Adapting Script for IIs (still)

jerrygarciuh has asked for the wisdom of the Perl Monks concerning the following question:

This script worked like a charm on *nix but the client's IIs server just has a fit. The latest is that no matter what input the script receives it just runs the show_news() sub. Bad passwords don't get bad_hacker_no_cookie(), attempts at file_up() get the error :Undefined subroutine CGI::upload, mail_routine() is not sending mail, and post_new_news() is not altering the text file.

The thing that is killing me here is that the script doesn't throw any errors (with the exception of the file upload) and goes and fires off show_news() every time.

Any advice is greatly appreciated!
TIA
jg

#!/usr/bin/perl -w
use strict;
use Fcntl ':flock';  # import LOCK_* constants

use CGI;
use CGI::Carp qw/fatalsToBrowser /;
use CGI ':standard';
use POSIX qw(strftime);

my $megabyte = 1024 * 1024;  # bytes
my $max_mb   = 1;     # max no. of MB we will allow

$CGI::DISABLE_UPLOADS = 0;
# CGI module variable for en/disabling uploads (non-zero to disable)
$CGI::POST_MAX = $megabyte * $max_mb;
# CGI module variable for maximum upload size (bytes)

my $q = CGI->new();

#######  CONFIG  ########################
my $mail ='thoseguys@mysite.com';
my $news_directory='D:\\Inetpub\\theirsite.org\\alerts\\';
my $path_to_text= "$news_directory\\body.txt";
my $path_to_header="$news_directory\\index.shtml";
my $goodpass="news";
my $newspage_url = "http://www.theirsite.org/alerts/";
my $this_script_url="http://www.theirsite.org/cgi-bin/alerts.cgi";
my $max_break_count= 20; #maximum number of lines before making post i
+nto seperate page
my $default_mail="theirsite"; #used in post if no name is given
my $domain="theirsite.org";  #no www. please
### File Upload Config###
my $base_dir = "/";
my $base_dom = "http://www.theirsite.org/";
my $target_dir = "alerts/images/";
#########################################

#declare some vars
my ($time_words,$topic,$words,$pass,$name,$user,$edit,$edit_done);
my ($line_break_count,$seperate_page,$textcolor,$textface,$textsize,$t
+opicsize);
my ($post_number,@updated_text,$plain_words,$upload_file,$image_link);
$/="\n\n\n";  #this is the delimiter for writing and rewriting the fil
+e


#Main routine
parse_form();
show_news();
get_time();

if ($pass ne $goodpass){
    bad_hacker_no_cookie();
}else {
    post_new_news();
}

mail_routine();
exit;
[download]


# Da subs
sub parse_form {
    my $sr;
    foreach my $str (qw(name words plain topic pass textcolor textface
+ textsize topicsize edit)) {
    $sr->{$str} =$q->param($str);
}

    $name =~ s/\s/_/g;

    $plain_words=$words;
    $words =~ s/\r\n/<BR>/g;
    while ($words=~ /<br>/gi ) {$line_break_count++}  #used in fork be
+low

    if ($q->param( "upload_file" )) { file_up(); }
    if ($edit eq "done") {
        send_edit_form();
    } elsif ($edit eq "yes") {                      #if params are und
+ef
        make_edit_form();
    }
    if ($line_break_count > $max_break_count) {
        seperate_page()
    }
}

sub get_time {

    my ($hour,$suffix);

    $hour= strftime ("%H", localtime ());
    if ($hour >= 12) {
        $suffix="PM";
    } else {
        $suffix = "AM";
    }
    if ($hour > 12) {
        $hour -= 12;
    }

    $time_words= strftime (" at $hour:%M $suffix on %m\/%d\/%Y \n", lo
+caltime ());
    $time_words;
}

sub post_new_news {
    open (FH, "+< $path_to_text") or die "where's the damn file? : $!"
+;
    flock (FH,LOCK_EX) or die "Couldn't flock: $!";
    my  @old_file = <FH>;
    seek FH, 0, 0;
    truncate (FH,0) or die "Can't truncate: $!";
    print FH qq|<b><font face=$textface color= #$textcolor size=$topic
+size>\n
            ::: $topic :::</b></font><br>\n
            <font face=$textface color= #$textcolor size=1>\n
            <div>posted by <a href="mailto:$name\@$domain"><font color
+=#0000FF>$name</font></a>\n
            $time_words.<p></div></font><p>\n
            <font face=$textface size=$textsize>&nbsp;&nbsp;$words</fo
+nt><p>
            <img src="$image_link"><p>\n\n\n|;
    print FH @old_file;
    flock(FH,LOCK_UN);  #unlock the file
    close FH or die "close damn you : $!";
    print "Location: $newspage_url\n\n";
}
[download]

sub seperate_page {
    get_time();
    open (TOPHTML, "$path_to_header") or die "where's the html file? :
+ $!";
    my  @html_file = <TOPHTML>;
    close TOPHTML;
    my $newhtml= strftime ("%m_%d_%Y", localtime ());
    open (NEWHTML, ">$news_directory\/$newhtml-$$.html") || die "Canno
+t create $newhtml ($!)";
    print NEWHTML @html_file;
    print NEWHTML qq|<b><font face=$textface color= #$textcolor size=$
+topicsize>\n
                 ::: $topic :::</b></font><br>\n
                 <font face=$textface color= #$textcolor size=1>\n
                <div>posted by <a href="mailto:$name\@$domain"><font c
+olor=#0000FF>$name</font></a>\n
                $time_words.<p></div></font><p>\n
                <font face=$textface size=$textsize>&nbsp;&nbsp;$words
+</font>
                </table></div></body></html> \n|;
    close NEWHTML;
    my $data    = $words;
    my $regex   = '.*?' . join('.*?', map { "<br>" } (1..8));
    my ($match) = $data =~ /($regex)/si;
    $words = "$match &nbsp;&nbsp;<a href=$newspage_url\/$newhtml-$$.ht
+ml><font color=#0000FF>MORE&gt;&gt;</font></a></p>";
}


sub file_up {
    local $| = 1;
    my ($bytesread,$buffer,$file);
    my $directory = $base_dir . $target_dir;
    my $fh = $q->upload('upload_file');
    my $filename = $q->param('upload_file');
    $filename =~ s/[^A-Za-z0-9\.\_]//g;
    $filename =~ s/windows//i;
    $filename =~ s/desktop//i;

    open(OUTF, '>' . $directory . $filename);
    while ($bytesread = read($fh, $buffer, 1024)) {
        print(OUTF $buffer);
    }
    close(OUTF);

    if (!$file && $q->cgi_error) {
        print($q->header(-status=>$q->cgi_error));
        exit 0;
    }


    $image_link = $base_dom . $target_dir . $filename;
    $image_link;
}






sub bad_hacker_no_cookie {
    print "Content-type: text/html\n\n";
     print "<HTML> \n";
     print "<body bgcolor=000000 text=99CCCC> \n";
     print "<CENTER><H1><font face=Arial>!Unauthorized Access!\n";
     print "<BR>";
     print "<font color = red>Hey bub, stop messin' with my News Page!
+\n";
     print "<BR>You are at IP address $user !";
     print "</H1></CENTER></font></body>";
}
sub mail_routine {
    if ($pass ne $goodpass) {
        open  MAIL,"|mail $mail" or die "mail problem : $!";
         print MAIL "$user tried to get in using $pass for a password.
+\n";
         print MAIL "They wanted to add $plain_words.";
         close MAIL;
     } else {
         open  MAIL,"|mail $mail" or die "mail problem : $!";
         print MAIL "$user changed the news to: $plain_words.\n";
         close MAIL;
     }
}
sub show_news { #This sub produces the current news page
    if ($topic eq "" && $words eq "") {
        open (FTXT, "$path_to_text") or die "where's the text file? : 
+$! is looking for $path_to_text";
        my  @text_file = <FTXT>;
        open (FHTML, "$path_to_header") or die "where's the html file?
+ : $!";
        my  @html_file = <FHTML>;
        print "Content-type: text/html\n\n";
        print @html_file;
        print @text_file;
        print "</table></div></body></html> \n";
        exit;
    } else {
        return;
    }
}

sub send_edit_form {
   my %FORM = $q->Vars('post_number');
   my $post_number = $q->param('post_number');
   my $start = $q->param('post_number');
   $pass = $q->param('pass');
   if ($pass eq $goodpass) {
       while ($post_number > 0) {
        if ( $q->param("box$post_number") ) {   # ignore deleted
        $_= $q->param("box$post_number");
        s/&quot;/"/g;
        s/&#039;/'/g;
        unshift @updated_text, $_;                 # keep the rest
        }
    $post_number--;
    }
    # now update file
    open(FH,">$path_to_text") || die $!;
    print FH join "\n\n\n", @updated_text;
    close(FH);
    print "Location: $newspage_url\n\n";
    exit;
 } else {
    bad_hacker_no_cookie();
    }
}



sub make_edit_form {
    open (FH, "$path_to_text") or die "where's the damn file? : $!";
    print header;
    print qq|<HTML>
            <BODY><center><form method="post" action="$this_script_url
+">\n
            <TABLE width=600><TR bgcolor=#000066><TD colspan=2 align=c
+enter>
            <font color=#ffffff><h2>Edit Your Posts</h2><br><font colo
+r=red>
            <h3>Uncheck Items To Delete Them</font></font><p>
            <font color="white"><b>Password:</b></font><input type="pa
+ssword" name="pass">
            <input type=submit name=Submit value="Delete Unchecked Pos
+ts">
            <p></TD><TR><TD>|;
    while (<FH>) {
        next if /^\n+$/;                  #ignore lines which contains
+ only newlines
        $post_number++;
        chomp;
        s/"/&quot;/g;
        s/'/&#039;/g;
        print qq|Save This Post? \n
            <input type=checkbox name="box$post_number" value=" $_ " c
+hecked><p>
              $_<hr>\n<p>\n<br><br><br>\n|;
      }
      close FH;
      print qq|</TD></TR><TR bgcolor="#333333"><TD align="center" cols
+pan="2">\n
          <input type="hidden" name="post_number" value="$post_number"
+>
          <input type="hidden" name="edit" value="done">
          <font color="#333333"><b>Password:</b></font></TD>
          </form></center></table></body></html>|;
    exit;
}
[download]

_____________________________________________________
If it gets a little bit out of hand sometimes, don't let it fool you into thinkin' you don't care.TvZ

Comment on Adapting Script for IIs (still) Select or Download Code

Replies are listed 'Best First'.
Re: Adapting Script for IIs (still) by dws (Chancellor) on Jan 02, 2002 at 10:14 UTC
This script worked like a charm on nix but the client's IIs server just has a fit.* Three suggestions: A useful technique when asking for help with a problem like this is to first strip the code down to a small example that exhibits a failure. Quite often, you'll solve the problem yourself. In this case, consider carefully the code paths by which you set `$pass`. If all else fails, compare the version of `CGI.pm` that you've been using on *nix to the one you're using on Win32.	[reply] [d/l] [select]
Re: Adapting Script for IIs (still) by theorbtwo (Prior) on Jan 02, 2002 at 10:33 UTC
"This script worked like a charm on *nix but the client's IIs server just has a fit. " This leads me to suspect specificly code that you changed to adapt it to the win32 environment... like your CONFIG section. I think you only want D:\\path\\name when you're in qq{} context (double-quotes); you only need D:\path\name in q{} context (single-quotes). It's worth a try, at least. I think in q{} context, \\ still maps to \, thought a single \ is legal... Thanks, James Mastros, Just Another Perl Scribe	[reply]