File Lock Error

#!/usr/bin/perl ############# Begin Setup ############### # complete url or path to directory images are located # this is all you are required to change, rest is optional. $imagedir = 'http://www.afrol.com/Services/bluechat'; # if you have to place all the cgi files in # your cgi-bin directory, then the chat directory # must be placed outside the cgi-bin directory. # change chatpath to the absolute path to the chat # directory and chaturl to the http://whatever url. # Leave as is for most installations. $chatpath = './chat'; $chaturl = './chat'; # Chat refresh time, in seconds $ChatRefresh = 10; # Time to leave messages $ChatMessageTime = 180; # Enable chat logging? 0 is false, 1 is true. # If you enable logging, be sure to check the # log file often, it can grow in size quickly. $chatLogging = '0'; $logFileName = 'chat_history.htm'; # bad words will be filtered out of chat. # you can add or remove them if you want. # Notice you can use Perl regular expressions too. @badwords = ("dsafjkld"); # You can exclude one channel from badwords filtering. # If you want all channels to be excluded, remove all the # badwords instead. $exclude_channel = 'adult'; ############### End Setup ################# print "Content-type: text/html\nPragma: no-cache\n\n"; # get the form data. &get_form_data; # check for room, and read the old message file $formdata{'room'} =~ s/\W//g; $formdata{'room'} = lc($formdata{'room'}); &lock($chatpath . '/' . $formdata{'room'} . '.lck'); # create room if not exist. if (!(-e "$chatpath/$formdata{'room'}\.htm")) { open(CREATE, ">$chatpath/$formdata{'room'}\.htm"); close(CREATE); } open(HTMLOLD, "$chatpath/$formdata{'room'}\.htm") || &myerror("Unable to open room: $formdata{'room'}"); @lines=; close(HTMLOLD); # time message printed. my $thetime = time; # write and output new messages file $newmessage = ''; if (($formdata{'cname'} ne '') && ($formdata{'message'} ne '')){ # remove all badwords $exclude_channel = lc($exclude_channel); if ($exclude_channel ne $formdata{'room'}) { foreach $curse (@badwords) { $formdata{'message'} =~ s/$curse/\\%\&\#\%\<\/font\>/ig; $formdata{'cname'} =~ s/$curse/\\%\&\#\%\<\/font\>/ig; } } # format the message $ColoredName = $formdata{'cname'}; $ColoredMessage = $formdata{'message'}; # replace smilely faces $ColoredMessage =~ s/\:\)/\

/g; $ColoredMessage =~ s/\:\(/\

/g; $ColoredMessage =~ s/\;\)/\

/g; # check for me action if ($ColoredMessage =~ s/^\.me//i) { $ColoredName = &Make_Color('`1|||`4|||`1|||`% ' . $ColoredName); $ColoredMessage = &Make_Color('`2' . $ColoredMessage . ''); } else { $ColoredName = &Make_Color($ColoredName . '`%:'); $ColoredMessage = &Make_Color($ColoredMessage); } $newmessage = "$ColoredName $ColoredMessage
\n"; } open (NEW, ">$chatpath/$formdata{'room'}\.htm"); print NEW "\n"; print NEW '' . "\n"; print NEW '' . "\n"; print NEW '' . "\n"; print NEW "\n"; print "\n"; print '' . "\n"; print '' . "\n"; print '' . "\n"; print "\n"; for ($i = 1; $i < @lines; $i++) { $lines[$i] =~ m//; if ((time - $1) <= $ChatMessageTime) { if ($lines[$i] ne "\n") { print NEW "$lines[$i]"; print "$lines[$i]"; } } } if ($newmessage ne '') { print NEW $newmessage; print $newmessage; if ($chatLogging) { my $now_string = gmtime; if (open(CHATLOG, ">>$chatpath/$logFileName")) { print CHATLOG '' . $now_string . '-' . $formdata{'room'} . '-' . $newmessage; close(CHATLOG); } } } print NEW "\n"; print "\n"; close(NEW); &unlock($chatpath . '/' . $formdata{'room'} . '.lck'); exit; # Gets Form data, also removes html formatting. sub get_form_data { if ($ENV{'REQUEST_METHOD'} eq 'GET') { @pairs = split(/&/, $ENV{'QUERY_STRING'}); } else { $buffer = ""; read(STDIN, $buffer, $ENV{'CONTENT_LENGTH'}); @pairs=split(/&/,$buffer); } foreach $pair (@pairs) { @a = split(/=/,$pair); $name=$a[0]; $value=$a[1]; $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg; $value =~ s/~!/ ~!/g; $value =~ s/\+/ /g; $value =~ s/\/\>\;/g; # remove to enable html tags in messages. $value =~ s/\r//g; push (@data,$name); push (@data, $value); } %formdata=@data; %formdata; } sub myerror { my $msg = shift; &unlock($chatpath . '/' . $formdata{'room'} . '.lck'); print $msg; exit; } sub Make_Color { my $st = shift; my $result = ''; my $colors = 0; my $i; my $ch; for ($i=0; $i < length($st); $i++) { if (substr($st,$i,1) eq '`') { $i++; if ($i > length($st)) { next; } $ch = substr($st,$i,1); if ($ch eq '1') {$result .= ''; $colors++;} elsif ($ch eq '2') {$result .= ''; $colors++;} elsif ($ch eq '3') {$result .= ''; $colors++;} elsif ($ch eq '4') {$result .= ''; $colors++;} elsif ($ch eq '5') {$result .= ''; $colors++;} elsif ($ch eq '6') {$result .= ''; $colors++;} elsif ($ch eq '7') {$result .= ''; $colors++;} elsif ($ch eq '8') {$result .= ''; $colors++;} elsif ($ch eq '9') {$result .= ''; $colors++;} elsif ($ch eq '0') {$result .= ''; $colors++;} elsif ($ch eq '!') {$result .= ''; $colors++;} elsif ($ch eq '@') {$result .= ''; $colors++;} elsif ($ch eq '#') {$result .= ''; $colors++;} elsif ($ch eq 'A') {$result .= ''; $colors++;} elsif ($ch eq '$') {$result .= ''; $colors++;} elsif ($ch eq '%') {$result .= ''; $colors++;} } else { $result .= substr($st,$i,1); } } while ($colors--) { $result .= ''; } return ($result); } sub lock { $mylockfile = shift; my $endtime = time + 7; if (-e $mylockfile) { open (LOCKFILE, $mylockfile); my $temp = ; close (LOCKFILE); if ($temp < time) { unlink ($mylockfile); } } while (-e $mylockfile && time < $endtime) { sleep(1); } if (-e $mylockfile) { &error("Can't obtain file lock for $mylockfile"); } else { open (LOCKFILE, ">$mylockfile") or &error ("Can't obtain file lock for $mylockfile"); print LOCKFILE (time + 10); close(LOCKFILE); } } sub unlock { $mylockfile = shift; # close (LOCKFILE); unlink ($mylockfile); } sub error { my $msg = shift; print "File Lock Error\n"; print '

Click Here to try again.

'; print "\n

$msg

\n"; print '

This may be caused by a slow server.

'; print ''; exit; }