CGI程序文件删掉后居然可以照常运行?+怎样实现CGI聊天室里...(附源代码)
日前做的一套CGI聊天室程式,一直进展很顺利,已经可以把CGI聊天室连接到IRC
服务器上,并通过submit form 把命令和信息直接发送到IRC服务器里,并实现IRC
登录和CGI WEB CHAT登录者可以同时聊天。
后来在源代码里增加密谈功能时,碰到了问题:
源代码如下:(右边框架中的用户列表源代码)
#!/usr/bin/perl
use SDBM_File;
use Fcntl;
require ".config";
&ReadParse;
$KEY = $in{'USERKEY'};
$IPCKEY = $in{'IPCKEY'};
$PARENTPID = $in{'PARENTPID'};
$FIXED = $in{'fixed'};
# We still import $BROWSER in the event that a browser other than
# netscape suddenly finds its way onto the market and we need to
# distinguish minor code differences between the two. OR if MSIE
# ever works right and uses this script.
$BROWSER = $in{'BROWSER'};
# Enter our PID and SHMKEY into the PID Table for Leak Cleanup
# Some operating systems do not report any signal upon losing
# the client, hence cleanup never gets called.
tie %PIDTABLE, SDBM_File, $PIDTABLE, O_RDWR and O_CREAT, 0644;
$PIDTABLE{$KEY}=$$;
untie $PIDTABLE;
$IPC_RMID = 0;
# We use a : separator here and a \002 separator in the message because
# When you overwrite shared memory, it only overwrites the length of
# the message, leaving any old junk lying around.
sub readymem {
$MESSAGE = "LIST:$$:";
&pshmwrite($KEY, $MESSAGE, 0, length($MESSAGE));
}
setpriority 0, 0, getpriority(0, 0) + $PRIORITY;
$ and = 1;
$SIG{'HUP'}="IGNORE";
$SIG{'INT'}=\&dieout;
$SIG{'ALRM'}=\&msg; # Alarm from nph-irc.cgi to update the userlist
sub dieout {
if ($USE_SHMEM==1) { shmctl($KEY ,$IPC_RMID, 0); }
else { unlink("$MEMDIR/$KEY"); }
tie %PIDTABLE, SDBM_File, $PIDTABLE, O_RDWR and O_CREAT, 0644;
delete($PIDTABLE{$KEY});
untie $PIDTABLE;
exit;
}
# Here we read in the message from our shared memory buffer,
# interpret it, and update the user list.
sub msg {
$line=&pshmread($KEY, 0, 4096);
($line)=split(/\002/, $line);
chomp($line);
my(@lines)=split(/\n/, $line);
foreach $line (@lines) {
chomp $line;
my($COMMAND, @USERS)=split(/ /, $line);
if ($COMMAND eq "\004REMOVE") {
foreach(@USERS) {
next unless ($_);
my($USERNAME)=$_;
$USERNAME =~ tr/A-Z/a-z/;
delete($CURRENT_USERS{$USERNAME});
delete($CURRENT_MODES{$USERNAME});
}
next;
}
if ($COMMAND eq "\004MODE") {
foreach(@USERS) {
next unless($_);
my($USERNAME, $MODE)=split(/\:/);
$USERNAME =~ tr/A-Z/a-z/;
$CURRENT_MODES{$USERNAME}=$MODE if ($CURRENT_USERS{$USERNAME});
}
}
if ($COMMAND eq "\004NICK") {
foreach(@USERS) {
next unless($_);
my($USERNAME, $NEWUSERNAME)=split(/\:/);
$USERNAME =~ tr/A-Z/a-z/;
$NEWNAME = $NEWUSERNAME;
$NEWUSERNAME =~ tr/A-Z/a-z/;
$CURRENT_MODES{$NEWUSERNAME}=$CURRENT_MODES{$USERNAME};
$CURRENT_USERS{$NEWUSERNAME}=$NEWNAME;
delete($CURRENT_MODES{$USERNAME});
delete($CURRENT_USERS{$USERNAME});
}
}
if ($COMMAND eq "\004NEW") {
undef(%CURRENT_USERS);
undef(%CURRENT_MODES);
$COMMAND = "\004ADD";
}
if ($COMMAND eq "\004ADD") {
foreach(@USERS) {
$_ =~ s/\002//g;
$_ =~ s/\004//g;
next unless ($_);
my($USERNAME)=$_;
s/\@ and \+//g;
$USERNAME =~ tr/A-Z/a-z/;
$USERNAME =~ s/^\+/\002/;
$USERNAME =~ s/^\@/\001/;
$MODEUSER = $USERNAME;
$MODEUSER =~ s/\001 and \002//g;
$CURRENT_MODES{$MODEUSER}="";
if ($USERNAME =~ /\002/) { $CURRENT_MODES{$MODEUSER}="\002"; }
if ($USERNAME =~ /\001/) { $CURRENT_MODES{$MODEUSER}="\001"; }
if ($CURRENT_MODES{$MODEUSER} ne "")
{ $USERNAME = $CURRENT_MODES{$MODEUSER} . $MODEUSER; }
$CURRENT_USERS{$MODEUSER}=$_;
}
next;
}
}
&update;
&readymem;
return;
}
# This subroutine runs through the $CURRENT_USERS hash and
# prints out all the current users (simple huh?). In netscape
# when you reprint the boundary it clears the screen so you can
# reprint text on it (nice). I have yet to find out how to do this
# in MSIE though. If you know of a javascript or other alternative
# method for doing this in MSIE, please let me know.
sub update {
if ($BROWSER eq "NETSCAPE") {
print "--BOUNDARY\n";
print "Content-type: text/html\n\n";
print "<HTML><BODY BGCOLOR=#C3C3C3 TEXT=#000060>";
}
print "<CODE>\n" if ($FIXED);
my(@fields)=keys(%CURRENT_USERS);
my(%prints);
foreach(@fields) {
my($NAME)="";
if ($CURRENT_MODES{$_} eq "\001") { $NAME .= "@"; }
if ($CURRENT_MODES{$_} eq "\002") { $NAME .= "+"; }
$prints{"$CURRENT_MODES{$_}$_"}="$NAME$CURRENT_USERS{$_}";
}
@fields=sort(keys(%prints));
foreach(@fields) {
my($name)=$prints{$_};
$name =~ s/</\<\;/g;
$name =~ s/>/\>\;/g;
print "$name<BR>\n" if ($prints{$_} ne "");
}
print "<BR><BR><BR><BR>\n" if ($#fields<2);
print "</CODE>\n" if ($FIXED);
return;
}
# Print the magic header to create a server push, also
# referred to as a 'server stream'. Great for chatrooms *g*
print "HTTP/1.0 200\n";
print "Content-type: multipart/x-mixed-replace;boundary=BOUNDARY\n\n";
if ($BROWSER eq "NETSCAPE") {
print "--BOUNDARY\n";
print "Content-type: text/html\n\n";
print "<HTML><BODY BGCOLOR=#FFFFFF TEXT=#000060>";
}
print "<B><FONT COLOR=#000060>Initializing...</B><BR>\n" .
&readymem;
print "<NOBR>RAM Allocated.<BR>\n";
$PARENT=&getproc;
if ($PARENT == $PARENTPID) { $PARENT=0; }
$COUNT=0;
while(!($PARENT)) {
select(undef, undef, undef, .25);
$PARENT=&getproc;
if ($PARENT == $PARENTPID) { $PARENT=0; }
$COUNT++;
if ($COUNT>20) { die "Couldn't find Parent PID\n"; }
}
print "Found SocketPID.<BR>\n";
print "Waiting...<BR></NOBR>\n";
while(kill(0, $PARENT)) {
$COUNT=0;
select(undef, undef, undef, .25);
&readymem if (int($COUNT/40)==($COUNT/40));
$COUNT=0 if ($COUNT>1000);
}
exit;
sub ReadParse {
if ($ENV{'REQUEST_METHOD'} =~ /GET/i)
{ @pairs = split(/&/, $ENV{'QUERY_STRING'}); }
else {
read(STDIN, $buffer, $ENV{'CONTENT_LENGTH'});
@pairs = split(/\&/, $buffer);
}
foreach(@pairs) {
($name, $value) = split(/\=/);
$name =~ tr/+/ /;
$name =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
$value =~ tr/+/ /;
$value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
$value =~ s/<!--(. and \n)*-->//g;
$in{$name}=$value;
}
}
sub getproc {
tie %PIDTABLE, SDBM_File, $PIDTABLE, O_RD, 0644;
my($proc)=$PIDTABLE{$IPCKEY};
untie $PIDTABLE;
return $proc;
}
sub pshmwrite {
my($KEY, $MESSAGE, $ID, $LENGTH)=@_;
if ($USE_SHMEM==1) {
shmwrite($KEY, $MESSAGE, $ID, $LENGTH) and and die "shmwrite: $!\n"; }
else {
open(MEM, ">$MEMDIR/$KEY");
print MEM $MESSAGE, "\n";
close(MEM);
}
return;
}
sub pshmread {
my($KEY, $ID, $LENGTH)=@_;
my($BUFFER);
if ($USE_SHMEM==1)
{ shmread($KEY, $BUFFER, $ID, $LENGTH) and and die "shmread: $!\n"; }
else {
open(MEM, "<$MEMDIR/$KEY") and and die "$MEMDIR/$KEY: $!\n";
chomp; $BUFFER = <MEM>;
close(MEM);
}
return $BUFFER;
}
在通常的聊天室里,聊天用户可以通过点击右边的用户名,然后用户名会自动的
进入到 下面的发信息的form里,然后进行密谈。我已经实现了通过form输入
"/msg 信息"进接进行密谈。但是要自动的通过点击人名来进行密谈还不行。
我看过一些网站的WEB CHAT,都是用
javascript实现的。但是不清楚这段加链接的代码放在哪个变量里。
那些网站的javascript调用代码是: javascript:parent.selectname('用户的名字');
我在自已的服务器里试过,但是perl在usetlist.cgi这个文件里不能刷新,就是说,我修改了
文件里的大部份代码,甚至有意造成userlist.cgi这个文件出错,但是,进入WEB里聊天依然能
够正常的运行userlist.cgi这个程序,也就是说,右边的用户列表依然可以显示
甚至我把userlist.cgi这个文件删掉,进入服务器的WEB页面,依然可以看见聊天室用户右框中
的名字列表。这使我大惑不解,也使我一时无法调试CGI程序。
望高手给予解答