perl脚本共享区(欢迎大家把实用的脚本贴在这里) :2004年1月20日更新

777 · 发表于 2004-1-11 10:44:38

Problems with binary transfers in Net::FTP
come from this link:
http://www.perldiscuss.com/artic ... p;group=perl.libnet

Subject: Problems with binary transfers in Net::FTP
From: (F Marchettistasi)
Newsgroups: perl.libnet
Date: Feb 24 2003 11:27:56

I am writing a perl script to automatically transfer a section of
our Intranet to Internet, at the same time reformatting index
pages and rearranging directories. I am rather satisfied of the
outcome, but I have problems with the transfer of TIFF images:
apparently, they are transferred in ASCII mode, in spite of the
message "Opening BINARY data mode" in the log.

Here is a test script I used to narrow down the problem (sorry
for the masking of the addresses, even if we don't have an
explicit policy to that effect I think it's safer to avoid
sending them out):

-----<Cut here>-----
#!/usr/bin/perl -w

$debug = 1 ;

$localfile = "test.tif" ;
$remotefile = "test-auto.tif" ;

use Net::FTP ;
use Fcntl ;

$ftp = Net::FTP -> new ( "xxx.yyy.z.ww" ,
                     Debug => $debug , Passive => 0
                     ) ;
if ( ! defined $ftp ) {
print "Error: connection to the FTP server failed.\n" ;
print "Reason: $@\n" ;
exit 1 ;
}

$ftp -> login ( "xxxxxxxxxxxx" , "************" ) ;

if ( ! $ftp -> ok () ) {
print "Error connecting to the FTP server.\n" ;
$errortext = $ftp -> message ;
print "Reason: $errortext</p>\n" ;
exit 1 ;
}

$ftp -> cwd ( "xxx.xxxxxx.it/ProjectTest/ ) ;

# $ftp -> type ( "binary" ) ;
$ftp -> quot ( "TYPE" , "I" ) ;
$ftp -> put ( $localfile , $remotefile ) ;

# $dcref = $ftp -> stor ( $remotefile ) ;
# sysopen ( LOC , $localfile , O_RDONLY ) ;
# binmode LOC ;

# my $readbuf = '' ;
# my $nread = 0 ;
# my $bsize = 1024 ;
# while ( ( $nread = sysread ( LOC , $readbuf , $bsize ) ) != 0 )
{
#    $dcref -> write ( $readbuf , $nread ) ;
# }
# $dcref -> close ;
# close LOC ;

$ftp -> quit ;
-----<Cut here>-----

The (NT) server I am connecting to does not understand "TYPE
BINARY", so I have to send a "TYPE I" command instead. In the
commented section I tried to use a dataconn object to have more
control. I also tried to turn passive mode on, since the server
seems to prefer passive data transfer. The result is always the
same: the file transferred via manual ftp is correctly sent,
while the one transferred via Net:FTP gets corrupted.

And here is the output:

-----<Cut here>-----
Net::FTP: Net::FTP(2.65)
Net::FTP: Exporter(5.566)
Net::FTP: Net::Cmd(2.21)
Net::FTP: IO::Socket::INET(1.26)
Net::FTP:    IO::Socket(1.27)
Net::FTP:    IO::Handle(1.21)

Net::FTP=GLOB(0x806517c)<<< 220 InterScan FTP VirusWall NT 3.53
(Stand-alone Mode), Virus scan on
Net::FTP=GLOB(0x806517c)>>> user xxxxxxxxxxxx@xxx.yyy.z.ww
Net::FTP=GLOB(0x806517c)<<< 331 Password required for
xxxxxxxxxxxx.
Net::FTP=GLOB(0x806517c)>>> PASS ....
Net::FTP=GLOB(0x806517c)<<< 230 User xxxxxxxxxxxx logged in.
Net::FTP=GLOB(0x806517c)>>> CWD xxx.xxxxxx.it/ProjectTest/
Net::FTP=GLOB(0x806517c)<<< 250 CWD command successful.
Net::FTP=GLOB(0x806517c)>>> TYPE I
Net::FTP=GLOB(0x806517c)<<< 200 Type set to I.
Net::FTP=GLOB(0x806517c)>>> PORT xx,yyy,w,zz,14,24
Net::FTP=GLOB(0x806517c)<<< 200 PORT command successful.
Net::FTP=GLOB(0x806517c)>>> STOR test.tif
Net::FTP=GLOB(0x806517c)<<< 150 Opening BINARY mode data
connection for test.tif.
Net::FTP=GLOB(0x806517c)<<< 226-Message from InterScan FTP
VirusWall NT 3.53
Net::FTP=GLOB(0x806517c)<<< 226-No virus found in test.tif
Net::FTP=GLOB(0x806517c)<<< 226 Transfer complete.
Net::FTP=GLOB(0x806517c)>>> QUIT
Net::FTP=GLOB(0x806517c)<<< 221
-----<Cut here>-----

Everything seems just fine, doesn't it? Well it isn't; here is an
ftp session which demonstrates it:

-----<Cut here>-----
$ ftp xxx.yyy.z.ww
Connected to xxx.yyy.z.ww (xxx.yyy.z.ww).
220 InterScan FTP VirusWall NT 3.53 (Stand-alone Mode), Virus
scan on
331 Password required for xxxxxxxxxxxx.
230 User xxxxxxxxxxxx logged in.
Remote system type is Windows_NT.
ftp> cd xxx.xxxxxx.it/ProjectTest/
250 CWD command successful.
ftp> bin
200 Type set to I.
ftp> put test.tif
local: test.tif remote: test.tif
227 Entering Passive Mode (xxx,yyy,z,ww,10,47)
125 Data connection already open; Transfer starting.
226-Message from InterScan FTP VirusWall NT 3.53
226-No virus found in test.tif
226 Transfer complete.
110180 bytes sent in 0.325 secs (3.3e+02 Kbytes/sec)
ftp> ls
227 Entering Passive Mode (xxx,yyy,z,ww,10,63)
125 Data connection already open; Transfer starting.
02-24-03  10:58AM             110494 test-auto.tif
02-24-03  11:12AM             110180 test.tif
226 Transfer complete.
ftp> quit
221
$ wc -l test.tif
314 test.tif
-----<Cut here>-----

As you can see from the output of "wc", the tif "file" has 314
"lines", so that an additional octet is added for each "line", as
in ASCII mode.

Sorry for the length, I tried to be as precise as possible. Any
suggestion is HIGHLY welcome...

Francesco Marchetti-Stasi
(f.marchettistasi at avlp.it

devel · 发表于 2004-1-20 18:18:02

come from
http://developer.netscape.com/do ... rise/nt/cgitips.htm

A sample CGI program in Perl

The following Perl example prints a message about the browser being used, unless the browser is Netscape Navigator, in which case the example prints a different message. This shows how you can do different actions depending on the client browser. This example also shows how you get information from environment variables.

A CGI Perl example that checks the user's client browser

#!/bin/perl
# Remember that the above line must reflect where your perl really resides.
# sample2.pl: A simple Perl CGI program that displays a different message
#          depending on the user's browser.

# Terminate headers
print "Content-type: text/htmlnn";

# Get the User-Agent (also known as client type)
$user_agent = $ENV{"HTTP_USER_AGENT"};

# Print a header with appropriate information
print "  <TITLE>Which browser are you using?</TITLE>
<H1 align=center>Which browser are you using?</H1>";

# Print the browser that they're using.
print "<hr>I'm using <b>".$user_agent."</b><hr>n";

# If it's Mozilla (Netscape Navigator), tell them how cool they are.
if($user_agent =~ "Mozilla")
{ print "<i>Congratulations!</i>"; }
else
{ print "<i>To each his own, as they say.</i>"; }

print "<hr>";

The CGI Perl code that handles the form data

#!/bin/perl
# Remember that the above line has to reflect where your perl really resides. This is a
# simple form handler that uses form values to send mail to a hard-coded user.

# Terminate headers
print "Content-type: text/htmlnn";

# Who should get the email and where is the email program?
$send_to = "user@yourserver.yourdomain.dom";
$mail_prog = "/usr/lib/sendmail";

# See which method they used to access this form. If they used POST, then
# read the input from STDIN. If they used GET, use the query string.

# Which method is used is determined by the HTML in the form.
if($ENV{'REQUEST_METHOD'} eq "GET") {
$buffer = $ENV{'QUERY_STRING'};
if($buffer eq "")  {
print "<TITLE>Error - use HTML</TITLE>n";
print "<H1 align=center>

lease use the HTML form provided</H1>n";
print "You accessed this program without a valid query string. Please ";
print "use the associated form to access it.n";
exit(1);
}
}  else  {
read(STDIN, $buffer, $ENV{'CONTENT_LENGTH'});
}
# Split pairs by the ampersand that divides variables
@pairs = split(/&/, $buffer);
# Create an array, indexed by the variable name, that contains all the values

foreach $pair (@pairs)
{
# Each variable is structured "name1=value1", so split it on those lines
($name, $value) = split(/=/, $pair);

# Decode the value (+ is a space, and %xx in hex is an encoded character)
$value =~ tr/+/ /;
$value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
# Create an array indexed by names and put the value in
$form{$name} = $value;
}

# The program should have the following values:
#  email  = the person's email address
#  p_feed = the person's positive feedback
#  n_feed = the person's negative feedback
#
# Next, put it into a usable form and mail it. Check to see if they left an
# email address. Don't check to see if it's valid, just to see if it's there.
if($form{"email"} eq "")  {
print "<TITLE>Sorry</TITLE>n";
print "<h1 align=center>No email address given</h1>n";
print "<p align=center>Your request could not be sent because you ";
print "gave no return address. Please give a return address and ";
print "try again.</p>n";
exit(1);
}

# Open the mail command, or print an error.
open (MAIL, "|$mail_prog $send_to") || die "Could not open $mail_prog";

# Send the feedback. print MAIL "From: $form{'email'}n";

# Print the user's email address as a reply-to, and send the user a copy
print MAIL "Reply-to: $form{'email'}n";
print MAIL "Cc: $form{'email'}n";

# Terminate mail headers.
print MAIL "n";

# Create the document body
print MAIL "Feedback from ".$form{'email'}.":n";
print MAIL "--------------------------------------------------------------n";
print MAIL "n----Positive feedback----n";
print MAIL $form{'p_feed'};
print MAIL "n----Negative feedback----n";
print MAIL $form{'n_feed'};
print MAIL "n------------------------------------------------------------n";

# Close the command, and send the mail.
close (MAIL);

# Now print out a success story, so the user knows it was sent
print "<TITLE>Thanks for your feedback</TITLE>n";
print "<h1 align=center>Thanks for your feedback</h1>n";
print "Thanks for taking the time to give us your feedback. We hope that ";
print "with your help, we can make this an even better web site!n";
print "<hr>";

exit(0);

home · 发表于 2004-1-21 22:04:09

Internet TCP Clients and Servers

Use Internet-domain sockets when you want to do client-server communication that might extend to machines outside of your own system.

Here's a sample TCP client using Internet-domain sockets:

#!/usr/bin/perl -w require 5.002; use strict; use Socket; my ($remote,$port, $iaddr, $paddr, $proto, $line); $remote = shift || 'localhost'; $port = shift || 2345; # random port if ($port =~ /\D/) { $port = getservbyname($port, 'tcp') } die &quot;No port&quot; unless $port; $iaddr = inet_aton($remote) || die &quot;no host: $remote&quot;; $paddr = sockaddr_in($port, $iaddr); $proto = getprotobyname('tcp'); socket(SOCK, PF_INET, SOCK_STREAM, $proto) || die &quot;socket: $!&quot;; connect(SOCK, $paddr) || die &quot;connect: $!&quot;; while ($line = <sock>) { print $line; } close (SOCK) || die &quot;close: $!&quot;; exit;

And here's a corresponding server to go along with it. We'll leave the address as INADDR_ANY so that the kernel can choose the appropriate interface on multihomed hosts:

#!/usr/bin/perl -Tw require 5.002; use strict; BEGIN { $ENV{PATH} = '/usr/ucb:/bin' } use Socket; use Carp; sub spawn; # forward declaration sub logmsg { print &quot;$0 $$: @_ at &quot;, scalar localtime, &quot;\n&quot; } my $port = shift || 2345; my $proto = getprotobyname('tcp'); socket(SERVER, PF_INET, SOCK_STREAM, $proto) || die &quot;socket: $!&quot;; setsockopt(SERVER, SOL_SOCKET, SO_REUSEADDR, 1) || die &quot;setsockopt: $!&quot;; bind(SERVER, sockaddr_in($port, INADDR_ANY)) || die &quot;bind: $!&quot;; listen(SERVER,5) || die &quot;listen: $!&quot;; logmsg &quot;server started on port $port&quot;; my $waitedpid = 0; my $paddr; sub REAPER { $SIG{CHLD} = \&amp;REAPER; # loathe sysV $waitedpid = wait; logmsg &quot;reaped $waitedpid&quot; . ($? ? &quot; with exit $?&quot; : ''); } $SIG{CHLD} = \&amp;REAPER; for ( $waitedpid = 0; ($paddr = accept(CLIENT,SERVER)) || $waitedpid; $waitedpid = 0, close CLIENT) { next if $waitedpid; my($port,$iaddr) = sockaddr_in($paddr); my $name = gethostbyaddr($iaddr,AF_INET); logmsg &quot;connection from $name [&quot;, inet_ntoa($iaddr), &quot;] at port $port&quot;; spawn sub { print &quot;Hello there, $name, it's now &quot;, scalar localtime, &quot;\n&quot;; exec '/usr/games/fortune' or confess &quot;can't exec fortune: $!&quot;; }; } sub spawn { my $coderef = shift; unless (@_ == 0 &amp;&amp; $coderef &amp;&amp; ref($coderef) eq 'CODE') { confess &quot;usage: spawn CODEREF&quot;; } my $pid; if (!defined($pid = fork)) { logmsg &quot;cannot fork: $!&quot;; return; } elsif ($pid) { logmsg &quot;begat $pid&quot;; return; # i'm the parent } # else i'm the child -- go spawn open(STDIN, &quot;<&client") || die "can't dup client to stdin"; open(STDOUT, ">&amp;CLIENT&quot;) || die &quot;can't dup client to stdout&quot;; ## open(STDERR, &quot;&gt;&amp;STDOUT&quot;) || die &quot;can't dup stdout to stderr&quot;; exit &amp;$coderef(); }

This server takes the trouble to clone off a child version via fork() for each incoming request. That way it can handle many requests at once, which you might not always want. Even if you don't fork() , the listen() will allow that many pending connections. Forking servers have to be particularly careful about cleaning up their dead children (called ``zombies'' in Unix parlance), because otherwise you'll quickly fill up your process table.

We suggest that you use the -T flag to use taint checking (see the perlsec manpage ) even if we aren't running setuid or setgid. This is always a good idea for servers and other programs run on behalf of someone else (like CGI scripts), because it lessens the chances that people from the outside will be able to compromise your system.

Let's look at another TCP client. This one connects to the TCP ``time'' service on a number of different machines and shows how far their clocks differ from the system on which it's being run:

#!/usr/bin/perl -w require 5.002; use strict; use Socket; my $SECS_of_70_YEARS = 2208988800; sub ctime { scalar localtime(shift) } my $iaddr = gethostbyname('localhost'); my $proto = getprotobyname('tcp'); my $port = getservbyname('time', 'tcp'); my $paddr = sockaddr_in(0, $iaddr); my($host); $| = 1; printf &quot;%-24s %8s %s\n&quot;, &quot;localhost&quot;, 0, ctime(time()); foreach $host (@ARGV) { printf &quot;%-24s &quot;, $host; my $hisiaddr = inet_aton($host) || die &quot;unknown host&quot;; my $hispaddr = sockaddr_in($port, $hisiaddr); socket(SOCKET, PF_INET, SOCK_STREAM, $proto) || die &quot;socket: $!&quot;; connect(SOCKET, $hispaddr) || die &quot;bind: $!&quot;; my $rtime = ' '; read(SOCKET, $rtime, 4); close(SOCKET); my $histime = unpack(&quot;N&quot;, $rtime) - $SECS_of_70_YEARS ; printf &quot;%8d %s\n&quot;, $histime - time, ctime($histime); }

Unix-Domain TCP Clients and Servers

That's fine for Internet-domain clients and servers, but what local communications? While you can use the same setup, sometimes you don't want to. Unix-domain sockets are local to the current host, and are often used internally to implement pipes. Unlike Internet domain sockets, UNIX domain sockets can show up in the file system with an ls(1) listing.

$ ls -l /dev/log srw-rw-rw- 1 root 0 Oct 31 07:23 /dev/log

You can test for these with Perl's -S file test:

unless ( -S '/dev/log' ) { die &quot;something's wicked with the print system&quot;; }

Here's a sample Unix-domain client:

#!/usr/bin/perl -w require 5.002; use Socket; use strict; my ($rendezvous, $line); $rendezvous = shift || '/tmp/catsock'; socket(SOCK, PF_UNIX, SOCK_STREAM, 0) || die &quot;socket: $!&quot;; connect(SOCK, sockaddr_un($remote)) || die &quot;connect: $!&quot;; while ($line = <sock>) { print $line; } exit;

And here's a corresponding server.

#!/usr/bin/perl -Tw require 5.002; use strict; use Socket; use Carp; BEGIN { $ENV{PATH} = '/usr/ucb:/bin' } my $NAME = '/tmp/catsock'; my $uaddr = sockaddr_un($NAME); my $proto = getprotobyname('tcp'); socket(SERVER,PF_UNIX,SOCK_STREAM,0) || die &quot;socket: $!&quot;; unlink($NAME); bind (SERVER, $uaddr) || die &quot;bind: $!&quot;; listen(SERVER,5) || die &quot;listen: $!&quot;; logmsg &quot;server started on $NAME&quot;; $SIG{CHLD} = \&amp;REAPER; for ( $waitedpid = 0; accept(CLIENT,SERVER) || $waitedpid; $waitedpid = 0, close CLIENT) { next if $waitedpid; logmsg &quot;connection on $NAME&quot;; spawn sub { print &quot;Hello there, it's now &quot;, scalar localtime, &quot;\n&quot;; exec '/usr/games/fortune' or die &quot;can't exec fortune: $!&quot;; }; }

As you see, it's remarkably similar to the Internet domain TCP server, so much so, in fact, that we've omitted several duplicate functions--spawn(), logmsg(), ctime(), and REAPER()--which are exactly the same as in the other server.

So why would you ever want to use a Unix domain socket instead of a simpler named pipe? Because a named pipe doesn't give you sessions. You can't tell one process's data from another's. With socket programming, you get a separate session for each client: that's why accept() takes two arguments.

For example, let's say that you have a long running database server daemon that you want folks from the World Wide Web to be able to access, but only if they go through a CGI interface. You'd have a small, simple CGI program that does whatever checks and logging you feel like, and then acts as a Unix-domain client and connects to your private server.

home · 发表于 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";

}

复制代码

home · 发表于 2004-2-3 17:43:17

#!/usr/local/bin/perl

use strict;

my $url = 'http://path/to/receive.pl';

my $query = 'body=hogehoge';

main();

exit;

sub main {

do_post($url, $query);

}

sub do_post {

my ($url, $query) = @_;

$url =~ m|^(?:[url]http://[/url])?(.*?)(/.*)|;

my $host = $1;

my $uri = $2;

my $len = length($query);

my $addr = (gethostbyname($host))[4];

my $name = pack("S n a4 x8", 2, 80, $addr);

socket(SOCKET, 2, 1, 0);

connect(SOCKET, $name);

binmode(SOCKET);

select(SOCKET); $| = 1; select(STDOUT);

print SOCKET <<END;

POST $uri HTTP/1.0

Host: $host

Content-Length: $len

$query

END

while (<SOCKET>) {

print;

}

close(SOCKET);

}

复制代码

com from this link:
http://uttsu.com/r/20021120_4.html

jhuangjiahua · 发表于 2004-6-4 20:30:46

3个perl脚本,用来分别把文本格式转换为
DOS/Windows系统和UNIX/Linux系统及Mac系统的
[PHP]\064"

-----text3dos.pl---------------------------
#!/usr/bin/perl
while(<stdin>){
$_=~/\r\n/\r;
$_=~/\n/\r;
$_=~/\r/\r\n;
print $_;
}
# DOS/Windows系统和UNIX/Linux系统及Mac系统的行结束符不一样.
# DOS/Windows 的行结束符是 "\r\n" (回车符+换行符)
# UNIX/Linux 的行结束符是 "\n" (换行符)
# Mac 的行结束符是 "\r" (回车符)
#
#本例把UNIX/Linux 的行结束符转换为DOS/Windows 的行结束符
#
#建议把她放到patch下，如 /usr/local/bin
#
#本例把标准输入的文本转换后送到标准输入。
#
#如 #cat textfile | text3dos.pl > texefile.txt
#
# jhuangjiahua@163.com
#

-----text3unix.pl---------------------------
#!/usr/bin/perl
while(<stdin>){
$_=~/\r\n/\n;
$_=~/\r/\n;
print $_;
}

-----text3mac.pl---------------------------
#!/usr/bin/perl
while(<stdin>){
$_=~/\r\n/\r;
$_=~/\n/\r;
print $_;
}

"[/PHP]

bst · 发表于 2004-12-12 09:50:43

各位朋友在发贴的时候能不能把程序的作用,和一些关键的地方作一些注释,这样新来的读起来就方便多了,也方便各位以后在复习.
谢谢各位的努力.

sunxiaobo · 发表于 2005-11-1 13:10:52

author: me
utility: guestbook
testing: http://www.uni-ulm.de/~s_xsun/
code: http://www.uni-ulm.de/~s_xsun/tmp/cgi.pm

黄叶 · 发表于 2006-1-9 11:49:04

楼主的脚本是Perl NetWork Program<

erl网络编程》里的例子。
呵呵。

phus · 发表于 2006-7-24 22:49:28

以前的写的一个脚本，用来批量下载163相册里的图片。
演示了如何使用LWP模块

#!/usr/bin/perl
#
# File: down.pl
# Author: phus

use strict;
use warnings;

use LWP::UserAgent;
use HTTP::Request::Common;
use Encode;
use File:

ath;

sub lwp_get($;%)
{
my ($url, %opt) = @_;

my $uri = URI->new($url);
my $referer = $uri->scheme."://".$uri->host.$uri->path unless (%opt || $opt{referer});
my $useragent = 'Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1' unless (%opt || $opt{useragent});

my $ua = LWP::UserAgent->new();

my $req = HTTP::Request->new(GET => $url);
$req->header('Host' => $uri->host);
$req->header('User-Agent' => $useragent);
$req->header('Referer' => $referer);
$req->header('Cookie' => $opt{cookie});

my $res = $ua->request($req);
warn "fetch_page error! perhaps you should try again.\n" unless $res->is_success;

if($opt{remote_charset} && $opt{local_charset} && ($opt{remote_charset} ne $opt{local_charset}))
{
      return encode($opt{local_charset}, decode($opt{remote_charset}, $res->as_string));
}

return $res->as_string;
}

sub lwp_post($$;%)
{
my ($url, $form_ref, %opt) = @_;

my $uri = URI->new($url);
my $referer = $uri->scheme."://".$uri->host.$uri->path unless (%opt || $opt{referer});
my $useragent = 'Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1' unless (%opt || $opt{useragent});
my $cookie = ' '  unless (%opt || $opt{cookie});

my $ua = LWP::UserAgent->new();
$ua->default_headers->push_header('Host' => $uri->host,);
$ua->default_headers->push_header('User-Agent' => $useragent,);
$ua->default_headers->push_header('Referer' => $referer,);
$ua->default_headers->push_header('Cookie' => $cookie);

my $res = $ua->request(POST $url, Content => ${form_ref});

warn "lwp_post faild!perhaps you supply a right password.\n" unless $res->is_success;

return $res->as_string;
}

sub nease_split($$$)
{
my ($html, $user, $aid) = @_;
my ($datas) = $html =~ /var datas = \[(.*)\]/g;
my ($gPhotosIds) = $html =~ /var gPhotosIds = \[(.*)\];/g;

my (@hostids, @type, @name, @photoids);
@photoids = split(/,/, $gPhotosIds);
@hostids = $datas =~ /\[(\d\d\d),\d,"\d+x\d+","[^\]]* "\]/g;
@type = $datas =~ /\[\d\d\d,(\d),"\d+x\d+","[^\]]* "\]/g;
@name = $datas =~ /\[\d\d\d,\d,"\d+x\d+","([^\]]*) "\]/g;

my @ext_types = ('.jpg', '.jpg', '.gif');
my @url = ();
foreach (0..$#photoids) {
      push(@url, "http://img".$hostids[$_].".photo.163.com/".$user."/".$aid."/".$photoids[$_].$ext_types[$type[$_]]);
      $name[$_] .= $ext_types[$type[$_]] unless ($name[$_] =~ /$ext_types[$type[$_]]$/)
}

return (\@url, \@name);
}

my ($user, $aid, $pwd) = @ARGV;
die "usage: $0 \$user \$aid [\$password]\n" if((not defined($user)) || (not defined($aid)));

my $aurl = "http://photo.163.com/photos/$user/$aid/";
my $iurl = "http://photo.163.com/js/photosinfo.php?user=$user&aid=$aid";

my ($html, $cookie);
if($pwd) {
my %form =  ('checking' => '1', 'pass' => $pwd);
$html = lwp_post($aurl, \%form);
($cookie) = $html =~ /Set\-Cookie

.*)/ig;
}

$html = lwp_get($iurl, (cookie => $cookie));
my ($url_ref, $name_ref) = nease_split($html, $user, $aid);

my $folder = "$user/$aid";
mkpath($folder, 1, 0755);

my $ret;
foreach (0..$#${url_ref}) {
print "\n$_/$#${url_ref} downloaded. ".$name_ref->[$_]."\n";
next if(-f "$folder/".$name_ref->[$_+2]);
$ret = `wget -c --referer=http://photo.163.com/photos/ $url_ref->[$_] -O \"$folder/$name_ref->[$_]\"`;
}

		自动登录	找回密码
密码			注册

perl脚本共享区(欢迎大家把实用的脚本贴在这里) :2004年1月20日更新

send.pl

分别把文本格式转换为 DOS/Windows系统和UNIX/Linux系统及Mac系统的