[devel]

谢谢georgek从网上找到的脚本。

#!/usr/bin/perl -w

#
# Copyright (C) 2003 by the gtk2-perl team (see the file AUTHORS for the full
# list)
#
# This library is free software; you can redistribute it and/or modify it under
# the terms of the GNU Library General Public License as published by the Free
# Software Foundation; either version 2.1 of the License, or (at your option)
# any later version.
#
# This library is distributed in the hope that it will be useful, but WITHOUT
# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
# FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for
# more details.
#
# You should have received a copy of the GNU Library General Public License
# along with this library; if not, write to the Free Software Foundation, Inc.,
# 59 Temple Place - Suite 330, Boston, MA 02111-1307 USA.
#
# $Header: /cvsroot/gtk2-perl/gtk2-perl-xs/Gtk2/examples/histogramplot.pl,v 1.8 2003/10/19 04:42:44 muppetman Exp $
#

# originally written in C by muppet in 2001 or 2002, i can't remember.
# ported from C to gtk2-perl 2003 by muppet

package Histogram::Plot;

use Gtk2;
use warnings;
use strict;
use Data::Dumper;

use constant FALSE => 0;
use constant TRUE => 1;

use constant MIN_CHART_WIDTH => 256;
use constant MIN_CHART_HEIGHT => 100;

my %drag_info;
use constant DRAG_PAD => 2;

sub screen_to_threshold {
my ($plot, $sx) = @_;
my $val = ($sx - $plot->{chartleft}) * 256 / $plot->{chartwidth};
return $val < 0 ? 0 : $val > 255 ? 255 : $val;
}
sub threshold_to_screen {
$_[1] / 256.0 * $_[0]->{chartwidth} + $_[0]->{chartleft}
}


#
# Glib::Objects are special; they're not normal perl objects (although
# the bindings go out of their way to make them act like it).
#
# if you just want to add a new function for yourself to a Gtk2::DrawingArea,
# the stuff we're about to get into is not strictly necessary; you could just
# re-bless the object reference into the decendent class and add an @ISA for
# it, like normal perl.
#
# however, adding signals, properties, or virtual function overrides to a
# GObject-based class requires fiddling with a GObjectClass structure
# specific to that subclass. if you added a new property to a re-blessed
# Glib::Object, *all* instances of that reblessed object's GObject parent
# would have the new property! that's because you didn't create a new
# GObjectClass for that new subclass.
#
# in order to create a new type to which you can add signals and properties,
# and which will be indistinguishable from "normal" GObjects at the C level
# (which means you can pass it to other gtk functions), you need to
# register your subclass with the Glib::Type subsystem.
#
# here, we're registering the current package as a new subclass of
# Gtk2::DrawingArea, and in the process adding a signal and a few
# object properties.
#
use Glib::Object::Subclass
'Gtk2::DrawingArea',
signals => {
#
# create a new signal...
#
threshold_changed => {
method => 'do_threshold_changed',
flags => [qw/run-first/],
return_type => undef, # void return
param_types => [], # instance and data are automatic
},
#
# override some built-ins... note that for this to work
# there has to be a signal to go along with the virtual
# function you want to override...
#
# i chose do_size_request to keep from having the normal
# size_request method being called.
size_request => \&do_size_request,
# just to show it off... you can use names, but you have
# to use a qualified name, or it looks in the current package
# at runtime, not setup time.
expose_event => __PACKAGE__.'::expose_event',
configure_event => \&configure_event,
motion_notify_event => \&motion_notify_event,
button_press_event => \&button_press_event,
button_release_event => \&button_release_event,
},
properties => [
Glib::ParamSpec->double ('threshold',
'Threshold',
'Diving line between above and below',
0.0, 255.0, 127.0,
[qw/readable writable/]),
Glib::ParamSpec->boxed ('histogram',
'Histogram Data',
'Array reference containing histogram data',
'Glib::Scalar',
[qw/readable writable/]),
Glib::ParamSpec->boolean ('continuous',
'Continuous updates',
'Emit the threshold_changed signal on every mouse event during drag, rather than just on release',
FALSE,
[qw/readable writable/]),
],
;

#
# at the lowest level, new Glib::Objects are created by Glib::Object::new.
# that function creates the instance and calls the instance initializers
# for all classes in the object's lineage, from the parent to the descendant.
# if there's any setup you would need to do in a constructor, it goes here.
#
sub INIT_INSTANCE {
my $plot = shift;
warn "INIT_INSTANCE $plot";

$plot->{threshold} = 0;
$plot->{histogram} = [ 0..255 ];
$plot->{pixmap} = undef;
$plot->{th_gc} = undef;
$plot->{dragging} = FALSE;
$plot->{continuous} = FALSE;
$plot->{origin_layout} = $plot->create_pango_layout ("0.0%");
$plot->{maxval_layout} = $plot->create_pango_layout ("100.0%");
$plot->{current_layout} = $plot->create_pango_layout ("0");
$plot->{maxscale_layout} = $plot->create_pango_layout ("255");
$plot->{minscale_layout} = $plot->create_pango_layout ("0");
$plot->{max} = 0;

$plot->{chartwidth} = 0;
$plot->{chartleft} = 0;
$plot->{bottom} = 0;
$plot->{height} = 0;

$plot->set_events ([qw/exposure-mask
leave-notify-mask
button-press-mask
button-release-mask
pointer-motion-mask
pointer-motion-hint-mask/]);
}


#
# whenever anybody tries to get the value of a gobject property belonging
# to this class, this function will be called. note that this call
# signature is different from the C version -- here we return the requested
# value.
#
sub GET_PROPERTY {
my ($plot, $pspec) = @_;
if ($pspec->get_name eq 'threshold') {
return $plot->{threshold};
} elsif ($pspec->get_name eq 'histogram') {
return $plot->{histogram};
} elsif ($pspec->get_name eq 'continuous') {
return $plot->{continuous};
}
}

#
# whenever anybody tries to set the value of a gobject property belonging
# to this class, this function will be called. the provided Glib::Object::Base
# method just stores the value in a hash key, but here we need to do other
# bits of work when a value is changed.
#
# note that this one also is changed from the C call signature; the order
# of the arguments has been swizzled to be more consistent with GET_PROPERTY.
#
sub SET_PROPERTY {
my ($plot, $pspec, $newval) = @_;
if ($pspec->get_name eq 'threshold') {
$plot->set_plot_data ($newval, ());
} elsif ($pspec->get_name eq 'histogram') {
$plot->set_plot_data (undef, @$newval);
} elsif ($pspec->get_name eq 'continuous') {
$plot->{continuous} = $newval;
}
}


sub calc_dims {
my $plot = shift;

my $context = $plot->{origin_layout}->get_context;
my $fontdesc = $context->get_font_description;
my $metrics = $context->get_metrics ($fontdesc, undef);

$plot->{textwidth} = 5 * $metrics->get_approximate_digit_width
/ Gtk2::Pango->scale; #PANGO_SCALE;
$plot->{textheight} = ($metrics->get_descent + $metrics->get_ascent)
/ Gtk2::Pango->scale; #PANGO_SCALE;

$plot->{chartleft} = $plot->{textwidth} + 2;
$plot->{chartwidth} = $plot->allocation->width - $plot->{chartleft};
$plot->{bottom} = $plot->allocation->height - $plot->{textheight} - 3;
$plot->{height} = $plot->{bottom};
}

# this gets called when the widget's parent container wants to know
# how much space we want. it's important to note that this sub will be
# called from deep within the gtk library, not from perl code, which is
# why it had to be implemented as a class closure override.
# we modify the requisition passed to us.
sub do_size_request {
my ($plot, $requisition) = @_;
warn "in class override for $_[0]\::do_size_request";

$requisition->width ($plot->{textwidth} + 2 + MIN_CHART_WIDTH);
$requisition->height ($plot->{textheight} + MIN_CHART_HEIGHT);

# chain up to the parent class.
shift->signal_chain_from_overridden (@_);
}


sub expose_event {
my ($plot, $event) = @_;

$plot->window->draw_drawable ($plot->style->fg_gc($plot->state),
$plot->{pixmap},
$event->area->x, $event->area->y,
$event->area->x, $event->area->y,
$event->area->width, $event->area->height);
return FALSE;
}

sub configure_event {
my ($plot, $event) = @_;

$plot->{pixmap} = Gtk2::Gdk::Pixmap->new ($plot->window,
$plot->allocation->width,
$plot->allocation->height,
-1); # same depth as window

# update dims
$plot->calc_dims;

$plot->histogram_draw;

return TRUE;
}

sub draw_th_marker {
my ($plot, $w, $draw_text) = @_;

if (!$plot->{th_gc}) {
$plot->{th_gc} = Gtk2::Gdk::GC->new ($plot->{pixmap});
$plot->{th_gc}->copy ($plot->style->fg_gc ($plot->state));
$plot->{th_gc}->set_function ('invert');
}
$w->draw_line ($plot->{th_gc},
$plot->threshold_to_screen ($plot->{threshold}), 0,
$plot->threshold_to_screen ($plot->{threshold}), $plot->{bottom});

$plot->{current_layout}->set_text (sprintf '%d', $plot->{threshold});
my ($textwidth, $textheight) = $plot->{current_layout}->get_pixel_size;
$plot->{marker_textwidth} = $textwidth;

# erase text
$w->draw_rectangle ($plot->style->bg_gc($plot->state),
TRUE,
$plot->threshold_to_screen ($plot->{threshold})
- $plot->{marker_textwidth} - 1,
$plot->{bottom} + 1,
$plot->{marker_textwidth} + 1,
$textheight);

$w->draw_layout ($plot->{th_gc},
$plot->threshold_to_screen ($plot->{threshold})
- $plot->{marker_textwidth},
$plot->{bottom} + 1,
$plot->{current_layout})
if $draw_text;
}

#
# the user can click either very near the vertical line of the marker
# or on (actually in the bbox of) the marker text.
#
sub marker_hit {
my ($plot, $screen_x, $screen_y) = @_;

my $screen_th = $plot->threshold_to_screen ($plot->{threshold});
if ($screen_y > $plot->{bottom}) {
# check for hit on text
if ($screen_x > $screen_th - $plot->{marker_textwidth} &&
$screen_x <= $screen_th) {
return $screen_th;
}
} else {
# check for hit on line
if ($screen_x > $screen_th - DRAG_PAD &&
$screen_x < $screen_th + DRAG_PAD) {
return $screen_th;
}
}
return undef;
}

sub button_press_event {
my ($plot, $event) = @_;

return FALSE
if ($event->button != 1 || not defined $plot->{pixmap});

my $sx = $plot->marker_hit ($event->x, $event->y);
return FALSE
unless defined $sx;

# erase the previous threshold line from the pixmap...
$plot->{threshold_back} = $plot->{threshold};
$plot->draw_th_marker ($plot->{pixmap}, FALSE);
$plot->window->draw_drawable ($plot->style->fg_gc($plot->state),
$plot->{pixmap},
$plot->threshold_to_screen ($plot->{threshold}) - $plot->{marker_textwidth}, 0,
$plot->threshold_to_screen ($plot->{threshold}) - $plot->{marker_textwidth}, 0,
$plot->{marker_textwidth} + 1, $plot->allocation->height);
# and draw the new one on the window.
$plot->draw_th_marker ($plot->window, TRUE);
$plot->{dragging} = TRUE;

$drag_info{offset_x} =
$plot->threshold_to_screen ($plot->{threshold}) - $event->x;

return TRUE;
}

sub button_release_event {
my ($plot, $event) = @_;

return FALSE
if ($event->button != 1
|| !$plot->{dragging}
|| not defined $plot->{pixmap});

# erase the previous threshold line from the window...
$plot->draw_th_marker ($plot->window, FALSE);
$plot->{threshold} =
$plot->screen_to_threshold ($event->x + $drag_info{offset_x});
# and draw the new one on the pixmap.
$plot->draw_th_marker ($plot->{pixmap}, TRUE);
$plot->window->draw_drawable ($plot->style->fg_gc ($plot->state),
$plot->{pixmap},
0, 0, 0, 0,
$plot->allocation->width,
$plot->allocation->height);
$plot->{dragging} = FALSE;

# let any listeners know that if the threshold has changed
$plot->signal_emit ("threshold-changed")
if $plot->{threshold_back} != $plot->{threshold}
and not $plot->{continuous};

return TRUE;
}

my $sizer;

sub motion_notify_event {
my ($plot, $event) = @_;

my ($x, $y, $state);

if ($event->is_hint) {
(undef, $x, $y, $state) = $event->window->get_pointer;
} else {
$x = $event->x;
$y = $event->y;
$state = $event->state;
}
if ($plot->{dragging}) {
return FALSE
if (!(grep /button1-mask/, @$state) ||
not defined $plot->{pixmap});

$plot->draw_th_marker ($plot->window, FALSE);

$x += $drag_info{offset_x};

# confine to valid region
my $t = $plot->screen_to_threshold ($x);
$x = $plot->threshold_to_screen (0) if $t < 0;
$x = $plot->threshold_to_screen (255) if $t > 255;

$plot->{threshold} = $plot->screen_to_threshold ($x);
$plot->draw_th_marker ($plot->window, TRUE);

$plot->signal_emit ("threshold-changed")
if $plot->{continuous};

} else {
my $c = undef;
my $sx = $plot->marker_hit ($x, $y);
if (defined $sx) {
$sizer = Gtk2::Gdk::Cursor->new ('GDK_SB_H_DOUBLE_ARROW')
if not defined $sizer;
$c = $sizer;
}
$plot->window->set_cursor ($c);
}

return TRUE;
}



sub histogram_draw {
my $plot = shift;
my $gc = $plot->style->fg_gc ($plot->state);

# erase (the hard way)
$plot->{pixmap}->draw_rectangle ($plot->style->bg_gc ($plot->state),
TRUE, 0, 0,
$plot->allocation->width,
$plot->allocation->height);

if ($plot->{max} != 0 && scalar(@{$plot->{histogram}})) {
##GdkPoint points[256+2];
my @hist = @{ $plot->{histogram} };
my @points = ();
for (my $i = 0; $i < 256; $i++) {
push @points,
$i/256.0 * $plot->{chartwidth} + $plot->{chartleft},
$plot->{bottom} - $plot->{height} * $hist[$i] / $plot->{max};
}
$plot->{pixmap}->draw_polygon ($gc, TRUE, @points,
$plot->allocation->width, $plot->{bottom} + 1,
$plot->{chartleft}, $plot->{bottom} + 1);
}
# mark threshold
# should draw this after the scale...
draw_th_marker ($plot, $plot->{pixmap}, TRUE);
# the annotations
$plot->{pixmap}->draw_line ($gc, 0, 0, $plot->{chartleft}, 0);
$plot->{pixmap}->draw_line ($gc, 0, $plot->{bottom},
$plot->{chartleft}, $plot->{bottom});
$plot->{pixmap}->draw_line ($gc, $plot->{chartleft}, $plot->{bottom},
$plot->{chartleft},
$plot->{bottom} + $plot->{textheight} + 1);
$plot->{pixmap}->draw_line ($gc,
$plot->allocation->width - 1, $plot->{bottom},
$plot->allocation->width - 1, $plot->{bottom} + $plot->{textheight} + 1);
$plot->{pixmap}->draw_layout ($gc,
$plot->{chartleft} - (1 + $plot->{textwidth}),
1, $plot->{maxval_layout});
$plot->{pixmap}->draw_layout ($gc,
$plot->{chartleft} - (1 + $plot->{textwidth}),
$plot->{bottom} - 1 - $plot->{textheight},
$plot->{origin_layout});
$plot->{pixmap}->draw_layout ($gc,
$plot->{chartleft} + 2, $plot->{bottom} + 1,
$plot->{minscale_layout});
}

#
# change the data displayed in the window, with all the necessary
# work to get it properly updated.
#
# @threshold: new threshold. ignored if undef.
# @histogram: new histogram. if not empty, copy to the histwin's
# internal histogram cache. MUST be 256 items long.
#
sub set_plot_data {
my ($plot, $threshold, @hist) = @_;

$plot->{threshold} = $threshold if defined $threshold;

if (@hist) {
my $total = 0;
my $max = 0;
for (my $i = 0; $i < 256; $i++) {
$total += $hist[$i];
$max = $hist[$i]
if $hist[$i] > $max;
}
$plot->{max} = $max;
$plot->{histogram} = \@hist;
$plot->{maxval_layout}->set_text
( sprintf "%4.1f%%", (100.0 * $plot->{max}) / $total );
}


# update dims since text may have changed
$plot->calc_dims;

# if the pixmap doesn't exist, we haven't been put on screen yet.
# don't bother drawing anything.
if ($plot->{pixmap}) {
$plot->histogram_draw;
$plot->queue_draw;
}
}

sub do_threshold_changed {
warn "default threshold handler";
}

################
#
# public methods
#
# we inherit new from Glib::Object::Subclass, and all the stuff we'd need
# to get to is available as object properties, so, well, there's no work
# to do here. :-)
#


##########################################################################
# now let's take that code for a test drive...
#
package main;

use Gtk2 qw/-init -locale/;
use constant TRUE => 1;
use constant FALSE => 0;

my $window = Gtk2::Window->new;
$window->signal_connect (delete_event => sub { Gtk2->main_quit; FALSE });

my $vbox = Gtk2::VBox->new;
$window->add ($vbox);
$window->set_border_width (6);

#
# a nicely framed histogram plot with some cheesy data
#
my $plot = Histogram::Plot->new (
threshold => 64,
histogram => [ map { sin $_/256*3.1415 } (0..255) ]
);

my $frame = Gtk2::Frame->new;
$vbox->pack_start ($frame, TRUE, TRUE, 0);
$frame->add ($plot);
$frame->set_shadow_type ('in');

#
# a way to manipulate one of the properties...
#
my $check = Gtk2::CheckButton->new ("Continuous");
$vbox->pack_start ($check, FALSE, FALSE, 0);
$check->set_active ($plot->get ('continuous'));
$check->signal_connect (toggled => sub {
$plot->set (continuous => $check->get_active);
1;
});

#
# do something fun when the threshold changes.
#
my $label = Gtk2::Label->new (sprintf "threshold: %.1f",
$plot->get ('threshold'));
$vbox->pack_start ($label, FALSE, FALSE, 0);

$plot->signal_connect (threshold_changed => sub {
$label->set_text (sprintf 'threshold: %d', $plot->get('threshold'));
});

#
# all systems go!
#
$window->show_all;
Gtk2->main;

# explicit clean up makes us see various messages on a debug build.
undef $plot;
undef $window;

[devel]

此脚本由home兄提供。
This script come from internet:

一个简单的FTP镜像脚本，它递归地将一个本地目录和远程目录做比较，，并将新地或更新过的文件拷贝到本地机器，保持目录的结构，脚本在本地拷贝中保持文件的模式，也尽力保持符号链接。

为了从远程服务器镜像文件和目录，以命令行参数调用这个脚本，命令行参数的组成为远程服务器的DNS名字，一个冒号，以及要镜像的文件或目录的路径。下面的例子镜像文件RECENT,只在从最后一次镜像该文件之后且文件又被改变的情况下才将它拷贝到本地目录：
$ftp_mirror.pl ftp.perl.org:/pub/CPAN/RECENT
下一个例子镜像CPAN模块目录的全部内容，递归地将远程目录结构拷贝到当前本地工作目录中(不要逐字地用这条命令，除非你地网络连接非常快速并且你具又很多地FREE磁盘空间)；

$ftp_mirror.pl ftp.perl.org:/pub/CPAN

这个脚本地命令行选项包括--user和--pass,为非匿名FTP提供用户和密码；还包括--verbose,获取详细地状态报告；以及--hash,在文件传输过程中打印出散列标记。
----------------start

#!/usr/bin/perl -w
# file: ftp_mirror.pl
# Figure 6.2: Recursively mirroring an FTP directory

#装入模块。
use strict;
use Net::FTP;
use File::Path;
use Getopt::Long;
#处理命令行参数。FTP主机和要镜像的目录或文件分别储存在变量$HOST AND $PATH.中。
use constant USAGEMSG => <<USAGE;
Usage: ftp_mirror.pl [options] host:/path/to/directory
Options:
--user <user> Login name
--pass <pass> Password
--hash Progress reports
--verbose Verbose messages
USAGE
my ($USERNAME,$PASS,$VERBOSE,$HASH);
die USAGEMSG unless GetOptions('user=s' => \$USERNAME,
'pass=s' => \$PASS,
'hash' => \$HASH,
'verbose' => \$VERBOSE);
die USAGEMSG unless my ($HOST,$PATH) = $ARGV[0]=~/(.+).+)/;

#初始FTP连接。
my $ftp = Net::FTP->new($HOST) or die "Can't connect: $@\n";
$ftp->login($USERNAME,$PASS) or die "Can't login: ",$ftp->message;#出入用户名和密码。
$ftp->binary;#设置微二进制传输。
$ftp->hash(1) if $HASH;#打开散列。

#初始化镜像。
do_mirror($PATH);
$ftp->quit;#完成。
exit 0;#退出。

# top-level entry point for mirroring.do_mirror()子例程。
sub do_mirror {
my $path = shift;#推入第一个参数给$path.
return unless my $type = find_type($path);
my ($prefix,$leaf) = $path =~ m!^(.*?)([^/]+)/?$!;#把文件全名分问目录的$prefix和文件名的$leaf.
$ftp->cwd($prefix) if $prefix;#改变工作目录。
return get_file($leaf) if $type eq '-'; # ordinary file
return get_dir($leaf) if $type eq 'd'; # directory
warn "Don't know what to do with a file of type $type. Skipping.";
}

# mirror a file镜像一个文件。
#get_file()子程序。
sub get_file {
my ($path,$mode) = @_;
my $rtime = $ftp->mdtm($path);#Returns the modification time of the given file

my $rsize = $ftp->size($path);#Returns the size in bytes for the given file as stored on the remote server.

$mode = (parse_listing($ftp->dir($path)))[2] unless defined $mode;#dir的用法说明：Get a directory listing of "DIR", or the current directory in long format.

my ($lsize,$ltime) = stat($path) ? (stat(_))[7,9] : (0,0);
if ( defined($rtime) and defined($rsize)
and ($ltime >= $rtime)
and ($lsize == $rsize) ) {
warn "Getting file $path: not newer than local copy.\n" if $VERBOSE;
return;
}

warn "Getting file $path\n" if $VERBOSE;
$ftp->get($path) or (warn $ftp->message,"\n" and return);
chmod $mode,$path if $mode;
}

# mirror a directory, recursively
sub get_dir {
my ($path,$mode) = @_;
my $localpath = $path;
-d $localpath or mkpath $localpath or die "mkpath failed: $!";
chdir $localpath or die "can't chdir to $localpath: $!";
chmod $mode,'.' if $mode;

my $cwd = $ftp->pwd or die "can't pwd: ",$ftp->message;
$ftp->cwd($path) or die "can't cwd: ",$ftp->message;

warn "Getting directory $path/\n" if $VERBOSE;

foreach ($ftp->dir) {
next unless my ($type,$name,$mode) = parse_listing($_);
next if $name =~ /^(\.|\.\.)$/; # skip . and ..
get_dir ($name,$mode) if $type eq 'd';
get_file($name,$mode) if $type eq '-';
make_link($name) if $type eq 'l';
}

$ftp->cwd($cwd) or die "can't cwd: ",$ftp->message;
chdir '..';
}

# subroutine to determine whether a path is a directory or a file

sub find_type {
my $path = shift;#输入$path的参数是以个路径。
my $pwd = $ftp->pwd;
my $type = '-'; # assume plain file,这里$type代表普通文件。
if ($ftp->cwd($path)) { #如果改变目录成功。
$ftp->cwd($pwd);
$type = 'd'; #转位目录
}
return $type;
}


# Attempt to mirror a link. Only works on relative targets.
#make_link()尝试创建本地符号链接来镜像远程链接。它假定远程目录列表中#的项指示符号链接的源和目标，象下面这样：
#README.html ---->index.html
sub make_link {
my $entry = shift;把第一个参数赋值给$entry
my ($link,$target) = split /\s+->\s+/,$entry;
return if $target =~ m!^/!; #这里只匹配以/开头的字符串
warn "Symlinking $link -> $target\n" if $VERBOSE;
return symlink $target,$link;
}

# parse directory listings
# -rw-r--r-- 1 root root 312 Aug 1 1994 welcome.msg
sub parse_listing {
my $listing = shift;
return unless my ($type,$mode,$name) =
$listing =~ /^([a-z-])([a-z-]{9}) # -rw-r--r--
\s+\d* # 1
(?:\s+\w+){2} # root root
\s+\d+ # 312
\s+\w+\s+\d+\s+[\d:]+ # Aug 1 1994
\s+(.+) # welcome.msg
$/x;
return ($type,$name,filemode($mode));
}

# turn symbolic modes into octal
sub filemode {
my $symbolic = shift;
my (@modes) = $symbolic =~ /(...)(...)(...)$/g;
my $result;
my $multiplier = 1;
while (my $mode = pop @modes) {
my $m = 0;
$m += 1 if $mode =~ /[xsS]/;
$m += 2 if $mode =~ /w/;
$m += 4 if $mode =~ /r/;
$result += $m * $multiplier if $m > 0;
$multiplier *= 8;
}
$result;
}

[devel]

SSH Secure Shell 3.0.0 Vulnerability Scanner
来自www.linuxeden.com


The following tool will scan the network for hosts using the vulnerable SSH version 3.0 that allows attackers to login to accounts without prompting for a user when their password is shorter than two characters.

For more information about this vulnerability, please see our previous post:
SSH Secure Shell 3.0.0 Allows Passwordless Logons

Tool:
#!/usr/bin/perl
#
# A local SSH 3.0.0 vulnerability scanner for the
# SSH Short Password Login Vulnerability
#
# Note: You must have superuser access on the system to scan it.
#
# usage: ./ssh3.pl
# Optional: -e turn off error
# -h specify a different /etc/shadow file
# (Options must come before host name)
#
# Written by hypoclear hypoclear@jungle.net - http://hypoclear.cjb.net
#
# This and all of my programs fall under my disclaimer, which
# can be found at: http://hypoclear.cjb.net/hypodisclaim.txt
use IO::Socket; use Getopt::Std;
getopts('h:e');
die "\nusage: $0 \n\tOptional: -e turn off error\n\t\t -h specify a different /etc/shadow file\n\n" unless @ARGV > 0;
if (!defined $opt_h)
{ $opt_h = "/etc/shadow";
}
$out = &bannerGrab($ARGV[0],22);
sysread $out, $message,100;
close $out;
if (($message =~ /3.0.0/) || (defined $opt_e))
{ print "Running SSH 3.0.0, checking for vulnerabilities...\n\n";
open(SHADOW, "<$opt_h") || die "Cannot open $opt_h!\nNote: You must have superuser access to run this script.\n\n";
while()
{ $name = $_;
$name =~ s/:.*$//;
$_ =~ s/^.*?\://;
$_ =~ s/:.*$//;
$name =~ s/\s//g; $_=~s/\s//g;
push(@name,$name);
push(@hash,$_);
push(@lnnum,$cnt++); $cnt++;
}
close(SHADOW);
foreach $hash (@hash)
{ @chars = split(//,$hash);
foreach $char (@chars)
{ $count++;
}
if ($count <= 2)
{ print "$name[$line]\t(line $lnnum[$line]) may be vulnerable!\n";
$vulnFlag = 1;
}
$count=0; $line++;
}
if ($vulnFlag != 1)
{ print "No accounts appear to be vulnerable.\n";
}
}
else
{ if (!defined $opt_e)
{ print "You are not running SSH 3.0.0.\n";
die "If you feel that this is an error run with the -e option.\n";
}
}
print "\n";
sub bannerGrab
{ $host = gethostbyname($_[0]) || warn "cannot connect to $ARGV[0]\n";
$port = getservbyport($_[1], 'tcp');
$haddr = sockaddr_in($_[1], $host);
socket(OUT, PF_INET, SOCK_STREAM, getprotobyname('tcp')) || warn "$!\n";
connect(OUT, $haddr) ;
return OUT;
}

[777]

come from internet

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 &amp;quot;No port&amp;quot;
unless $port;
$iaddr = inet_aton($remote) || die &amp;quot;no host: $remote&amp;quot;; $paddr= sockaddr_in($port, $iaddr);
$proto = getprotobyname('tcp');
socket(SOCK, PF_INET, SOCK_STREAM, $proto) || die &amp;quot;socket:$!&amp;quot;;
connect(SOCK, $paddr) || die &amp;quot;connect: $!&amp;quot;;
while ($line = &lt;sock&gt;) { print $line; } close (SOCK) || die &amp;quot;close:$!&amp;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 &amp;quot;
$0 $$: @_ at &amp;quot;, scalar localtime, &amp;quot;\n&amp;quot; } my $port = shift || 2345;
my $proto = getprotobyname('tcp');
socket(SERVER, PF_INET, SOCK_STREAM, $proto) || die &amp;quot;socket:$!&amp;quot;;
setsockopt(SERVER, SOL_SOCKET, SO_REUSEADDR, 1) || die&amp;
quot;setsockopt: $!&amp;quot;; bind(SERVER, sockaddr_in($port, INADDR_ANY)) || die &amp;quot;bind: $!&amp;quot;; listen(SERVER,5) || die &amp;quot;listen: $!&amp;quot;; logmsg &amp;quot;server started on port $port&amp;quot;; my $waitedpid = 0; my $paddr;
sub REAPER { $SIG{CHLD} = \&amp;amp;
REAPER; # loathe sysV $waitedpid = wait;
logmsg &amp;quot;reaped $waitedpid&amp;quot; . ($? ? &amp;quot; with exit $?&amp;quot; : '');
} $SIG{CHLD} = \&amp;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 &amp;quot;connection from $name [&amp;quot;, inet_ntoa($iaddr),&amp;quot;] at port $port&amp;quot;;
spawn sub { print &amp;quot;Hello there, $name, it's now &amp;quot;, scalar localtime, &amp;quot;\n&amp;quot;; exec '/usr/games/fortune' or confess &amp;quot;can't exec fortune: $!&amp;quot;;
};
} sub spawn {
my $coderef = shift;
unless (@_ == 0 &amp;amp;&amp;amp; $coderef &amp;amp;&amp;amp;ref($coderef) eq 'CODE') { confess &amp;quot;usage: spawn CODEREF&amp;quot;;
}
my $pid;
if (!defined($pid = fork)) {
logmsg &amp;quot;
cannot fork: $!&amp;quot;; return;
} elsif ($pid) { logmsg &amp;quot;
begat $pid&amp;quot;; return; # i'm the parent }
# else i'm the child -- go spawn open(STDIN, &amp;quot;&lt;&amp;client") || die "can't dup client to stdin"; open(STDOUT, "&gt;&amp;amp;CLIENT&amp;quot;) || die &amp;quot;can't dup client to stdout&amp;quot;;
## open(STDERR, &amp;quot;&amp;gt;&amp;amp;STDOUT&amp;quot;) || die &amp;quot;can't dup stdout to stderr&amp;quot;; exit &amp;amp;$coderef();
}

[home]

These are some perl scripts that I wrote to aid in system administration tasks that come my way. Feel free to use them but do so at your own risk.
:( :(

md5check is a perl script that can be used to verify the integrity of the files on your system. I use it to ensure that none of my system files have been changed, and to report when they have been changed. Kind of like tripwire, only much easier to setup and use. I use it in a crontab like this,

0 4 * * * ~/bin/md5check 2>&1 | mail -s md5check steeve

which checks the md5 checksums of the folders specified in the script and compares them to those in a flat file text database.

The directories to be scanned are specified in the script like this,

find(\&findfile, '/sbin' );
find(\&findfile, '/bin' );
find(\&findfile, '/lib' );
find(\&findfile, '/usr/bin' );
find(\&findfile, '/usr/etc' );
find(\&findfile, '/usr/games' );
find(\&findfile, '/usr/include' );
find(\&findfile, '/usr/kerberos' );
find(\&findfile, '/usr/lib' );
find(\&findfile, '/usr/libexec' );
find(\&findfile, '/usr/local' );
find(\&findfile, '/usr/lost+found' );
find(\&findfile, '/usr/sbin' );
find(\&findfile, '/usr/tmp' );
find(\&findfile, '/usr/X11R6' );
find(\&findfile, '/etc' );

The following modules are used in md5check,

use File::Find;
use Digest::MD5;

You can download these modules from www.cpan.org if you don't already have them.
download at the URL
http://oneguycoding.com/opensource/md5check



Differential Backup

This script will backup a specified directory. Backup levels can be specified to backup only files changed since the last backup at the previous level. A level 0 backup is a full backup. Level 1 backs up only files changed since the level 0 backup. Destination files are compressed unless they have one of the following extensions,

@noCompressExt = (bz2,gz,tgz,Z,z,zip,rpm,gif,png,jpg,jpeg,mp3,mpg,mpeg,qic);

Destination files compressed by dbak.pl are appended by the extention -gz to differentiate them from files that were not compressed because of @noCompressExt.

By default, only mtime is compared to decide whether a file has changed since the last backup level. The file size can also be compared (this requires decompressing each backup file so this will slow backup substantially). One can also compare md5 digests to be absolutely sure of file changes.

Example,

dbak.pl -s /home -d /mnt/backup -l 4 -q --purge

backup all files not found or changed in backup levels 0 through 3 from /home to /mnt/backup/4/home. Before the backup is done the folder /mnt/backup/4/home is purged of all files that are no longer found in /home.

The following modules are used in dbak.pl

use File::stat;
use File::Find;
use File::Basename;
use Fcntl ':flock'; # import LOCK_* constants
use Compress::Zlib;
use Digest::MD5;
use Getopt::Long;

for which you may need to compile and install

Compress-Zlib-1.08.tar.gz
Digest-MD5-2.12.tar.gz

You can download these modules from www.cpan.org

download at this URL
http://oneguycoding.com/opensource/dbak.pl

[777]

Problems with binary transfers in Net::FTP
come from this link:
http://www.perldiscuss.com/article.p...up=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]

come from
http://developer.netscape.com/docs/m...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>Please 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]

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 &amp;quot;No port&amp;quot; unless $port; $iaddr = inet_aton($remote) || die &amp;quot;no host: $remote&amp;quot;; $paddr = sockaddr_in($port, $iaddr); $proto = getprotobyname('tcp'); socket(SOCK, PF_INET, SOCK_STREAM, $proto) || die &amp;quot;socket: $!&amp;quot;; connect(SOCK, $paddr) || die &amp;quot;connect: $!&amp;quot;; while ($line = &lt;sock&gt { print $line; } close (SOCK) || die &amp;quot;close: $!&amp;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 &amp;quot;$0 $$: @_ at &amp;quot;, scalar localtime, &amp;quot;\n&amp;quot; } my $port = shift || 2345; my $proto = getprotobyname('tcp'); socket(SERVER, PF_INET, SOCK_STREAM, $proto) || die &amp;quot;socket: $!&amp;quot;; setsockopt(SERVER, SOL_SOCKET, SO_REUSEADDR, 1) || die &amp;quot;setsockopt: $!&amp;quot;; bind(SERVER, sockaddr_in($port, INADDR_ANY)) || die &amp;quot;bind: $!&amp;quot;; listen(SERVER,5) || die &amp;quot;listen: $!&amp;quot;; logmsg &amp;quot;server started on port $port&amp;quot;; my $waitedpid = 0; my $paddr; sub REAPER { $SIG{CHLD} = \&amp;amp;REAPER; # loathe sysV $waitedpid = wait; logmsg &amp;quot;reaped $waitedpid&amp;quot; . ($? ? &amp;quot; with exit $?&amp;quot; : ''); } $SIG{CHLD} = \&amp;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 &amp;quot;connection from $name [&amp;quot;, inet_ntoa($iaddr), &amp;quot;] at port $port&amp;quot;; spawn sub { print &amp;quot;Hello there, $name, it's now &amp;quot;, scalar localtime, &amp;quot;\n&amp;quot;; exec '/usr/games/fortune' or confess &amp;quot;can't exec fortune: $!&amp;quot;; }; } sub spawn { my $coderef = shift; unless (@_ == 0 &amp;amp;&amp;amp; $coderef &amp;amp;&amp;amp; ref($coderef) eq 'CODE') { confess &amp;quot;usage: spawn CODEREF&amp;quot;; } my $pid; if (!defined($pid = fork)) { logmsg &amp;quot;cannot fork: $!&amp;quot;; return; } elsif ($pid) { logmsg &amp;quot;begat $pid&amp;quot;; return; # i'm the parent } # else i'm the child -- go spawn open(STDIN, &amp;quot;&lt;&amp;client") || die "can't dup client to stdin"; open(STDOUT, "&gt;&amp;amp;CLIENT&amp;quot || die &amp;quot;can't dup client to stdout&amp;quot;; ## open(STDERR, &amp;quot;&amp;gt;&amp;amp;STDOUT&amp;quot || die &amp;quot;can't dup stdout to stderr&amp;quot;; exit &amp;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 &amp;quot;%-24s %8s %s\n&amp;quot;, &amp;quot;localhost&amp;quot;, 0, ctime(time()); foreach $host (@ARGV) { printf &amp;quot;%-24s &amp;quot;, $host; my $hisiaddr = inet_aton($host) || die &amp;quot;unknown host&amp;quot;; my $hispaddr = sockaddr_in($port, $hisiaddr); socket(SOCKET, PF_INET, SOCK_STREAM, $proto) || die &amp;quot;socket: $!&amp;quot;; connect(SOCKET, $hispaddr) || die &amp;quot;bind: $!&amp;quot;; my $rtime = ' '; read(SOCKET, $rtime, 4); close(SOCKET); my $histime = unpack(&amp;quot;N&amp;quot;, $rtime) - $SECS_of_70_YEARS ; printf &amp;quot;%8d %s\n&amp;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 &amp;quot;something's wicked with the print system&amp;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 &amp;quot;socket: $!&amp;quot;; connect(SOCK, sockaddr_un($remote)) || die &amp;quot;connect: $!&amp;quot;; while ($line = &lt;sock&gt { 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 &amp;quot;socket: $!&amp;quot;; unlink($NAME); bind (SERVER, $uaddr) || die &amp;quot;bind: $!&amp;quot;; listen(SERVER,5) || die &amp;quot;listen: $!&amp;quot;; logmsg &amp;quot;server started on $NAME&amp;quot;; $SIG{CHLD} = \&amp;amp;REAPER; for ( $waitedpid = 0; accept(CLIENT,SERVER) || $waitedpid; $waitedpid = 0, close CLIENT) { next if $waitedpid; logmsg &amp;quot;connection on $NAME&amp;quot;; spawn sub { print &amp;quot;Hello there, it's now &amp;quot;, scalar localtime, &amp;quot;\n&amp;quot;; exec '/usr/games/fortune' or die &amp;quot;can't exec fortune: $!&amp;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]

come from
http://www.zevils.com/cgi-bin/cvsweb...server?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]

#!/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|^(?:http://)?(.*?)(/.*)|;
    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]

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 的行结束符是 "rn" (回车符+换行符)
#    UNIX/Linux 的行结束符是 "n" (换行符)
#    Mac 的行结束符是 "r" (回车符)
#
#本例把UNIX/Linux 的行结束符 转换为DOS/Windows 的行结束符
#
#建议把她放到patch下，如 /usr/local/bin
#
#本例把标准输入的文本转换后送到标准输入。
#
#如 #cat textfile | text3dos.pl > texefile.txt
#
# [email]jhuangjiahua@163.com[/email]
#



-----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 $_;
}


" 


[bst]

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

[sunxiaobo]

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

[黄叶]

楼主的脚本是Perl NetWork Program<Perl网络编程》里的例子。
呵呵。

[phus]

以前的写的一个脚本， 用来批量下载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::Path;

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->[$_]\"`;
}