|
发表于 2004-1-27 00:42:04
|
显示全部楼层
come from
http://www.zevils.com/cgi-bin/cv ... c/tocserver?rev=1.5
不知道干什么用的?
- #!/usr/bin/perl
- use Data::Dumper;
- use Toc qw(:all);
- use IO::Socket;
- use IO::Select;
- use GDBM_File;
- use Fcntl;
- use Fcntl qw(:flock);
- use POSIX;
- my($sock, $pid, $screenname);
- $pid = fork;
- exit unless $pid == 0;
- POSIX::setsid();
- $sock = IO::Socket::INET->new(LocalPort => 5000, Listen => 5) or die "Couldn't sock: $@\n";
- $dir = (getpwent())[7];
- unlink "$dir/toc.db";
- unlink "$dir/chatseq";
- system("rm -f $dir/*.lock");
- sub dbtie() {
- my $VAR1;
- while(-f "$dir/toc.db.lock") { select(undef, undef, undef, 0.01); }
- touch("$dir/toc.db.lock");
- open(TOC, "$dir/toc.db");
- local $/ = undef;
- my $toc = <TOC>;
- eval $toc;
- %toc = %$VAR1;
- close TOC;
- #print "Loaded DB: ", Data::Dumper::Dumper(\%toc), "\n";
- }
- sub dbuntie() {
- open(TOC, ">$dir/toc.db");
- print TOC Data::Dumper::Dumper \%toc;
- #print "Dumping DB: ", Data::Dumper::Dumper(\%toc), "\n";
- close TOC;
- unlink "$dir/toc.db.lock";
- }
- sub END { $server->close if $server; $client->close if $client; }
- sub chatseq() {
- while(-f "$dir/chatseq.lock") { select(undef, undef, undef, 0.01); }
- touch("$dir/chatseq.lock");
- open(CHATSEQ, "$dir/chatseq");
- my $chatseq = <CHATSEQ> or "0";
- close CHATSEQ;
- $chatseq++;
- open(CHATSEQ, ">$dir/chatseq");
- print CHATSEQ $chatseq;
- close CHATSEQ;
- unlink("$dir/chatseq.lock");
- return $chatseq;
- }
- sub touch($) {
- my $file = shift;
- open(FILE, ">$file");
- close FILE;
- }
- sub putmsg($$) {
- my $who = shift;
- my $message = shift;
- my ($inmsg, @messages, $VAR1);
- push @{$queue{$who}}, $message if $message;
- return if -f "$dir/$who" or not @{$queue{$who}};
- print "Put $message!\n";
- while(-f "$dir/$who.lock") { select(undef, undef, undef, 0.01); }
- touch("$dir/$who.lock");
- open(MSG, ">$dir/$who");
- print MSG scalar pop @{$queue{$who}};
- close MSG;
- unlink("$dir/$who.lock");
- print "$screenname putmsg($who, $message)\n";
- }
- sub getmsg() {
- my(@messages, $VAR1);
- while(-f "$dir/$screenname.lock") { select(undef, undef, undef, 0.01); }
- touch("$dir/$screenname.lock");
- open(MSG, "$dir/$screenname");
- local $/ = undef;
- my $message = <MSG>;
- print "Got $message!\n";
- close MSG;
- unlink "$dir/$screenname";
- unlink "$dir/$screenname.lock";
- print STDERR "getmsg($screenname, $message)\n";
- return $message;
- }
- sub tellbuds($) {
- my $message = shift;
- my $person;
- foreach $person(keys %{$toc{people}}) {
- next unless exists $toc{people}{$person}{on} and exists $toc{people}{$person}{buddies}{$screenname};
- putmsg($person, $message);
- }
- }
- sub unquote($) {
- my $msg = shift;
- $msg =~ s/\\\\/\\/g;
- $msg =~ s/\\\$/\$/g; $msg =~ s/\\\[/\[/g; $msg =~ s/\\]/]/g;
- $msg =~ s/\\\(/\(/g; $msg =~ s/\\\)/\)/g; $msg =~ s/\\\#/\#/g;
- $msg =~ s/\\\{/\{/g; $msg =~ s/\\\}/\}/g; $msg =~ s/\\"/"/g;
- $msg =~ s/\\\'/\'/g; $msg =~ s/\\\`/\`/g;
- return $msg;
- }
- sub leavechat($) {
- my $chat = shift;
- my $chatname;
- my $person;
- $chatname = $toc{people}{$screenname}{chats}{$chat};
- foreach $person(keys %{$toc{chats}{$chatname}}) {
- next if $person eq $screenname;
- putmsg($person, "CHAT_UPDATE_BUDDY:".$toc{chats}{$chatname}{$person}.":F:$screenname");
- }
- delete $toc{chats}{$chatname}{$screenname};
- }
- sub toc_signoff() {
- my $chat;
- my $chatname;
- my $person;
- dbtie;
- foreach $chat(keys %{$toc{people}{$screenname}{chats}}) {
- leavechat($chat);
- }
- delete $toc{people}{$screenname};
- tellbuds("UPDATE_BUDDY:$screenname:F:0:0:0: ");
- unlink "$dir/$screenname";
- dbuntie;
- }
- $Toc::config{temp}{paused} = 0;
- while($client = $sock->accept) {
- my($line, $message, $command, @params, $person, $flags);
- $pid = fork();
- die "Couldn't fork: $!" unless defined $pid;
- if($pid == 0) {
- $client->close;
- next;
- }
- ${*$client}{'net_toc_username'} = 'temp';
- $client->read($line, 10);
- die unless $line eq "FLAPON\r\n\r\n";
- $flags = 0;
- fcntl($client, F_GETFL, $flags);
- $flags |= O_NONBLOCK;
- fcntl($client, F_SETFL, $flags);
- #sflap_do($client, "SIGN_ON:1.0");
- sflap_put($client, sflap_encode(pack("N", 1), 1));
- $message = sflap_get($client, 1);
- (undef, undef, undef, $screenname) = unpack("Nnna*", $message); #signon packet
- $Toc::config{$screenname}{paused} = 0;
- ${*$client}{'net_toc_username'} = $screenname;
- sflap_get($client, 1);
- sflap_do($client, "SIGN_ON:TOC1.0");
- sflap_do($client, "NICK:$screenname");
- sflap_do($client, "CONFIG:m 1\ng Buddies\nb $screenname");
- while(1) {
- foreach $person(keys %queue) {
- putmsg($person, undef);
- }
- select(undef, undef, undef, 0.1);
- if(-f "$dir/$screenname") {
- sflap_do($client, getmsg());
- }
- $message = sflap_get($client);
- if($message eq "-1" and $! != EAGAIN) {
- toc_signoff;
- die "Client died: $!\n";
- } elsif($message eq "-1" or $message =~ /^\s*$/) {
- next;
- } else {
- #print "We got $message!\n";
- }
- for($i = length($message) - 1; $i >= 0; $i--) {
- substr($message, $i, 1, "") if substr($message, $i, 1) eq chr(0);
- }
- dbtie;
- my @new = ();
- push(@new, $+) while $message =~ m{
- "([^"\\]*(?:\\.[^"\\]*)*)"\s? # groups the phrase inside the quotes
- | ([^ ]+)\s?
- | \s
- }gx;
- push(@new, undef) if substr($message,-1,1) eq ' ';
- ($command, @params) = map { unquote($_) } @new;
- #print "command=$command.\n";
- if($command eq "toc_init_done") {
- print "toc{people}{$screenname}?\n";
- $toc{people}{$screenname}{on} = 1;
- print Data::Dumper::Dumper($toc{people}{$screenname}), "\n";
- tellbuds("UPDATE_BUDDY:$screenname:T:0:".time.":0: O");
- } elsif($command eq "toc_send_im") {
- my($who, $message) = @params;
- print "toc{people}{$who}?\n";
- print Data::Dumper::Dumper($toc{people}{$who}), "\n";
- if(exists $toc{people}{$who}{on}) {
- putmsg($who, "IM_IN:$screenname:F:$message");
- } else {
- putmsg($screenname, "ERROR:901:$who");
- }
- } elsif($command eq "toc_add_buddy") {
- foreach $person(@params) {
- $toc{people}{$screenname}{buddies}{$person} = 1;
- if(exists($toc{people}{$person}{on})) {
- putmsg($screenname, "UPDATE_BUDDY:$person:T:0:".time.":0: O");
- }
- }
- } elsif($command eq "toc_remove_buddy") {
- foreach $person(@params) {
- delete $toc{people}{$screenname}{buddies}{$person};
- }
- } elsif($command eq "toc_set_config") {
- } elsif($command eq "toc_evil") {
- } elsif($command eq "toc_add_permit") {
- } elsif($command eq "toc_add_deny") {
- } elsif($command eq "toc_chat_join") {
- my $chat = chatseq();
- $toc{chats}{$params[1]}{$screenname} = $chat;
- $toc{people}{$screenname}{chats}{$chat} = $params[1];
- putmsg($screenname, "CHAT_JOIN:$chat:".$params[1]);
- putmsg($screenname, "CHAT_UPDATE_BUDDY:$chat:T:".join(":", keys %{$toc{chats}{$params[1]}}));
- foreach $person(keys %{$toc{chats}{$params[1]}}) {
- next if $person eq $screenname;
- $chat = $toc{chats}{$params[1]}{$person};
- putmsg($person, "CHAT_UPDATE_BUDDY:$chat:T:$screenname");
- }
- } elsif($command eq "toc_chat_send") {
- my $chat = $params[0];
- $message = $params[1];
- my $chatname = $toc{people}{$screenname}{chats}{$chat};
- foreach $person(keys %{$toc{chats}{$chatname}}) {
- putmsg($person, "CHAT_IN:".$toc{chats}{$chatname}{$person}.":$screenname:F:$message");
- }
- } elsif($command eq "toc_chat_whisper") {
- my $chat = $params[0];
- $person = $params[1];
- $message = $params[2];
- my $chatname = $toc{people}{$screenname}{chats}{$chat};
- putmsg($person, "CHAT_IN".$toc{chatname}{$person}.":$screenname:T:$message");
- } elsif($command eq "toc_chat_evil") {
- } elsif($command eq "toc_chat_invite") {
- my $chat = shift @params;
- $message = shift @params;
- my $chatname = $toc{people}{$screenname}{chats}{$chat};
- foreach $person(@params) {
- $chat = chatseq();
- $toc{people}{$person}{invites}{$chat} = $chatname;
- putmsg($person, "CHAT_INVITE:$chatname:$chat:$screenname:$message");
- }
- } elsif($command eq "toc_chat_leave") {
- leavechat($params[0]);
- } elsif($command eq "toc_chat_accept") {
- my $chat = shift @params;
- my $chatname = $toc{people}{$screenname}{invites}{$chat};
- $toc{chats}{$chatname}{$screenname} = $chat;
- $toc{people}{$screenname}{chats}{$chat} = $chatname;
- putmsg($screenname, "CHAT_JOIN:$chat:$chatname");
- putmsg($screenname, "CHAT_UPDATE_BUDDY:$chat:T:".join(":", keys %{$toc{chats}{$chatname}}));
- foreach $person(keys %{$toc{chats}{$chatname}}) {
- next if $person eq $screenname;
- $chat = $toc{chats}{$chatname}{$person};
- putmsg($person, "CHAT_UPDATE_BUDDY:$chat:T:$screenname");
- }
- } elsif($command eq "toc_get_info") {
- } elsif($command eq "toc_set_info") {
- } elsif($command eq "toc_set_away") {
- if($params[0]) {
- tellbuds("UPDATE_BUDDY:$screenname:T:0:".time.":0: OU");
- } else {
- tellbuds("UPDATE_BUDDY:$screenname:T:0:".time.":0: O");
- }
- } elsif($command eq "toc_get_dir") {
- } elsif($command eq "toc_set_dir") {
- } elsif($command eq "toc_dir_search") {
- } elsif($command eq "toc_set_idle") {
- } elsif($command eq "toc_set_caps") {
- } elsif($command eq "toc_rvous_propose") {
- } elsif($command eq "toc_rvous_accept") {
- } elsif($command eq "toc_rvous_cancel") {
- } elsif($command eq "toc_format_nickname") {
- } elsif($command eq "toc_change_passwd") {
- }
- dbuntie;
- }
- }
- sub Toc::debug_print($$$) {
- my($text, $type, $level) = @_;
- #print STDERR "($level, $type) $text";
- }
复制代码 |
|