CGI程序文件删掉后居然可以照常运行?+怎样实现CGI聊天室里...(附源代码)

perlbabymoon11 2000-03-24 02:54:00
日前做的一套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程序。

望高手给予解答

...全文
266 4 打赏 收藏 转发到动态 举报
写回复
用AI写文章
4 条回复
切换为时间正序
请发表友善的回复…
发表回复
iamcloud 2000-09-05
  • 打赏
  • 举报
回复
聊天室本来就应该连服务器程序都自己写的,用socket创建服务器,浏览器作为客户端,而服务器则是一个守护进程存在,这样的聊天室才配称做是聊天室。
http://cloud.o-red.com/chat
小弟不才,写了这么一个程序,(当然有所参考)
chaska 2000-08-27
  • 打赏
  • 举报
回复
userlist.cgi这个程序是为netscape准备的,而对于ie浏览器,在线人数的更新是通过
nph-irc.cgi程序输出窗口中的javascript函数操作的(替换在线窗口中id为text的
innerHTML
sunsetyang 2000-03-25
  • 打赏
  • 举报
回复
你有没有试过在删除后刷新页面一下?确定一下你修改的文件就是外部所可见的那个cgi文件!!
King 2000-03-24
  • 打赏
  • 举报
回复
问一下,这个好象是普通的聊天室CGI,怎么和IRC相连?

2,204

社区成员

发帖
与我相关
我的任务
社区描述
Web 开发 CGI
社区管理员
  • CGI社区
加入社区
  • 近7日
  • 近30日
  • 至今
社区公告
暂无公告

试试用AI创作助手写篇文章吧