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

KornLee

from:http://www.linuxsir.cn/bbs/showt ... 15&pagenumber=3

#!/usr/bin/perl -w

# Chinese count method
# wrote by Lyoo
# iamlyoo@163.com
# 2003/06/22


# match @unit = qw / 个 拾 佰 仟 万 拾万 佰万 仟万/
@unit = qw / A B C D E F G H / ;

##########################################################
#
# receive user's input
#
########################################################

$count = 0;
while ( $count < 1 ) {
print "lease input a number:";
chomp ($number = <STDIN> );
if ( $number =~ /^[-,+]?\d+\.?\d*$/ ) {
$count += 1;
} else {
print "It's not a Number!\n";
redo;
}
}

##########################################################
#
# create a number_array
#
#########################################################

# add a number to the number_string,
# so that the while-loop can get the "0" in the tail of the number_string.
$number_9 = $number."9";

# convert the number to a array.
$dot = "no";
while ($number_9) {
my $single = $number_9;
$single =~ s/([\d,.,+,-]).*/$1/;
$number_9 =~ s/[\d,.,+,-](.*)/$1/;
push (@number_array,$single);
$dot = "yes" if $single eq ".";
}

# delect the addition number.reverse the array.
pop @number_array;
@number_array = reverse @number_array;

# get number's sylobm.
$sylobm = "";
$sylobm = pop @number_array if $number_array[-1] =~ /[+,-]/;

# get the number_dot_string.
$number_dot_string = "";
if ($dot eq "yes") {
while (@number_array) {
$number_dot_string .= shift @number_array;
last if $number_dot_string =~ /\d\./;
};
$number_dot_string = reverse $number_dot_string;
};


#############################################################################
#
# creat a number_unit_array
#
#############################################################################

$min_unit = 9;
$j = 0;
$i = 0;
$n = 0;

foreach (@number_array) {
push (@number_unit_array,$unit[$i].$_);

if ($i == 0) {
$j++;
$min_unit = "on";
$switch = "on"
};

unless ($switch eq "off" || $_ eq "0") {
$min_unit = $n;
};

unless ($switch eq "off" || $min_unit eq "on") {
$number_unit_array[$min_unit] = ("Z" x ($j-1)).$number_unit_array[$min_unit];
$switch = "off";
}

$i++;
$n++;
$i = $i % 8;
}

#############################################################################
#
# modify the number_unit_string
#
#############################################################################

foreach (@number_unit_array) {
$number_unit_string .= $_;
}
$number_unit_string = reverse $number_unit_string;
$_ = $number_unit_string;
s/0[A-H]/0/g;
s/0+/0/g;
s/A//g;
s/0+$//;

#print "$_\n";

s/H(\d)G(\d)F(\d)E/D$1C$2B$3E/g;

s/H(\d)G(\d)F/D$1C$2F/g;
s/H(\d)G(\d)E/D$1C$2E/g;
s/H(\d)F(\d)E/D$1B$2E/g;
s/G(\d)F(\d)E/C$1B$2E/g;


s/H(\d)E/D$1E/g;
s/G(\d)E/C$1E/g;
s/F(\d)E/B$1E/g;

s/H(\d)F/D$1F/g;
s/G(\d)F/C$1F/g;

s/H(\d)G/D$1G/g;

$number_unit_string = "$sylobm"."$_"."$number_dot_string";

#############################################################################
#
# output the number_unit_string as a array
#
#############################################################################

# convert number_unit_string to array.
# it's ugly but without this action
# chinese can't output correct.
# I don't know why

while ($number_unit_string) {
my $single = $number_unit_string;
$single =~ s/([\w,.,+,-]).*/$1/;
$number_unit_string =~ s/[\w,.,+,-](.*)/$1/;
push (@number_unit_ok,$single);
}
#print "number_unit_ok is @number_unit_ok.\n";

foreach (@number_unit_ok) {
&print_chinese;
}
print "\n";

sub print_chinese {
if ($_ eq 0) {
print "零";
} elsif ($_ eq 1) {
print "壹";
} elsif ($_ eq 2) {
print "贰";
} elsif ($_ eq 3) {
print "叁";
} elsif ($_ eq 4) {
print "肆";
} elsif ($_ eq 5) {
print "伍";
} elsif ($_ eq 6) {
print "陆";
} elsif ($_ eq 7) {
print "柒";
} elsif ($_ eq 8) {
print "捌";
} elsif ($_ eq 9) {
print "玖";
} elsif ($_ eq A) {
print "个";
} elsif ($_ eq B) {
print "拾";
} elsif ($_ eq C) {
print "佰";
} elsif ($_ eq D) {
print "仟";
} elsif ($_ eq E) {
print "万";
} elsif ($_ eq F) {
print "拾万";
} elsif ($_ eq G) {
print "佰万";
} elsif ($_ eq H) {
print "仟万";
} elsif ($_ eq Z) {
print "亿";
} elsif ($_ eq "+") {
print "<正>";
} elsif ($_ eq "-") {
print "<负>";
} elsif ($_ eq ".") {
print "<点>";
}
}

#####################################################
# the end of this script
####################################################

devel

使用pipe()创建链接的文件句柄。
#!/opt/bin/perl -w

#++
# file: piping-facfib.pl
#
# Slightly modified from
#  figure 2.2: (Using pipe() to create linked filehandles)
#  in Network Programming With Perl by Lincoln D. Stein
#  (c)2001 Addison-Wesley
#--

use POSIX 'WNOHANG'; # for reaper()
use diagnostics;
use strict;
my $arg = shift || 10;

print "piping_facfib.pl\n";
print "  This program starts two subprocesses that write to a pipe.\n";
print "  The main process reads from the pipe and prints what it receives.\n";
print "  Notice the non-deterministic order of the results.";
print "\n";
print "  The subprocesses compute the first n Fibronacci and factorials.\n";
print "  n is the command line argument, or 10 if no argument is specified.\n";

# prepare to handle CHLD signals when subprocesses exit
$SIG{CHLD} = \&reaper;

pipe(READER,WRITER) or die "Can't open pipe: $!\n";

if (0 == fork) { # first child writes to WRITER
  close READER;
  select WRITER;  # this is what print() will work with
  $| = 1;         # unbuffered print()-ing
  factorial($arg);
  exit 0;
}


if (0 == fork) { # second child writes to WRITER
  close READER;
  select WRITER;
  $| = 1;
  my $result = fibonacci($arg);
  exit 0;
}

# parent process closes WRITER and reads from READER
close WRITER;
print while <READER>;


# -- subroutines start here -- #

sub short_time {
    return rand 3;
} # short_time()

sub factorial {
    my $target = shift;
    my $result = 1;
    my $i;   
    for ($i = 1; $i <= $target; $i++) {
        sleep short_time();
        $result *= $i;
        print "factorial($i) => ",$result, "\n";
    }
} # factorial()

sub fibonacci {
    my $target = shift;
    my $result = 1;
    my ($a, $b) = (1,0);
    my $i;   

    for ($i = 1; $i <= $target; $i++) {
        $result = $a + $b;
        print "fibonacci($i) => ", $result, "\n";
        ($a, $b) = ($b, $result);
        sleep short_time();
    }
} # fibonacci()

sub reaper {
    while ((my $kid = waitpid(-1, WNOHANG))>0) {
        warn "Reaped child process with PID $kid\n";
    }
} # reaper()

devel

这个程序打开一个文件、统计文件的行数，并报告其发现。
#!/usr/bin/perl -w
#filename: count_lines.pl
use strict; #使用strict检验语法。
use IO::File;
my $file =shift; #退入一个参数，这里指输入一个文件名
my $counter=0;
my $fh=IO::File->new($file) or die "Could not open $file!\n"; #用IO::File打开文件并返回一个文件句柄$fh.不成功返回undef,后以一条错误信息终止。
while (defined (my $line=$fh->getline) ) { #在while()循环的测试部分调用了IO::File对象的getline()方法。
$counter++;
}
STDOUT->print("counted $counter line\n"); #从STDOUT读取内容，并发送到printf(),

devel

come from internett

#!/usr/bin/perl -w

# popcorn.pl
# A CGI program, written using CGI.pm, to process
#  the popcorn sales form
# Initialize total price and total number of purchased items

$total_price = 0;
$total_items = 0;

use CGI ":standard";

# First produce the header part of the HTML return value


print header(-charset=>'UTF-8');
print start_html(-dtd=>[ '-//W3C//DTD XHTML 1.0 Strict//EN',
                       'http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd' ],
                 -title=>"CGI-Perl Popcorn Sales Form, using CGI.pm",
                 -head=>Link({-rel=>'stylesheet', -type=>'text/css', -href=>'../style.css'}));

# Set local variables to the parameter values

my($name, $street, $city, $payment) =
        (param("name"), param("street"),
        param("city"), param("payment"));
my($unpop, $caramel, $caramelnut, $toffeynut) =
        (param("unpop"), param("caramel"),
         param("caramelnut"), param("toffeynut"));

# Compute the number of items ordered and the total cost

if ($unpop > 0) {
    $cost = 3.0 * $unpop;
    $total_price += $cost;
    $total_items += $unpop;
}

if ($caramel > 0) {
    $cost = 3.5 * $caramel;
    $total_price += $cost;
    $total_items += $caramel;
}

if ($caramelnut > 0) {
    $cost = 4.5 * $caramelnut;
    $total_price += $cost;
    $total_items += $caramelnut;
}

if ($toffeynut > 0) {
    $cost = 5.0 * $toffeynut;
    $total_price += $cost;
    $total_items += $toffeynut;
}

# Produce the result information to the browser and finish the page

print "<h3>Customer:</h3>\n",
      "<p>$name <br />\n", "$street <br />\n", "$city <br />\n",
      "ayment method: $payment <br /><br /></p>\n",
      "<h3>Items ordered:</h3> \n",
      "<p>Unpopped popcorn: $unpop <br /> \n",
      "Caramel popcorn: $caramel <br /> \n",
      "Caramel nut popcorn: $caramelnut <br /> \n",
      "Toffey nut popcorn: $toffeynut <br /><br /> \n",
      "You ordered $total_items popcorn items <br />\n",
      "Your total bill is: \$ $total_price <br /></p> \n";
print end_html();

home

come from internett

#!/usr/local/bin/perl -w
#
# helper script for ck_cov.aml
#
# usage: ck_cov.pl [service] [covname] [textfile] [other argss...]
#
# returns exit status 0 if this prog ran ok; stdout will be '' if
# it found nothing, could be anything (presumably 'ERROR' if it found
# anything wrong with the thing it was checking.
# Only returns exist status != 0 if something went wrong
#
# 08-may-1997 tglover  Created
# 08-jun-1997 bmackenz Added keywords to 'missing meta' output.
# 17-jul-1997 tglover  Added check for universe polygon labelled
# 21-jul-1997 tglover  Added check for unpopulated FCODEs/TAGs
# 05-jun-1998 bmackenz Added counts to check for unpopulated above.
# 12-feb-2001 teglover Sytax correction, line 81 (added parens)

if (@ARGV < 1) {
  print STDERR "usage: ck_cov.pl <service> <textfile> <other args>\n";
  exit 1;
}

$service = shift;
$service =~ tr/A-Z/a-z/;

$infile = shift;
if (not open( INFILE, "$infile" )) {
  print STDERR "Can not open $infile\n";
  exit 1;
}

$rtn_val = ''; # this is set by global side effect

# Note that to read parms within the sbrs here, must get them from
# @ARGV instead of @_.

eval "&$service";
##$eval_rtn = eval "&$service( @ARGV )";
##print "eval rtn is [$eval_rtn], \$\@ is [$@]\n";
##print "only running ck_item_pop\n";
##&ck_item_pop( @ARGV );

close( INFILE );

# check for errors here

# exit with the return value
print STDOUT "$rtn_val\n";
exit;

#---------------
# this is passed LIST <cover>.meta KEY
sub ck_meta {
  while (<INFILE>) {
    if (/^ *[0-9]+ +([A-Z][A-Z0-9_]+)/) {
     $keyvals{ $1 } = 1;
    }
  }
  # check for required keys
  $missing_keys = "";
  foreach $key ('TITLE', 'DESCRIPTION', 'SOURCE', 'ACCURACY') {
    if (not exists( $keyvals{ $key })) {
      $missing_keys = $missing_keys." ".$key
    }
  }
  if ($missing_keys) {
  $rtn_val = "missing meta KEY values: $missing_keys";
  }
}
#-------------------
# this is passed (in the file) the name of the cover
# It will test for the user's ability to alter the cover.
sub  ck_fix_access {
  my( $cov, $wkspace );

  # get the workspace & cover names
  $_ = <INFILE>;        # get full filespec from file
  $_ =~ tr/A-Z/a-z/;        # lower case
  # get the names
  if (not (($wkspace, $cov) = (m!^\s*(\S+)/(\S+)\s*$!))) {
    $rtn_val = 'internal: cannot parse workspace/cover in ck_fix_access';
    return;
  }

  # does the user have access to the cover dir?
  if (not -w "$wkspace/$cov") {
    $rtn_val = 'cover is not writable';
  # can the user write in the cover's workspace?
  } elsif (not -w "$wkspace") {
    $rtn_val = 'workspace containing cover is not writable';
  # can the user write in the workspace's info dir?
  } elsif (not -w "$wkspace/info") {
    $rtn_val = 'info directory not writable';
  }
  
}
#-------------------
# this is passed REGIONERRORS
sub ck_regions {
  while (<INFILE>) {
    if (/^Unclosed region detected/i or /has unclosed ring/) {
      $rtn_val = 'failed REGIONERRORS';
      last;
    }
  }
}
#---------------------
# this is passed LABELERRORS then NODEERRORS DANGLE
sub ck_polys {
  while (<INFILE>) {   
    if (/total number of dangling nodes: *([0-9]+)/i and $1 > 0) {
      $rtn_val = 'fails NODEERRORS';
      last;
    }
    elsif (/polygon +([0-9]+) +has +([0-9]+) +label/i and
          ($1 != 1 or $2 != 0)) {
      $rtn_val = 'fails LABELERRORS';
      last;
    }
  }
}
#------------------------
# this is passed LABELERRORS then NODEERRORS DANGLE
# It makes sure that the universe poly is NOT labelled
sub ck_universe_label {
  $rtn_val = 'fails universe check';
  while (<INFILE>) {   
    if (/polygon +1 +has +0 +label/i) {
      # the universe has no label point (this is good)
      $rtn_val = '';
      last;
    }
  }
}
#------------------------
#
# This is passed a list of all the <item> values
# args:
#        info file (eg AAT, PATNATION, etc)
#        item name
#        whether the cover contains polygons
# Checks that all the items are populated.
sub ck_item_pop {
  my( $filetype, $itemname, $polyflag) = @ARGV;

  # the list should contain
  # first line: headings (ignore)
  # other lines: record# item_value

  $numrec = 0;
  $unpop = 0;
  while (<INFILE>) {
    $numrec++ ;
    # any line with only one word will be an unpopulated item
    if (/^\s*(\S+)\s*$/) {
      # only one word... but ok if record one in poly topology
      if ($1 eq '1' and $filetype =~ /^pat/i and $polyflag > 0) {
        # this is the universe poly -- it's ok to be blank
      } else {
        $unpop++ ;
      }
    }
  }
  if ($unpop > 0) {
    $rtn_val = "item $itemname blank ($unpop x of $numrec) in .$filetype";
  }

}  

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:lot;

use Gtk2;
use warnings;
use strict;
use Data:umper;

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:rawingArea,
# 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:rawingArea, and in the process adding a signal and a few
# object properties.
#
use Glib::Object::Subclass
        'Gtk2:rawingArea',
        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:aramSpec->double ('threshold',
                                         'Threshold',
                                         'Diving line between above and below',
                                          0.0, 255.0, 127.0,
                                         [qw/readable writable/]),
                Glib:aramSpec->boxed ('histogram',
                                        'Histogram Data',
                                        'Array reference containing histogram data',
                                        'Glib::Scalar',
                                        [qw/readable writable/]),
                Glib:aramSpec->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:ango->scale; #PANGO_SCALE;
        $plot->{textheight} = ($metrics->get_descent + $metrics->get_ascent)
                            / Gtk2:ango->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:ixmap->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:lot->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:abel->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:ath;
use Getopt:ong;
#处理命令行参数。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:ong;

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