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

devel

这里是perl脚本共享区
请注明脚本的作者，最好是附加上一些简单的解释。要是从这里转贴，请注明来自黄嘴企鹅论坛www.linuxsir.cn

一些脚本
http://www.cpan.org/scripts/index.html
ftp://ftp.funet.fi/pub/languages/perl/CPAN/scripts

注意：所有的置顶贴子禁止闲谈和灌水，谢谢合作。

devel

来自internet

The echo client and echo server don't play well together because they don't agree on the end of line character (however, the server will work correctly with telnet, and the client will work well with other echo servers, including tcp_echo_serv1.pl).

To make the client talk to the server, you must modify it to append CRLF sequences to the end of each input line, as shown in this revised example.

#!/usr/bin/perl
# file: tcp_echo_cli1.pl
# Figure 4.1: A TCP Echo Client

# usage: tcp_echo_cli1.pl [host] [port]

use strict;
use Socket qw(EFAULT :crlf);
use IO::Handle;
my ($bytes_out,$bytes_in) = (0,0);

my $host = shift || 'localhost';
my $port = shift || getservbyname('echo','tcp');

my $protocol = getprotobyname('tcp');
$host = inet_aton($host) or die "$host: unknown host";

socket(SOCK, AF_INET, SOCK_STREAM, $protocol) or die "socket() failed: $!";
my $dest_addr = sockaddr_in($port,$host);
connect(SOCK,$dest_addr) or die "connect() failed: $!";

SOCK->autoflush(1);

while (my $msg_out = <>) {
    chomp $msg_out;
    $msg_out .= CRLF;
    print SOCK $msg_out;
    my $msg_in = <SOCK>;
    print $msg_in;

    $bytes_out += length($msg_out);
    $bytes_in  += length($msg_in);
}

close SOCK;
print STDERR "bytes_sent = $bytes_out, bytes_received = $bytes_in\n";

devel

来自intenel,这个脚本提供一个TCP echo 服务，版本是2

#!/usr/bin/perl
# file: tcp_echo_serv2.pl
# Figure 5.4: The reverse echo server, using IO::Socket

# usage: tcp_echo_serv2.pl [port]

use strict;
use IO::Socket qw(EFAULT :crlf);
use constant MY_ECHO_PORT => 2007;
$/ = CRLF;
my ($bytes_out,$bytes_in) = (0,0);

my $quit = 0;
$SIG{INT} = sub { $quit++ };

my $port     = shift || MY_ECHO_PORT;

my $sock = IO::Socket::INET->new( Listen    => 20,
                                  LocalPort => $port,
                                  Timeout   => 60*60,
                                  Reuse     => 1)
  or die "Can't create listening socket: $!\n";

warn "waiting for incoming connections on port $port...\n";
while (!$quit) {
  next unless my $session = $sock->accept;

  my $peer = gethostbyaddr($session->peeraddr,AF_INET) || $session->peerhost;
  my $port = $session->peerport;
  warn "Connection from [$peer,$port]\n";

  while (<$session>) {
    $bytes_in  += length($_);      
    chomp;
    my $msg_out = (scalar reverse $_) . CRLF;
    print $session $msg_out;
    $bytes_out += length($msg_out);
  }
  warn "Connection from [$peer,$port] finished\n";
  close $session;
}

print STDERR "bytes_sent = $bytes_out, bytes_received = $bytes_in\n";
close $sock;

devel

来自INTERNET 使用IO::Socket的daytime客户。


#!/usr/bin/perl
# file: time_of_day_tcp2.pl
# Figure 5.1 Time of day client using IO::Socket

use strict; #使用标准的格式。
use IO::Socket qw(EFAULT :crlf);  #2加载模块，

my $host = shift || 'localhost';#从命令行获取远程主机的名字。

$/ = CRLF;#设置行尾分割符。
my $socket = IO::Socket::INET->new("$host:daytime")
    or die "Can't connect to daytime service at $host: $!\n"; #6,7创建套解字。
chomp(my $time = $socket->getline); #取的时间并把它赋给一个句柄。
print $time,"\n";



运行：
#perl time_of_day_tcp2.pl wuarchive.wustl.edu
TIME

home

来自internet使用Mial::Internet发送电子邮件。

#!/usr/bin/perl -w
use Mail::Internet; #load module.

my $head=Mail::Header->new;
$head->add(From => 'John Doe <doe@acme.org>'); #创建邮件的头部，use Mail::Header model.please look at perldoc Mail::Header
$head->add(To   => 'L Stein <lstein@lsjs.org>' );
$head->add(Cc   => 'jac@acome.org');
$head->add(Cc   => 'vvd@acome.org');
$head->add(Subject  => 'hello there');

my $body = <<END ; #editor contain of mail
This is just a simple e-mail message.
Nothing to get excited about.

Regards, JD
END

$mail =Mail::Internet->new(Header => $head ,#这几行是创建Mail::Internet对象，
                           Body   => [$body] ,
                           Modify => 1 );
print $mail->send('sendmail'); #发送邮件。

devel

一个客户端的聊天程序，来自INTERNET。

#!/usr/bin/perl -w
# file: chat_client.pl
# Figure 19.2: Chat client using UDP

use strict;
use IO::Socket;
use IO::Select;
use ChatObjects::ChatCodes;
use ChatObjects::Comm;
#以上几行是导入模块。

$SIG{INT} = $SIG{TERM} = sub { exit 0 };
my ($nickname,$server);
#以上两行是：安装信号处理程序。
# dispatch table for commands from the user
my %COMMANDS = (
                channels  => sub { $server->send_event(LIST_CHANNELS)      },
                join      => sub { $server->send_event(JOIN_REQ,shift)     },
                part      => sub { $server->send_event(PART_REQ,shift)     },
                users     => sub { $server->send_event(LIST_USERS)         },
                public    => sub { $server->send_event(SEND_PUBLIC,shift)  },
                private   => sub { $server->send_event(SEND_PRIVATE,shift) },
                login     => sub { $nickname = do_login()      },
                quit      => sub { undef },
               );

# dispatch table for messages from the server
my %MESSAGES = (
                ERROR()        => \&error,
                LOGIN_ACK()    => \&login_ack,
                JOIN_ACK()     => \&join_part,
                PART_ACK()     => \&join_part,
                PUBLIC_MSG()   => \&public_msg,
                PRIVATE_MSG()  => \&private_msg,
                USER_JOINS()   => \&user_join_part,
                USER_PARTS()   => \&user_join_part,
                CHANNEL_ITEM() => \&list_channel,
                USER_ITEM()    => \&list_user,
               );
#以上是定义调度表。

# Create and initialize the UDP socket
my $servaddr = shift || 'localhost';
my $servport = shift || 2027;
$server = ChatObjects::Comm->new(PeerAddr  => "$servaddrservport") or die $@;
#以上是创建UDP套接字和服务器封装器。

# Try to log in
$nickname = do_login();  
die "Can't log in.\n" unless $nickname;

# Read commands from the user and messages from the server
my $select = IO::Select->new($server->socket,\*STDIN);
LOOP:
while (1) {
  my @ready = $select->can_read;
  foreach (@ready) {
    if ($_ eq \*STDIN) {
      do_user(\*STDIN) || last LOOP;
    } else {
      do_server($_);
    }
  }
}

# called to handle a command from the user
sub do_user {
  my $h = shift;
  my $data;
  return   unless sysread($h,$data,1024);  # longest line
  return 1 unless $data =~ /\S+/;
  chomp($data);
  my($command,$args) = $data =~ m!^/(\S+)\s*(.*)!;
  ($command,$args) = ('public',$data) unless $command;
  my $sub = $COMMANDS{lc $command};
  return do_help() unless $sub;
  return $sub->($args);
}

# called to handle a message from the server
sub do_server {
  die "invalid socket" unless my $s = ChatObjects::Comm->sock2server(shift);
  die "can't receive: $!" unless
    my ($mess,$args) = $s->recv_event;
  my $sub = $MESSAGES{$mess} || return warn "$mess: unknown message from server\n";
  $sub->($mess,$args);
  return $mess;
}

# try to log in (repeatedly)
sub do_login {
  $server->send_event(LOGOFF,$nickname) if $nickname;
  my $nick = get_nickname();  # read from user
  my $select = IO::Select->new($server->socket);

  for (my $count=1; $count <= 5; $count++) {
    warn "trying to log in ($count)...\n";
    $server->send_event(LOGIN_REQ,$nick);
    next unless $select->can_read(6);
    return $nick if do_server($server->socket) == LOGIN_ACK;
    $nick = get_nickname();
  }

}

# prompt user for his nickname
sub get_nickname {
  while (1) {
    local $| = 1;
    print "Your nickname: ";
    last unless defined(my $nick = <STDIN>);
    chomp($nick);
    return $nick if $nick =~ /^\S+$/;
    warn "Invalid nickname.  Must contain no spaces.\n";
  }
}

# handle an error message from server
sub error {
  my ($code,$args) = @_;
  print "\t** ERROR: $args **\n";
  print "\tType /help for help\n";
}

# handle login acknowledgement from server
sub login_ack {
  my ($code,$nickname) = @_;
  print "\tLog in successful.  Welcome $nickname.\n";
}

# handle channel join/part messages from server
sub join_part {
  my ($code,$msg) = @_;
  my ($title,$users) = $msg =~ /^(\S+) (\d+)/;
  print $code == JOIN_ACK
    ? "\tWelcome to the $title Channel ($users users)\n"
    : "\tYou have left the $title Channel\n";
}

# handle channel listing messages from server
sub list_channel {
  my ($code,$msg) = @_;
  my ($title,$count,$description) = $msg =~ /^(\S+) (\d+) (.+)/;
  printf "\t%-20s %-40s %3d users\n","[$title]",$description,$count;
}

# handle a public message from server
sub public_msg {
  my ($code,$msg) = @_;
  my ($channel,$user,$text) = $msg =~ /^(\S+) (\S+) (.*)/;
  print "\t$user [$channel]: $text\n";
}

# handle a private message from server
sub private_msg {
  my ($code,$msg) = @_;
  my ($user,$text) = $msg =~ /^(\S+) (.*)/;
  print "\t$user [**private**]: $text\n";
}

# handle user join/part messages from server
sub user_join_part {
  my ($code,$msg) = @_;
  my $verb = $code == USER_JOINS ? 'has entered' : 'has left';
  my ($channel,$user) = $msg =~ /^(\S+) (\S+)/;
  print "\t<$user $verb $channel>\n";
}

# handle user listing messages from server
sub list_user {
  my ($code,$msg) = @_;
  my ($user,$timeon,$channels) = $msg =~ /^(\S+) (\d+) (.+)/;
  my ($hrs,$min,$sec) = format_time($timeon);
  printf "\t%-15s (on %02d:%02d:%02d) Channels: %s\n",$user,$hrs,$min,$sec,$channels;
}

# nicely formatted time (hr, min sec)
sub format_time {
  my $sec = shift;
  my $hours = int( $sec/(60*60) );
  $sec     -= ($hours*60*60);
  my $min   = int( $sec/60 );
  $sec     -= ($min*60);
  return ($hours,$min,$sec);
}

# print help message
sub do_help {
  print <<END;
        Commands:
          /channels             List chat channels
          /join <channel>       Join a channel
          /part <channel>       Depart a channel
          /users                List users in current channel
          /public <msg>         Send a public message
          /private <user> <msg> Send a private message to user
          /login                Login again
          /quit                 Quit

        Typing anything that doesn't begin with a "/" is interpreted as a message
        to the current channel.
END
}

END {
  if (defined $server) {
    $server->send_event(LOGOFF,$nickname);
    $server->close;
  }
}

devel

一个服务端的聊天程序，来自INTERNET。

#!/usr/bin/perl -w
# file: chat_server.pl
# Figure 19.5: Chat server using UDP

use strict;
use ChatObjects::ChatCodes;
use ChatObjects::Comm;
use ChatObjects::User;
use ChatObjects::Channel;
use constant DEBUG => 0;

# create a bunch of channels
ChatObjects::Channel->new('CurrentEvents',  'Discussion of current events');
ChatObjects::Channel->new('Weather',        'Talk about the weather');
ChatObjects::Channel->new('Gardening',      'For those with the green thumb');
ChatObjects::Channel->new('Hobbies',        'For hobbyists of all types');
ChatObjects::Channel->new('Pets',           'For our furry and feathered friends');

# dispatch table
my %DISPATCH = (
                LOGOFF()        => 'logout',
                JOIN_REQ()      => 'join',
                PART_REQ()      => 'part',
                SEND_PUBLIC()   => 'send_public',
                SEND_PRIVATE()  => 'send_private',
                LIST_CHANNELS() => 'list_channels',
                LIST_USERS()    => 'list_users',
                );

# create the UDP socket
my $port = shift || 2027;
my $server = ChatObjects::Comm->new(LocalPort=>$port);
warn "servicing incoming requests...\n";

while (1) {
  next unless my ($code,$msg,$addr) = $server->recv_event;

  warn "$code $msg\n" if DEBUG;
  do_login($addr,$msg,$server) && next if $code == LOGIN_REQ;

  my $user = ChatObjects::User->lookup_byaddr($addr);
  $server->send_event(ERROR,"please log in",$addr) && next
    unless defined $user;

  $server->send_event(ERROR,"unimplemented event code",$addr) && next
    unless my $dispatch = $DISPATCH{$code};
  $user->$dispatch($msg);
}

sub do_login {
  my ($addr,$nickname,$server) = @_;
  return $server->send_event(ERROR,"nickname already in use",$addr)
    if ChatObjects::User->lookup_byname($nickname);
  return unless ChatObjects::User->new($addr,$nickname,$server);
}

devel

一个与日期时间服务器相匹配得客户程序。

#!/usr/bin/perl
# file: localtime_cli.pl
# Figure 22.4: localtime_cli.pl, Daytime Client

#load model
use IO::Socket;
use POSIX 'tmpnam';
use Getopt:ong;

#define const
use constant SOCK_PATH     => '/tmp/localtime';
use constant TIMEOUT       => 1;

my $path;
GetOptions("path=s" => \$path);
$path ||= SOCK_PATH;
my $local = tmpnam();

$SIG{TERM} = $SIG{INT} = sub { exit 0 };

# set umask to be world writable ...create a socket.
umask(0111);
my $sock = IO::Socket::UNIX->new( Type  => SOCK_DGRAM,
                                  Local => $local,
                                ) or die "Socket: $!";

my $timezone = shift || ' ';
my $peer     = sockaddr_un($path);

#send request and wait reply.
send($sock,$timezone,0,$peer) or die "Couldn't send(): $!";
my $data;
eval {
  local $SIG{ALRM} = sub { die "timeout\n" };
  alarm(TIMEOUT);
  recv($sock,$data,128,0)       or die "Couldn't recv(): $!";
  alarm(0);
} or die "Couldn't get response: $@";
print $data,"\n";


END { unlink $local if $local }

azheng

好东东，谢谢！辛苦啦！

注意：从现在开始，请不要在置顶贴子里闲谈和灌水，谢谢合作！

KornLee

from: http://www.linuxsir.cn/bbs/showthread.php?threadid=46381


#!/usr/bin/perl

if ( $#ARGV != 0 ){
printf(STDERR "Usage: perl treedir.pl directory\n");
exit(0);
}

glob $vtab="|";
glob @fmt=();

glob @dirs=();

search_dir($ARGV[0]);

sub listdir{
my ($dirname) = @_;

opendir(DIR_HANDLE, $dirname);
my (@dirlist) = readdir(DIR_HANDLE);

shift(@dirlist);
shift(@dirlist);

closedir(DIR_HANDLE);
return @dirlist;
}

sub getPath{
return join("/",@dirs);
}

sub search_dir{
my ($dirnm)=@_;

push(@dirs,$dirnm); # cd $dirnm
my (@entries)=listdir(getPath());
my ($count)=$#entries;

foreach $file (@entries) {

if (0==$count){
$vtab="\\\\";
}

display($file);
$vtab="|";

if (-d getPath()."/".$file){

if($count==0){
push(@fmt,"\t");
}
else {
push(@fmt,"|\t");
}

search_dir($file);
}

$count--;
}

pop(@fmt);
pop(@dirs); # cd ..
}

sub display{
my ($entry)=@_;
my ($formats)=join("",@fmt);

print $formats.$vtab."-----".$entry."\n";
}


windows linux 下都可使用。
查找的目录级非常大，足够实用。