sourcecode

Reaped: SATISH (NodeReaper)

This node was taken out by the NodeReaper on 2006-10-25 09-27-23
Reason: [jdporter]: reap. no content. (looks like a test post)

You may view the original node and the consideration vote tally.

Reaped: SF_form_secure (NodeReaper)

This node was taken out by the NodeReaper on 2006-10-23 09-03-01
Reason: [Corion]: Reap: Duplicate of SF_form_secure

You may view the original node and the consideration vote tally.

SF_form_secure (SFLEX)

What are you waiting for?
Start using it!
Befor that A.D.D. sets in.

Tk Photo Slideshow, with scrolling and scaling (jdporter)

use Tk;use Tk::JPEG;use Tk::Pane;use strict;use warnings;my $dir = shift || '.';chdir $dir or die "Can't go do $dir - $!\n";my $filespec = "*.jpg";my @files = glob $filespecor die "No files matching $filespec in $dir !\n";my $ii = -1; # image indexmy $mw = new MainWindow;my $scrolled = $mw->Scrolled( 'Pane', -scrollbars => 'osoe', -width => 640, -height => 480, )->pack( -expand => 1, -fill => 'both', );my $imagit = $scrolled->Label->pack( -expand => 1, -fill => 'both', );my( $xscroll, $yscroll ) = $scrolled->Subwidget( 'xscrollbar', 'yscrollbar' );my( $last_x, $last_y );my $img2;$mw->bind( '' => \&prev_image );$mw->bind( ''    => \&prev_image );$mw->bind( ''  => \&prev_image );$mw->bind( ''  => \&next_image );$mw->bind( ''  => \&next_image );$mw->bind( '' => \&next_image );$imagit->bind( '' => sub { undef $last_x } );$imagit->bind( '' => [ \&drag, Ev('X'), Ev('Y'), ] );sub drag{my( $w, $x, $y ) = @_;if ( defined $last_x ){my( $dx, $dy ) = ( $x-$last_x, $y-$last_y );my( $xf1, $xf2 ) = $xscroll->get;my( $yf1, $yf2 ) = $yscroll->get;my( $iw, $ih ) = ( $img2->width, $img2->height );if ( $dx < 0 ){$scrolled->xview( moveto => $xf1-($dx/$iw) );}else{$scrolled->xview( moveto => $xf1-($xf2*$dx/$iw) );}if ( $dy < 0 ){$scrolled->yview( moveto => $yf1-($dy/$ih) );}else{$scrolled->yview( moveto => $yf1-($yf2*$dy/$ih) );}}( $last_x, $last_y ) = ( $x, $y );}=podImage scaling here is designed to strike a balancebetween not wanting to scroll too much and notwanting to lose too much resolution by downsampling.The heuristic is:1. if the image fits within the scrolled pane in oneor both dimensions (that is, only zero or one scrollbarwould be shown), no downsampling is done.2. otherwise (i.e. if two scrollbars would be needed),the downsampling factor is incremented (from 1) untilcondition #1 (above) is met.(Of course, we don't actually increment and check likethat; we calculate the desired factor algebraically.)This way, when you do have to scroll, it will often beon one axis only; and the distance you'll have to scroll will be minimized (or rather, optimized).Another approach would be to downsample the picturesufficiently such that the image always fits entirelywithin the pane, and scrolling won't be necessary, butI'd rather give minimization of resolution loss slightly more weight than eliminating the need to scroll.=cutsub factor{my( $n, $m ) = @_;($n>$m) ? int($n/$m) : 1}sub min{my( $n, $m ) = @_;$n < $m ? $n : $m}sub show_image{my $imgfile = $files[$ii];$mw->configure( -title => "($ii) - - - - - - -" );my $img1 = $mw->Photo( 'fullscale',-format => 'jpeg',-file => $imgfile,);# it's possible to manipulate an image during reading# from disk, but unfortunately you don't get quite as# much control as you do when copying one image to another,# and some of the things we need to do we can only do# during copy, not reading.my $factor = min(factor( $img1->width, $scrolled->width ),factor( $img1->height, $scrolled->height ),);$img2 = $mw->Photo( 'resized' );$img2->copy( $img1, -shrink, -subsample => $factor, $factor );$imagit->configure(-image => 'resized',-width => $img2->width,-height => $img2->height,);$mw->configure( -title => "($ii) $imgfile" );}sub prev_image{$ii = ( $ii + @files - 1 ) % @files;show_image();}sub next_image{$ii = ( $ii + 1 ) % @files;show_image();}$mw->after( 100, \&next_image );MainLoop;

Module Finder (innominate)

#!/usr/bin/perl use strict;use warnings;use File::Find;if(my $m = shift){find(sub{/$m/i ? print"$File::Find::name\n" : 0},@INC);}else {print "Please enter a single search string as an argument!\n";}

pexec.pl: snippet runner (Hue-Bond)

#!/usr/bin/perluse warnings;use strict;use Gtk2;## todo: change mnemonic into an accelerator (^D)## todo: do another one for quitting (^Q)## bug (fixed by forking): halts on infinite loops :^Pmy ($window, $vbox, $ptext, $but, $label);my $font = 'Monospace 10';my $perl = '/usr/bin/perl';sub do_run {    my $pid;    my $buf = $ptext->get_buffer;    local $SIG{'CHLD'} = 'IGNORE';    warn "fork: $!" and return unless defined ($pid = fork);    if ($pid) { ## parent        $ptext->grab_focus;        return;     }    ## child    $pid = open my $fd, '|-', $perl, '-t' or die "fork: $!";    print "\n$perl PID: $pid\n";  ## for easy killing    print $fd $buf->get_text ($buf->get_bounds, 1);    close $fd;    exit;   }Gtk2->init;$window = Gtk2::Window->new ('toplevel');$vbox   = Gtk2::VBox->new (0, 0); $ptext  = Gtk2::TextView->new;$but    = Gtk2::Button->new;$label  = Gtk2::Label->new_with_mnemonic ('_Run!');$but->signal_connect (clicked => \&do_run);$but->add ($label);$but->set_size_request (50, 30);$ptext->set_size_request (50, 20);$ptext->set_border_width (4);$ptext->modify_font (Gtk2::Pango::FontDescription->from_string ($font));$ptext->get_buffer->set_text (<<_DEF_TEXT_);use warnings;use strict;use Data::Dumper;\$ENV{'PATH'} = \$ENV{'CDPATH'} = '/usr/bin:/bin';_DEF_TEXT_$vbox->add ($ptext);$vbox->pack_end ($but, 0, 0, 0);$window->signal_connect (destroy => sub { Gtk2->main_quit; });$window->set_default_size (700, 400);$window->add ($vbox);$window->show_all;Gtk2->main;

linked-port: find given linked libraries ("shared objects") in FreeBSD Ports (parv)

#!/usr/local/bin/perl$VERSION = '0.01';use warnings; use strict;use Data::Dumper;$Data::Dumper::Useqq = 1;$Data::Dumper::Indent = 1;$Data::Dumper::Sortkeys = 1;$Data::Dumper::Terse = 0;$Data::Dumper::Purity = $Data::Dumper::Deepcopy = 1;$Data::Dumper::Deparse = 1;use Getopt::Long;my %opt =  (    'ports-data' => q{/var/db/pkg}  , 'file-list'  => '+CONTENTS'  , 'ports' => []  , 'libs'  => []  );GetOptions(  'd|dir|ports-data=s' => \$opt{'ports-data'}, 'p|ports=s@' => $opt{'ports'}, 'l|libs=s@' => $opt{'libs'})  or die;#  Search for files for ALL the installed ports.push @{ $opt{'ports'} } , '.' unless scalar @{ $opt{'ports'} };push @{ $opt{'libs'} } , @ARGV if scalar @ARGV;my $possibly_linked =  get_files  (    {      'list-maker' => [ qw{ pkg_info -L } ]    , 'ports' => find_ports( $opt{'ports'} )    , 'keep'  =>        qr{ (?: /(?: s?bin | libexec ) / .+ | /perl\d+/.+?[^/]+\.so )$ }x    }  );my $linked =  find_libs  (    {      'libs-lister' => q{ldd}    , 'ports' => $possibly_linked    , 'keep' => ( map qr{$_}i , join '|' , @{ $opt{'libs'} } )[0]    }  );print Dumper( $linked );exit;sub find_libs{  my ( $find ) = @_;  my %linked;  my $parse = qr{^ \s* lib[-.,_a-zA-Z0-9]+ \s+ => \s+ .+ };  foreach my $port ( keys %{ $find->{'ports'} } )  {    foreach my $file (  @{ $find->{'ports'}->{ $port } } )    {      #  Stringification is needed to send ldd(1) errors to /dev/null; otherwise      #  "2>/dev/null: No such file or directory" error message is produced by      #  ldd(1).      my $cmd =        join ' ' , $find->{'libs-lister'} , $file , '2>/dev/null';      open my $ph , '-|' , $cmd or die "Cannot open pipe: $!";      my $skip = quotemeta $file;      $skip = qr{^$skip:};      while ( my $line = <$ph> )      {        next unless $line =~ m/$find->{'keep'}/;        next if $line =~ m/$skip/;        $line =~ s/^\s+//;        chomp $line;        push @{ $linked{ $port }->{ $file } } , $line      }    }  }  return { %linked };}sub get_files{  my ( $find ) = @_;  my %files;  foreach my $p ( @{ $find->{'ports'} } )  {    open my $ph , '-|' , @{ $find->{'list-maker'} } , $p      or die "Cannot open pipe: $!";    while ( my $file = <$ph> )    {      next unless $file =~ m/$find->{'keep'}/ ;      chomp $file;      push @{ $files{ $p } } , $file ;    }  }  return { %files };}sub find_ports{  my ( $re ) = @_;  ($re) = map qr{$_}i, join '|' , @{ $re };  my ($dh , $close ) = open_dir( $opt{'ports-data'} );  my @ports;  while ( my $port = readdir $dh )  {    next unless $port =~ m/$re/;    my $path = join '/' , $opt{'ports-data'} , $port;    next      unless -d $path          && -f join '/' , $path , $opt{'file-list'}        ;    push @ports , $port;  }  $close->();  chomp @ports;  return [ sort @ports ];}sub open_dir{  my ( $dir ) = @_;  opendir my $dh , $dir or die "Cannot open $dir: $!";  return ( $dh , sub { closedir $dh or die "Cannot close $dir: $!"; } );}

Attachment Search for TWiki (Melly)

#!/usr/bin/perl -wTuse strict;use CGI qw(:standard);use File::Find;# base pathsmy $searchpath = '/var/www/twiki/pub/';my $doc_url = '/twiki/pub/';my $twiki_url = '/twiki/bin/view/';my $return_url = '/'; # link back to main twiki# twikis that can be searched, incl. Allmy @twikis = qw(  All CV Customers Dev Implementation Info Product Proton  RENLStar Sales Sandbox Support);# for popup_menu values=array element# (stops user adding another directory)my %twikis;foreach(0..$#twikis){  $twikis{$_} = $twikis[$_];}# will hold final list of twikis to search (1 twiki unless All)my @twikipaths;# params from formmy $mode = param('mode'); # cgi app modemy $isregex = param('isregex'); # regex searchmy $cs = param('cs'); # case-sensitivemy $fname_only = param('fname_only'); # filenames only# searchterm - allow anything, but eval regex ($msg for regex errs)my ($msg, $searchterm) = ('','');$searchterm = $1 if (defined param('searchterm') &&  param('searchterm') =~ /(.+)/);if($isregex){  eval {'foobar' =~ /$searchterm/};  if($@){    $isregex = 0;    $@ =~ /([^;]*)/;    $msg = "Bad Regex - non-Regex search performed: $1      (if you entered '*', you probably meant '.*')
";  }}# search_ext - allow anything, but eval (always regex)my $search_ext = 'doc';$search_ext = $1 if (defined param('search_ext') &&  param('search_ext') =~ /(.+)/);eval{ 'foobar' =~ /$search_ext/};if($@){  $search_ext = 'doc';  $@ =~ /([^;]*)/;  $msg .= "Bad Extension Regex - searching for .doc: $1";}# for displaymy $nice_ext = '.' . (lc $search_ext);my $title;# translate array element from param to twiki namemy $twiki = $twikis[0];$twiki = $twikis[$1] if (defined param('twiki') &&  param('twiki') =~ /^(\d+)$/) and defined $twikis[$1];# for list of files found in searchmy @matched_files;# no search, just formif(!$mode or $searchterm =~ /^\s*$/ or !$twiki){  $mode = 0;  $title = 'Twiki Attachment Search';  &SearchTop($title);  &SearchEnd();}# form + search + search resultselsif($mode){  # build list of twikis to search  if($twiki eq 'All'){    foreach(@twikis){      push @twikipaths, $searchpath . $_ . '/' if $_ ne 'All';    }  }  else{    push @twikipaths, $searchpath . $twiki . '/';  }  # handle regex/non-regex search, run search and print results  $searchterm = quotemeta $searchterm if !$isregex;  &DoSearch();  $title = 'Twiki Attachment Search Results';  &SearchTop($title)  &SearchResults();  &SearchEnd();}# page topsub SearchTop(){  my $title = $_[0];  my $title2;  $title2 = "(Search for: $searchterm)" if $mode;  $title2 .= "(Extension: $nice_ext)";  $title2 .= "
(Twiki: $twiki)";  $title2 .= $isregex ? '(regex)' : '(non-regex)';  $title2 .= $cs ? '(case-sensitive)' : '(case-insensitive)';  $title2 .= $fname_only ? '(filenames only)' : '(filenames and content)';  print header();  print start_html($title);  &SearchForm($title, $title2);}# page endsub SearchEnd(){  print end_html();}# search form, use numeric vals for twikissub SearchForm(){  print h2($_[0]);  print h4($_[1]);  print p(    a({-href=>$return_url},'Back to TWiki')  );  print p("WARNING - Searching may take some time,    especially if you search all Twikis (although \"Filenames Only\" should    be okay).
",    "To return a list of all docs, use \".*\"    as a Regex  with the \"Filenames Only\" and \"All\" options.
    The extension regex is not case-sensitive.");  print start_form('GET');  print p("Search For: ", textfield('searchterm', '',35), '.',    textfield('search_ext', 'doc',7),'(extension regex)'  );  print p(    a({-href=>'http://tinyurl.com/pcpbq',-target=>'_new'},"Regex: "),    checkbox('isregex',0,1, ''),    "Case Sensitive: ", checkbox('cs',0,1,''),    "Filenames Only: ", checkbox('fname_only',0,1,'')  );  print p("In TWikis: ",popup_menu('twiki',[0..$#twikis],0,\%twikis),    hidden('mode', 1));  print p(submit('Search'), ' ', CGI::reset());  print endform;}# handle search results (mainly building urls)sub SearchResults(){  print h4('Warning'), '', $msg, '
' if $msg;  my @filesout;  foreach(@matched_files){    my $file = $_;    if($file =~ m#^$searchpath([^/]*)(.*)/(.*)#){      my $shorttwiki = $1 . $2;      my $twikilink =  $twiki_url . $shorttwiki;      my $filelink = $doc_url . $shorttwiki . '/' . $3;      my $filename = $3;      push @filesout, [$shorttwiki, $twikilink, $filelink, $filename];    }  }  print table({-border=>1},    Tr([      th(['Document', 'On TWiki']),      map{        td([            a({-href=>$$_[2]},$$_[3]), a({-href=>$$_[1]},$$_[0])        ])      } @filesout    ])  );}# perform search, checking if fname_only, cs, etc.,# stripping non-printable asciisub DoSearch{  my $path = $searchpath;  $path .= $twiki;  find({wanted=>\&wanted,    untaint=>1,untaint_pattern=>'^([\040-\176]*)$',untaint_skip=>1},    @twikipaths);  sub wanted{    # ,v files are twiki attachment versions -    # we only check current version    if($_ !~ /,v$/i and /.+\.$search_ext$/i){      if($cs && /$searchterm/){        push @matched_files, $File::Find::name;      }      elsif(!$cs && /$searchterm/i){        push @matched_files, $File::Find::name;      }      elsif(!$fname_only){        open(DOC, $File::Find::name)||          die "Couldn't open $File::Find::name:$!\n";        THISFILE: while(my $line = ){          $line =~ s/[^\011\012\015\040-\176]//g;          if($cs && $line =~ /$searchterm/){            close DOC;            push @matched_files, $File::Find::name;            last THISFILE;          }          elsif(!$cs && $line =~ /$searchterm/i){            close DOC;            push @matched_files, $File::Find::name;            last THISFILE;          }        }      }    }  }}

file-search: File search with minimum scrolling of output (parv)

#!/usr/local/bin/perl$VERSION = '0.01';use warnings; use strict;use File::Spec;use Pod::Usage;use Getopt::Long qw(:config gnu_compat no_ignore_case no_debug);my %default_opt =  (    'show-default-opt' => undef  , 'verbose' => undef  , 'ignore-case' => undef  , 'invert-match' => undef  , 'bin-search' => undef  , 'recursive' => undef  , 'line-numbers' => 1  , 'number-width' => 4  , 'collapse-space' => 1  , 'blank-line' => undef  , 'highlight' => 1  , 'cleanse-path' => 1  , 'realpath' => undef  , 'strip-curdir' => 1  );my %opt = %default_opt;my ( $pattern , @files ) = process_args();my $re_flags = 'x';$re_flags .= 'i' if $opt{'ignore-case'};($pattern) = map qr($_) , "(?$re_flags)$pattern" ;#  Used elsewhere in multiple places.my $spec = 'File::Spec';foreach my $file ( @files ){  search_file( $file , $pattern , \%opt );}exit;sub search_file{  my ( $file , $pattern , $opt ) = @_;  unless ( defined $pattern )  {    die "Pattern is not defined\n";    return;  }  return if -l $file ;  if ( -d _ )  {    search_directory( $file , $pattern , $opt ) if $opt->{'recursive'} ;    return;  }  unless ( -T $file || $opt->{'bin-search'} )  {    warn "Failed 'ASCII test', skipped $file\n" if $opt->{'verbose'};    return;  }  if ( ! -f _ )  {    warn "Non-regular file, skipped $file\n" if $opt->{'verbose'};    return;  }  my $save;  return unless real_search( $file , \$save , $opt );  my $alt = get_alternate_name( $file , $opt ) || $file ;  $alt = make_term_bold( $alt , qr{.+} ) if $opt->{'highlight'} ;  printf "==>>>  %s\n" , $alt;  print $save ;  print "\n";}sub search_directory{  my ( $dir , $re , $opt ) = @_;  my $dh;  unless ( opendir $dh , $dir )  {    warn "Cannot open directory $dir: $!";    return;  }  while ( my $file = readdir $dh )  {    next if $file eq $spec->curdir or $file eq $spec->updir ;    search_file( $spec->catfile( $dir , $file ) , $re , $opt );  }  return;}sub real_search{  my ( $file , $save , $opt ) = @_;  my ( $in , $close ) = open_file( $file );  return unless $in;  my ( $lines , $matches );  my $space = qr{ [ \t]+ }x;  my $result = result_format( $opt );  while ( my $line = <$in> )  {    if ( $opt->{'invert-match'} )    {      next if $line =~ m/$pattern/;    }    else    {      next if $line !~ m/$pattern/;    }    $lines++;    if ( $opt->{'collapse-space'} )    {      $line =~ s/^$space//;      $line =~ s/$space+$//;      $line =~ s/$space/ /g;    }    if ( !$opt->{'invert-match'}  && $opt->{'highlight'} )    {      $line = make_term_bold( $line , $pattern );    }    $$save .= $result->( $. , $line );  }  $close->();  return $lines;}sub result_format{  my ( $opt ) = @_;  my $line_fmt = '%' . $opt->{'number-width'} . "d  %s";  my $newline = $opt->{'blank-line'} ? "\n" : '';  return    $opt->{'line-numbers'}    ? sub { sprintf $line_fmt , $_[0] , $_[1]  . $newline }    : sub { $_[1] . $newline } ;}sub make_term_bold{  my ( $in , $re ) = @_;  my ( $bold , $norm ) = ( "\e[1m" , "\e[0m" );  $in =~ s/($re)/$bold$1$norm/g;  return $in;}sub get_alternate_name{  my ( $name , $opt ) = @_;  return unless $opt;  if ( $opt->{'realpath'} || $opt->{'strip-curdir'} )  {    require Cwd;    import Cwd qw( abs_path getcwd );    $name = abs_path( $name );    $name = strip_current_dir( $name ) if $opt->{'strip-curdir'};    return $name;  }  return $name if !$opt->{'cleanse-path'};  return $spec->canonpath( $name );}sub strip_current_dir{  my ( $path ) = @_;  my $curdir = quotemeta getcwd();  $path =~ s{^ $curdir / }//x;  return $path;}sub open_file{  my ( $file ) = @_;  my $fh;  unless ( open $fh , '<' , $file )  {    warn "Cannot open $file: $!";    return;  }  return ( $fh , sub { close $fh or die "Cannot close $file: $!" } ) ;}sub process_args{  GetOptions  (    'h|help' => \$opt{'help'}  , 'D|show-default-opt' => \$opt{'show-default-opt'}  , 'S|show-set-opt'     => \$opt{'show-set-opt'}  , 'q|quiet'  => sub { $opt{'verbose'} = undef }  , 'verbose+' => \$opt{'verbose'}  , 'v|invert-match' => \$opt{'invert-match'}  , 'i|ignore-case!' => \$opt{'ignore-case'}  , 'r|recursive!' => \$opt{'recursive'}  , 'B|bin-search' => \$opt{'bin-search'}  , 'n|line-numbers!'  => \$opt{'line-numbers'}  , 'w|number-width=i' => \$opt{'number-width'}  , 'C|collapse-space!'    => \$opt{'collapse-space'}  , 'b|blank-line!' => \$opt{'blank-line'}  , 'H|highlight!'  => \$opt{'highlight'}  , 'c|cleanse-path!' => \$opt{'cleanse-path'}  , 'R|realpath!'     => \$opt{'realpath'}  , 's|strip-curdir!' => \$opt{'strip-curdir'}  )    || die pod2usage('-exitval'  => 2 , '-verbose'  => 1);  show_options( $opt{'show-set-opt'} ? \%opt : \%default_opt , 'exit' )    if $opt{'show-default-opt'} or $opt{'show-set-opt'} ;  pod2usage('-exitval' => 0 , '-verbose' => 3)    if $opt{'help'};  #  Check if any arguments remain which will be file names  pod2usage( '-msg' => ''            , '-exitval' => 1            , '-verbose' => 1          )    if scalar @ARGV < 2;  return @ARGV;}sub show_options{  my ( $opt , $exit ) = @_;  my $out;  my $max = ( sort { $b <=> $a } map length( $_ ) , keys %{ $opt } )[0];  $max++;  my $fmt = '%' . $max . "s: %s\n";  foreach my $k ( sort keys %{ $opt } )  {    my $v = $opt->{ $k };    $out .=      sprintf $fmt        , $k , ( !$v ? 'no' : $v == 1 ? 'yes' : $v ) ;  }  print $out;  exit 0 if $exit;}__END__=pod=head1 NAMEfile-search - Search for regular expressions in text files.=head1 SYNOPSISTo see default options ...  file-search -show-default-optTo search case-insensitively, recursively, highlight text matched,and preserve spaces & tabs ...  file-search \    -ignore-case -recursive -highlight -nocollapse-space \    '(pat|s)tern' \    file(s) | directory(ies)=head1 DESCRIPTIONThe main reason for existence of this program is to minimizehorizontal scrolling by displaying the file name only once (on a lineof its own) before display of the lines matched, and by collapsingtabs and multiple spaces.  Other reasons are to strip the currentdirectory from the file name paths, and to have matched texthighlighted.Below are first few lines of output ofC with default options, namelyhighlight the matched text (actual escpace character has been replacedby '\e' solely to keep this file "text") ...  ==>>>  \e[1mfile-search\e[0m    23  , '\e[1mcollapse\e[0m-space' => 1   131  if ( $opt->{'\e[1mcollapse\e[0m-space'} )   230  , 'C|\e[1mcollapse\e[0m-space!' => \$opt{'\e[1mcollapse\e[0m-space'}   ...After the options have been taken into account, first parameter istaken to be a Perl regular experssion, and rest as the files to searchfor.  Directories are skipped if I<-recursive> option is not given.=head1 OPTIONSSome of the options can be negated by prefixing it with "no" as listedbelow; the last option will override preivous one.  For exmaple, IfI<-norecursive> is followed by I<-recursive>, files will berecursively searched when a directory is encountered.=head2 General Options=over 4=item B<-help> | B<-h>Shows this message.=item B<-quiet> | B<-q>Produce grave error messages only.=item B<-show-default-opt> | B<-D>Show default options.=item B<-show-set-opt> | B<-S>Show options given on command line.=item B<-verbose>Produce extra messages.  Specifying it multiple times causes more outputaccordingly.=back=head2 Search & Display Options=over 4=item B<-bin-search> | B<-B>Search through binary files (as determined by L<-T> function).=item B<-blank-line> | B<-b>Put a blank line after each line where the pattern matches.B<-noblank-line> turns off this option.=item B<-cleanse-path> | B<-c>Do sane path clean up (for the file name to De displayed) withouttouching the file system.  See L.B<-nocleanse-path> turns off this option.=item B<-collapse-space> | B<-C>Display lines after removing multiple spaces and tabs.B<-nocollapse-space> turns off this option.=item B<-highlight> | B<-H>Highlight the text which matches given pattern.B<-nohighlight> turns off this option.=item B<-ignore-case> | B<-i>Do case-insensitive pattern matching.B<-noignore-case> turns off this option.=item B<-invert-match> | B<-v>Show lines which do not match the given pattern(s).=item B<-line-numbers> | B<-n>Show line numbers.B<-noline-numbers> turns off this option.=item B<-number-width> I | B<-w> INumber of characters to use to format line numbers.=item B<-realpath> | B<-R>Display real path of a file.  See L.B<-norealpath> turns off this option.=item B<-recursive> | B<-r>If a directory is given as one of the files, search through all the files in it.B<-norecursive> turns off this option.=item B<-strip-curdir> | B<-s>Remove current directory path from file names displayed.B<-nostrip-curdir> turns off this option.=back=head1 DEPENDENCY=over 2=item *Cwd=item *File::Spec=item *Getopt::Long=back=head1 TO DO=over 2=item *Ability to see context of given number of lines.=item *Possibly use Term::* module(s) to highlight.=back=head1 BUGS=over 2=item *When highlighting is used, raw sequence is inserted in the output.That seems to work well for L in my environment, but may notelsewhere.  Piping output to C seems to work too underCygwin-X in L.=back=head1 SEE ALSOL=head1 AUTHOR, LICENSE, DISTRIBUTION, ETC.Parv, parv_@yahoo.comMODIFIED:  Oct 07 2006This software is free to be used in any form only if proper credit isgiven.  I am not responsible for any kind of damage or loss.  Use itat your own risk.=cut

Zedulator - a tiled, integrated CB/PM/Web client (jZed)

#!/usr/bin/perl -wuse strict;print "\nEnter a pmurl or nothing for www.perlmonks.org : ";my $pmurl = <>;chomp($pmurl);my %v;($v{main},$v{search},$v{talk},$v{help})= split /\n\n/, join '', ;print "\nmodifying pmurl to $pmurl ... \n" if $pmurl;$v{main} =~ s/www.perlmonks.org/$pmurl/g if $pmurl;for my $section(qw(help main search talk)) {    my $fn = "zedulator.$section.html";       $fn =~ s/\.main//;    print "creating $fn ... \n";    open(my $fh,">$fn");    print $fh  $v{$section};    close $fh;}print "all done! ... \n";__DATA__    Perlmonks zedulator                                                                                                 <p>No Frames?           <a href="http://www.perlmonks.org/?displaytype=raw;node=showchatmessages">Chat Here</a>       </p>     Zedulator Search
 Zedulator Talk
      Zedulator Help    ZEDULATOR tiles your browser with frames as shown in the diagram. Use the frame borders to contract or expand the frames as needed.
You can search using PerlMonks shortcuts or go directly to any URI using zedulator shortcuts. (see searching)
The search results are, by default, targeted to the browsing frame. Links in the private messages, other users, and chat frames can also be targeted to the browsing frame.(see targeting)
You can customize shortcuts, frames, and targeting. (see customizing) +---------------+---------------+|   talk input  | search input  ++---------------+---------------+| private msgs  | other users   |+---------------+---------------+|                               ||        chat frame             ||                               |+-------------------------------+|                               ||      browsing frame           ||                               |+-------------------------------+
Zedulator: search shortcuts
The default search goes directly to Perlmonks search. However, if the search term starts with a forward slash, it gets treated as a zedulator search and uses the built-in or custom zedulator shortcuts and goes directly to the requested page, bypassing Perlmonks.  Custom shortcuts can be calls to local javaScript functions, see the shortcut definitions in zedulator.html.
/zed open this help page
gogle:// any standard PerlMonks shortcut like pad://, cpan:, etc.
/cb60 open mini-cb60.flux8.com
/nn open Newest Nodes
/float float zedulator in a chromeless window
/filepath open a local file
Zedulator : targeting links to the bottom frame
searches automatically appear in bottom frame
links in other zedulator frames drag and drop the link to the search input box and submit the search
browser bookmarks copy the link, paste it into the search input box and submit the search
Zedulator : customizing
create custom search shortcuts edit the shortcut/url associations in zedulator.html
start with page other than zedulator help edit the browse_frame.src in zedulator.html
permanent resize/move/ delete frame edit framesets in zedulator.html
retarget search to tab or window edit the form target in zedulator.search.html

Guest Cleanup (Maze)

#!/usr/bin/perl#reguest.pl#by Chris Monahan#this is free software, you can distribute it under the same terms as perl itselfuse warnings;use strict;my @dirs = ("Music", "Pictures", "Documents", "Desktop");print "preserving guest content under a timestamped folder \n \n";my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdist) = gmtime(time);  $min++; $hour++; $mday++; $sec++; $mon++; $year++; my $count = 0; my @mkdir = ( "$year:$mon:$mday", "$hour:$min:$sec");chdir ("/home/guest-content");while ($count ne @mkdir){system "mkdir $mkdir[$count]";chdir "$mkdir[$count]";$count ++;}chdir ("/home");$count = 0;while ($count ne @dirs){my $dest = "guest-content/$year:$mon:$mday/$hour:$min:$sec/";#unless (system ("mv guest/$dirs[$count]/ $dest");#){#}$count++;}print "purging configuration settings \n ";system ("rm -R  guest");print "restoring guest home \n ";system ("mkdir guest");system ("cp -R default/* guest");$count = 0;while ($count ne @dirs){system ("mkdir guest/$dirs[$count]");$count++;}print "restoring guest account password and ownership details \n";#system("usermod -p password guest");system ("chown -R guest:guest guest");print "done \n"

Screwed tree scanning (Maze)

#!/usr/bin/perl#this is free software, you can distribute it under the same terms as perl itself# scanfiletree pre alpha#by Christopher Monahan # scans a filetree as defined by a set of parameters passed to it # and returns it in the preferred format  eg: XMLuse warnings;use strict;# use XML::Simple;use Cwd;use Data::Dumper; #beginning of variable declarationslocal $::path;                 #scalar for the path when in string formlocal @::path;                 #array for the path when in list formlocal @::direntry;           #array for holding the directory entries of the directory being scanned # local %::params;               #basic parameters passed to scantree via arguments and the configurationlocal $::root;                 #the virtual root to start scanning fromlocal $::troot;                #the true root to start scanning fromlocal $::outputfile;           #the name of the file that will receive the fatefull treedata# local %::handler_self_params;  #parameters with some extrapolation involved destined for controlling the handler subroutines# local $::mainflag;             #the main argument passed to scantree# local $::regdir[0] = 1;        #the value for the register sublocal %::treehash;             #the hash the tree will be stored inlocal $::status;               #here to stop things if things go sour, or tell a particular stage to implement advanced mechanisms# end of variable declarations#begin sub definitionssub scan { #for scanning arrays in generalmy @hunt = split (/&/, $_[0]);if ($#hunt ne 0){my $count = 0;my %founda;my $length = 0;while ($count != @hunt){$founda{$count} = grep {/$hunt[$count]/} @_;$length = $length + length($founda{$count});$count++;}return $length; #? will this work ?}else{my @foundb = 0;@foundb = grep {/$_[0]/} @_;return $#foundb;}}### eatdir section# sub handle_eatdir_params {#  if (defined (%::handler_self_params{"eatdir"}{"split"})) {#  @::path = split (/\//, $_[0])#  } # if (defined (%::handler_self_params{"eatdir"}{"register"})){# my $count = 0;# while ($count ne $#path){# if ($count == 0){# register;# $count++# }# }# if (%::handler_self_params {"eatdir"} {"register"}){# return @path# }# else {# return $_[0]# }# }sub eatdir {my $seendir = $_[0];my @direntries;my $direntry;# my @seendir = handle_eatdir_params(@_);# my @seendir = @_;# unless ($#seendir eq 0) {my $seendir = join ("/", @seendir)}# else {my $seendir = $seendir[0]}opendir SEENDIR, $seendir;@direntries = readdir SEENDIR;closedir SEENDIR;$direntries[0] = "pie";$direntries[1] = "pie";foreach $direntry (@direntries){if (-d "$seendir/$direntry"){eatdir ("$seendir/$direntry")}}my $direntries = join ( ':' , @direntries);handle_direntries("${seendir}:${direntries}");}### direntry subs ###sub handle_direntries{&::handle_direntries_params($_[0]);&::handle_direntries_main;}sub handle_direntries_params {($::path, @::direntry) = split (/:/, $_[0]);@::path = split (/\//, $::path);# more argument parsing for options here later}sub handle_direntries_main{my $count = 0;local %::pathline;while ($count ne $#::path){$::pathline{"$::path[$count]:$count"} = {};$count ++;}$count = 0;while ($count ne $#::direntry){unless (-d "$::path/$::direntry[$count]"){ $::pathline{"$::path[$#::path]:$#::path"}{"$::direntry[$count]"} = $::FileLabel; }$count ++; }$count = $#::path;while ($count gt 0){my $lcount = $count - 1;$::pathline{"$::path[$lcount]:$lcount"}{"$::path[$count]"} = $::pathline{"$::path[$count]"};delete $::pathline{"$::path[$count]"};$count --;}local $::mergecount;local $::mergepoint;&handle_direntries_merge;}sub mergepoint{if (defined $_[0]){my $val = join ('{', $::mergepoint,$_[0]); #}$val = "$val}";$::mergepoint = $val;return $val;}else{return ' ';}}sub handle_direntries_merge{no strict 'refs';# my $merge = $_[0];# my $treeref = $_[1];if (defined $_[0]){my $mergepoint = mergepoint($_[0]);}else {my $mergepoint = mergepoint;}my @mergekeys = keys %::pathline$mergepoint};my $mergekey;foreach ($mergekey, @mergekeys){if (exists %::treehash$mergepoint{$mergekey}){$::mergecount++;handle_direntries_merge($mergekey);$::mergecount - 1;}else {$::treehash$mergepoint{$mergekey} = $::pathline$mergepoint{$mergekey};}}}#here should lie some code for taking the hash of a particular pathline, and merging it in with the main treehash#at the moment just dump for diagnostic purposes - comment out the above of the  and uncomment the following line to get some tacky functionality# print Dumper(%{$_[0]});# sub handle_direntries_main_alt{# my $count = 1;# my $treeref = \%::treehash;# while ($count != $#::path){# $treeref = \%$treeref->{$::path[$count]};# $count++;# next if $count == $#::path;# unless (defined($treeref->{$::path[$count]})) {# $treeref->{$::path[$count]} = {"$::DirLabel" => $::path[$count]}# }# $count = 0;# while ($count != $#::direntries){# $treeref -> {$::path[$count]}{$::direntry[$count]} = "$::FileLabel" unless $treeref -> {$::path[$count]}{$::direntry[$count]} = "$::DirLabel";# } # }# }# sub register { #sub for keeping track of directories: eg - making sure we are not in a recursive symlink loop, could use inode numbers here# if(){# $::regdir[$::regdir[0]]="first $main::regdir[$::regdir[0]]"# }### stage subs ###sub begin{print "Ready to scan $::troot and deposit the resulting XML into $$::outputfile \n shall I proceed? (y/n)\n";my $confirm = ;if ($confirm =~ /y|Y/){chroot($::troot);&eatdir($::troot);}else{die "it was a pleasure anyway \n";$::status = 0;}%::treehash = ("begin","+","root","/$::root");}sub handle_main_params{ #{ # this bits a stub# $::mainflag = \$ARGV[0] unless defined(@_);# # if ($::mainflag =~ /-x|--routine/){# # ## routine scheduling bit# # }# elsif ($::mainflag eq "-c") {# ##configuration bit# }# else {$::root = \$ARGV[0];$::outputfile = \$ARGV[1];my $cd = cwd;unless ($::root =~ /[^\/]/){ $::troot = "$cd\/$$::root"; }else {$::troot = $$::root; }}sub finish{#again another stubprint Dumper(%::treehash);}# end of subroutine definitions#main$::FileLabel = "File";# $::DirLabel = '+';handle_main_params ();begin();finish();print 'we have reached the end 2 \n';## end of mainh

Latin Verb Conjugator (Minimiscience)

#!/usr/bin/perl -w#conjugate.pl, v.1.0#Created by John T. Wodder II#Last edited: 21 Sept 2006 by John Wodder#This script will create a synopsis of a Latin verb & output it as a LaTeX#document.use strict;use Switch;my($tmp, $base, $vowel, $vowel2, $stemTwo, $stemThree, $conj, $trans, $first, $subj, $extPerson, $person, $personal, $passive, $perfect, $sum, $adj);my %short = ('\\=o', 1, 'm', 1, 's', 0, 't', 1, 'mus', 0, 'tis', 0, 'nt', 1, 'r', 1, 'ris/re', 0, 'tur', 0, 'mur', 0, 'min\\=\\i', 0, 'ntur', 1, 'or', 1, 'te', 0);my $word = qr/[[:alpha:]\\={}]+/;my $long = qr/\\=\{?\\?([aeio])\{?\}?/i;my $lineTerm = " \\\\\n";sub append { my($pre, $post, $opt) = @_; # Bits guide for $opt: # 1 - Use 'm' instead of '\=o' # 2 - Use -i\=o & -iunt endings (Use is determined at runtime) # 4 - Use -int instead of -unt (only applies to fut. perf. act. indic.) $opt = 0 unless defined $opt; $post = 'm' if $post eq '\\=o' && ($opt & 1); if ($pre =~ /$long$/o) {  $pre =~ s/$long$/$1/o if $short{$post};  $pre =~ s/i$/iu/io if $post =~ /^nt/o && ($opt & 2);  $pre =~ s/a$//io if $post =~ /^(\\=)?o/o; } else {  $pre =~ s/e$/i/io;  if ($post =~ /^nt/) {   if ($opt & 2) {    $pre =~ s/i$/iu/o;   } elsif (!($opt & 4)) { # 4 applies to the fut. perf. act. indic.    $pre =~ s/i$/u/o;   }  } elsif ($post =~ /^(\\=)?o/o && !($opt & 2)) {   $pre =~ s/i$//o;  } elsif ($post eq 'ris/re') {   $pre =~ s/i$/e/io;  } } print $pre, $post;}print "Enter the four principal parts of the verb you wish to conjugate,\nseparated by spaces, with macrons denoted LaTeX-style:\nEnter `quit' to exit.\n> ";VERB: while () { if (/^(($word)([ie]?)\\=o),?\s+\2(e|$long)re,?\s+($word)\\=\{?\\i\{?\}?,?\s+($word)us$/io) { # (\\=ur|\\=\{u\}r)?  ($first, $base, $vowel, $stemTwo, $stemThree) = ($1, $2, $4, $6, $7);  $trans = $7 !~ /(\\=ur|\\=\{u\}r)$/i;  $stemThree =~ s/(\\=ur|\\=\{u\}r)$//i unless $trans;  switch ($vowel) {   case m/^\\=\{?a\}?$/i {$conj = 1; $subj = '\\=e'; $vowel2 = '\\=a'; }   case m/^\\=\{?e\}?$/i {$conj = 2; $subj = 'e\\=a'; $vowel2 = '\\=e'; }   case m/^e$/i {($conj, $subj, $vowel2) = $3 ? (4, 'i\\=a', 'i\\=e') : (3, '\\=a', '\\=e'); }   case m/^\\=\{?\\i\{?\}?$/i {$conj = 5; $subj = 'i\\=a'; $vowel2 = 'i\\=e'; }   else {die("An error has occurred in parsing the stem vowel.\n"); }  }  last VERB; } elsif (/^($word)\\=\{?o\}?$/io) {  my $a = $1;  print 'Is the verb a standard first-conjugation verb? (y/n): ';  $tmp = ;  if ($tmp =~ /^y/i) {   ($base, $conj, $vowel, $subj, $trans, $stemTwo, $stemThree, $first, $vowel2) = ($a, 1, '\\=a', '\\=e', 1, $a.'\\=av', $a.'\\=at', $a.'\\=o', '\\=a');   last VERB;  } else {print "Enter the four principal parts.\n"; } } elsif (/^q(uit)?$/io) {exit; } elsif ($_ eq "`quit'\n") {print "I didn't mean that literally.\n"; } else {print "Quid?\n"; } print '> ';}print "In what person & number do you wish to conjugate this verb?\n> ";PERSON: while(defined($extPerson = )) { switch ($extPerson) {  case /^(1(st)?|first)(\s*person)?,?\s*s(ing(\.|ular)?)?$/io {   ($person, $personal, $passive, $perfect, $sum, $adj) = (0, '\\=o', 'r', '\\=\\i', 'sum', 'us/a/um');   last PERSON;  } case /^(2(nd)?|second)(\s*person)?,?\s*s(ing(\.|ular)?)?$/io {   ($person, $personal, $passive, $perfect, $sum, $adj) = (1, 's', 'ris/re', 'ist\\=\\i', 'es', 'us/a/um');   last PERSON;  } case /^(3(rd)?|third)(\s*person)?,?\s*s(ing(\.|ular)?)?$/io {   ($person, $personal, $passive, $perfect, $sum, $adj) = (2, 't', 'tur', 'it', 'est', 'us/a/um');   last PERSON;  } case /^(1(st)?|first)(\s*person)?,?\s*p(l(\.|ur(\.|al)?)?)?$/io {   ($person, $personal, $passive, $perfect, $sum, $adj) = (3, 'mus', 'mur', 'imus', 'sumus', '\\=\\i/ae/a');   last PERSON;  } case /^(2(nd)?|second)(\s*person)?,?\s*p(l(\.|ur(\.|al)?)?)?$/io {   ($person, $personal, $passive, $perfect, $sum, $adj) = (4, 'tis', 'min\\=\\i', 'istis', 'estis', '\\=\\i/ae/a');   last PERSON;  } case /^(3(rd)?|third)(\s*person)?,?\s*p(l(\.|ur(\.|al)?)?)?$/io {   ($person, $personal, $passive, $perfect, $sum, $adj) = (5, 'nt', 'ntur', '\\=erunt', 'sunt', '\\=\\i/ae/a');   last PERSON;  } case /^q(uit)?$/io {exit; }  else {print "Quid?\n"; } } print '> ';}my $file = $first;$file =~ s/[\\={}]//g;open(FILE, '>', "$file.tex");select FILE;print "\\documentclass{article}\\begin{document}\\title{Synopsis of \\emph{$first}, $extPerson}\\author{\\texttt{conjugate.pl}, v.1.0}\\maketitle\n\\begin{center}\\begin{tabular}{l ", ($trans ? "c c}\n & \\textbf{Active} & \\textbf{Passive} \\\\ \\hline\n\\multicolumn{3" : "c}\n\\multicolumn{2"), "}{c}{\\textbf{Indicative Mood}} \\\\ \\hline\n";print 'Present & ', $base; append($vowel, $personal, ($conj>3) ? 2 : 0);if ($trans) { print ' & ', $base; append($vowel, ($person==0) ? 'or' : $passive, ($conj>3) ? 2 : 0);}print $lineTerm, 'Imperfect & ', $base, $vowel2;append('b\\=a', $personal, 1);if ($trans) { print ' & ', $base, $vowel2; append('b\\=a', $passive);}print $lineTerm, 'Future & ', $base;if ($conj < 3) { print $vowel; append('bi', $personal);} else { append(($person==0) ? $subj : $vowel2, $personal, 1);}if ($trans) { print ' & ', $base; if ($conj < 3) {  print $vowel;  append('bi', ($person==0) ? 'or' : $passive); } else {  append(($person==0) ? $subj : $vowel2, $passive); }}print $lineTerm, 'Perfect & ', $stemTwo, $perfect;print ' & ', $stemThree, $adj, ' ', $sum if $trans;print $lineTerm, 'Pluperfect & ', $stemTwo;append('er\\=a', $personal, 1);if ($trans) { print ' & ', $stemThree, $adj, ' '; append('er\\=a', $personal, 1);}print $lineTerm, 'Future Perfect & ', $stemTwo;append('eri', $personal, 4);if ($trans) { print ' & ', $stemThree, $adj, ' '; append('eri', $personal);}print $lineTerm, '\\multicolumn{', $trans+2, "}{c}{\\textbf{Subjunctive Mood}} \\\\ \\hline\n Present & ", $base;append($subj, $personal, 1);if ($trans) { print ' & ', $base; append($subj, $passive);}print $lineTerm, 'Imperfect & ', $base, $vowel;append('r\\=e', $personal, 1);if ($trans) { print ' & ', $base, $vowel; append('r\\=e', $passive);}print $lineTerm, 'Perfect & ', $stemTwo;append('er\\=\\i{}', $personal, 1);if ($trans) { print ' & ', $stemThree, $adj, ' '; append('s\\=\\i{}', $personal, 1);}print $lineTerm, 'Pluperfect & ', $stemTwo;append('iss\\=e', $personal, 1);if ($trans) { print ' & ', $stemThree, $adj, ' '; append('ess\\=e', $personal, 1);}print $lineTerm, '\\multicolumn{', $trans+2, "}{c}{\\textbf{Infinitives}} \\\\ \\hline\n Present & ", $base, $vowel, 're';print ' & ', $base, ($conj != 3 && $conj != 4) ? ($vowel, 'r\\=\\i') : '\\=\\i' if $trans;print $lineTerm, 'Perfect & ', $stemTwo, 'isse';print ' & ', $stemThree, 'us/a/um esse' if $trans;print $lineTerm, 'Future & ', $stemThree, '\\=urus/a/um esse';print ' & ---' if $trans;print $lineTerm, '\\multicolumn{', $trans+2, "}{c}{\\textbf{Participles}} \\\\ \\hline\n Present & ", $base, $vowel2, 'ns, -';$vowel2 =~ s/\\=//;print $vowel2, 'ntis';print ' & ---' if $trans;print $lineTerm, 'Perfect & ---';print ' & ', $stemThree, 'us/a/um' if $trans;print $lineTerm, 'Future & ', $stemThree, '\\=urus/a/um';print ' & ', $base, $vowel2, 'ndus/a/um' if $trans;print $lineTerm, '\\multicolumn{', $trans+2, "}{c}{\\textbf{Imperatives}} \\\\ \\hline\n & ", $base, $vowel, ', ', $base;append($vowel, 'te');if ($trans) { print ' & ', $base, $vowel, 're, ', $base; append($vowel, 'min\\=\\i');}if ($trans) { print <

BinBot - Find .NZB links in RSS feeds. (iamjafi)

#!/usr/bin/perl# Binbot.pl: Reads a list of rss feeds from a file and searches for keywords, writing matching  and# <link> elements to a new rss file.# I use it for tracking USENET binaries, but it could be used for any pupose.#Files: #urls.txt - A text file consisting of URLs to rss feeds, one per line. #e.g. http://www.whatever.com/some-rss.rss#keywords.txt - A text file consisting of keywords to search for, one per line.# 9/24/06 - switched to URI::Fetch (from LWP::Simple) to allow reading gzip compressed feeds.use strict;use warnings;use XML::RSS::Parser::Lite;use XML::RSS::SimpleGen;use URI::Fetch;#variablesmy $url_file = "urls.txt";my $rss_file = "binbot.rss";my $keyword_file = "keywords.txt";my @keywordlist;my @rsslist;#load keywordsopen (KEYWORDFILE, $keyword_file) || die "No Keyword file ($keyword_file) found, aborting.\n";while (<KEYWORDFILE>){chomp;push (@keywordlist, $_);}close KEYWORDFILE;#load list of rss filesopen (URLFILE,"$url_file") || die "No URL file ($url_file) found, aborting.\n";while (<URLFILE>){chomp;push (@rsslist, $_);}close URLFILE;#create the output rss imagerss_new('htp://www.whatever_you_want.com',"BinBot Results");#loop through the rss files searching for keywordsforeach my $rss (@rsslist) {print "Reading $rss\n";#Fetch the file. If successful, search for keywordsmy $res = URI::Fetch->fetch($rss) or die URI::Fetch->errstr;if ($res->is_success) {      my $xml = $res->content;  my $rp = new XML::RSS::Parser::Lite;$rp->parse($xml);# Search for keywords in rss filefor (my $i = 0; $i < $rp->count(); $i++) {my $item = $rp->get($i);foreach my $kw (@keywordlist) {my $title = $item->get('title');my $url = $item->get('url');my $desc = $item->get('description');# If the keyword exists in the title, add the entry to the rss image.if ( $title =~ /$kw/i ) { print "Matched keyword $kw\n";rss_item($url,$title,$desc) }}}} else {      print $res->status_line, "\n";  }}# Save the rss image to a file.rss_save("$rss_file");</pre>
</article>
<article>
<h1>Windows Active Directory to PDF Phone List (davis)</h1>
<pre class="block_code">#!/usr/bin/perluse warnings;use strict;use Data::Dumper;use Net::LDAP;use Net::LDAPS;use Template;my $template_input = '\documentclass[10pt,a4paper]{article}\usepackage{times}\usepackage{xtab}\usepackage{colortbl}\setlength\textheight{290mm}\setlength{\voffset}{-15mm} \begin{document}\begin{center}\begin{xtabular}{lllll}\textbf{Name} & \textbf{Title} & \textbf{Ext.} & \textbf{Mobile} & \textbf{SPD} \\\\\hline[% FOREACH buildings %]\hline\multicolumn{5}{c}{[% buildingname %]}\\\\\hline[% FOREACH staff %][%- IF loop.index % 2 -%]\rowcolor[gray]{0.91}[%- END -%][%name%] & \\tiny{[%title%]} & [%extension%] & [%mobile%]  & [%mobile_speed_dial%]\\\\[% END %][% END %]\end{xtabular}\end{center}\end{document}';##There'll be some customization necessary heremy $ldap = Net::LDAPS->new("domain.controller") or die "$@";my $message    = $ldap->bind( "cn=Some User,ou=Service Accounts,dc=company,dc=com",    password => 'Secret' );$message = $ldap->search(    base   => "ou=Employees,dc=company,dc=com",    filter => "(& (cn=*) (objectClass=user))",);$message->code && die $message->error;my @skip_names = (    #A list of names to be skipped (service/admin accounts etc));my %staff;foreach my $employee ( $message->all_entries ) {    my $name = $employee->get_value("cn");    next if ( grep /^\Q$name\E$/, @skip_names );        my $title             = $employee->get_value("title")           || "";    my $extension         = $employee->get_value("telephoneNumber") || "";    my $mobile            = $employee->get_value("mobile")          || "";    my $mobile_speed_dial = $employee->get_value("pager")           || "";        my $building = $employee->get_value("physicalDeliveryOfficeName") || "";    my $useraccount_control = $employee->get_value("userAccountControl")        || "";    next if ( account_disabled($useraccount_control) );    # Skip disabled accounts    push @{ $staff{$building} },        {        name              => $name,        title             => $title,        extension         => $extension,        mobile            => $mobile,        mobile_speed_dial => $mobile_speed_dial        };}my @buildings;foreach my $building ( sort keys(%staff) ) {    my @staff = sort { $a->{name} cmp $b->{name} } @{ $staff{$building} };    push @buildings, { buildingname => $building, staff => \@staff };}my $template = Template->new();my $output;$template->process( \$template_input, { buildings => \@buildings }, \$output )    or die $template->e->error(), "\n";open( my $fh, ">", "phone_list.tex" )    or die "Couldn't open phone_list.tex for writing: $!\n";print $fh $output;close($fh);sub account_disabled {    my $flags = shift;    my %check = calculate_flags($flags);    return 1 if ( $check{ACCOUNTDISABLE} );    return 0;}sub calculate_flags {    my $flags_to_check = shift;    my %table          = (        SCRIPT                         => 0x0001,        ACCOUNTDISABLE                 => 0x0002,        HOMEDIR_REQUIRED               => 0x0008,        LOCKOUT                        => 0x0010,        PASSWD_NOTREQD                 => 0x0020,        PASSWD_CANT_CHANGE             => 0x0040,        ENCRYPTED_TEXT_PWD_ALLOWED     => 0x0080,        TEMP_DUPLICATE_ACCOUNT         => 0x0100,        NORMAL_ACCOUNT                 => 0x0200,        INTERDOMAIN_TRUST_ACCOUNT      => 0x0800,        WORKSTATION_TRUST_ACCOUNT      => 0x1000,        SERVER_TRUST_ACCOUNT           => 0x2000,        DONT_EXPIRE_PASSWORD           => 0x10000,        MNS_LOGON_ACCOUNT              => 0x20000,        SMARTCARD_REQUIRED             => 0x40000,        TRUSTED_FOR_DELEGATION         => 0x80000,        NOT_DELEGATED                  => 0x100000,        USE_DES_KEY_ONLY               => 0x200000,        DONT_REQ_PREAUTH               => 0x400000,        PASSWORD_EXPIRED               => 0x800000,        TRUSTED_TO_AUTH_FOR_DELEGATION => 0x1000000,    );    my %results;    foreach my $flag ( keys %table ) {        $results{$flag} = 1 if ( $flags_to_check & $table{$flag} );    }    return %results;}</pre>
</article>
<article>
<h1>unichist -- count/summarize characters in data (graff)</h1>
<pre class="block_code">#!/usr/bin/perl=head1 NAMEunichist=head1 SYNOPSISunichist [--chart] [--top=N] [--hex[only]] [--enc=ENC] [file ...] --chart : print summary of character counts per "chart" --top=N : print only the N most frequent characters --hex     : include the Unicode hexadecimal code point value --hexonly : show the hex code point instead of the character itself --enc=ENC : convert input from ENC to utf8 (def: input is utf8)=head1 DESCRIPTIONFor text data provided on STDIN or in one or more files named on thecommand line, this program will print the list of characters occurringin the data, together with the frequency of occurrence for eachcharacter.By default, input is assumed to be in utf8, and all characters presentin the input are counted and listed on STDOUT, one character per line,in their "standard" order (i.e. the numeric ordering determined bytheir Unicode code point values), with the number of occurrencesfollowing each character.If the input uses some known encoding other than utf8, simply name theencoding with the "--enc=..." option (e.g. "--enc=cp1252" or"--enc=UTF-16LE").  If the value of this option is not recognized as aknown encoding, the program exits with an error message listing theknown encodings.  (Note that ASCII is a proper subset of utf8; the--enc option is only needed when data is neither ASCII nor utf8.)Output is always in utf8 (but with the "--hexonly" option, it willalways be just plain ASCII).The --hex option will put the hexadecimal code point value at thebeginning of each output line, followed by the utf8 character and thenits frequency.  Use --hexonly to output just the hexadecimal value andfrequency without the actual utf8 character itself (useful when yourdisplay window is unable to handle utf8 data correctly).The "--top=N" option will cause only the N most frequent characters tobe listed, in descending order of frequency.  If N is 0, no characterswill be listed (useful in combination with the "--chart" option,described below).  If N is -1, all characters will be listed indescending order of frequency (instead of the default code-pointorder).The "--chart" option will produce a supplemental set of output lines,breaking the character counts into groups according the the "chart"pages defined by the Unicode Standard (version 5.0).  As of thisversion, there are about 150 distinct "charts" ranging fromU0000-U007F (ASCII) to U2F800-U2FA1F (CJK Compatibility IdeographsSupplement).  These charts define the classes of characters thatUnicode uses when organizing its code pages into distinct sets(e.g. by language, writing system or function).  Usually, a given datafile would contain characters spanning just a few distinct charts, andthis form of listing is useful when checking for "outlier characters".To see only this summary of character counts by chart, use this optionin combination with "--top=0", to turn off the listing of individualcharacters with their frequencies.=head1 LIMITATIONS/BUGSBe aware that some values in the range \x{0000} - \x{2FA1F} do notcorrespond to defined characters -- there are gaps in the variouscharts.  To the extent that Unicode explicitly omits some ranges ofcode point values as "unassigned", any characters that fall withinthese unassigned ranges will be always be listed by their hex valueonly in the default output, and grouped together into a single"unassigned" class when the "--chart" option is used.  But there aresome "unassigned" code points that we are not able to identify assuch.  When in doubt, use the "--hexonly" option, and check the outputagainst the code charts as published at www.unicode.org/charts/.It's also possible that unicode input might contain characters in aregion called the "Private Use Area" (UE000-UF8FF), which means thatthe correct label or interpretation of the character depends on thewhim of whoever created the data.  Another possible anomaly for utf8input is the present of "characters" in the so-called "Surrogate Area"(UD800-UDFFF), which indicates an encoding error by whoever createdthe data.  In both cases, the default output will show only the hexvalues of the observed code points in these ranges, and the "--chart"output will indicate these regions as "Private Use" or "Surrogate".=head1 OTHER NOTESThe default output listing uses the symbolic names NUL, TAB, LFD, RTN,SPC, NBSP and DEL for the null-byte, the five common whitespacecharacters and \x7F, respectively; other ASCII and Latin-1 controlcharacters are presented in "\xHH" notation.=head1 AUTHORDavid Graff ( graff (at) ldc (dot) upenn (dot) edu )=cutuse strict;use Encode;use Getopt::Long;my $Usage = "Usage: $0 [--chart] [--top=N] [--hex[only]] [--enc=ENC] [file ...]\n";my %opt;GetOptions( \%opt, 'chart', 'hex', 'hexonly', 'enc=s', 'top=i' )    or die $Usage;die $Usage if ( @ARGV == 0 and -t );my $inmode = ':utf8';if ( $opt{enc} ) {    my @enclist = Encode->encodings(":all");    listEncodings( $Usage, @enclist ) unless ( grep /$opt{enc}/, @enclist );    $inmode = ":encoding($opt{enc})";}binmode STDOUT, ':utf8';my ( %char_hist, %class_hist, %class_def, %unassigned );# load the definitions of "chart" character classes#  and unassigned ranges:my $last_end = -1;while (<DATA>) {    chomp;    my ( $bgn, $end, $name ) = split / [-:] /, $_, 3;    $bgn = chr( hex( $bgn ));    $class_def{$bgn}{limit} = chr( hex( $end ));    $class_def{$bgn}{title} = $name;    if ( $last_end+1 != ord( $bgn )) {        for my $val ( $last_end+1 .. ord($bgn)-1 ) {            $unassigned{chr($val)} = undef;        }    }    if ( $name =~ /Surrogate|Privat Use/ ) {        for my $chr ( $bgn .. $class_def{$bgn}{limit} ) {            $unassigned{$chr} = $name;        }    }    $last_end = hex( $end );}if ( @ARGV == 0 ) {    binmode STDIN, $inmode;    count_chars( \%char_hist );} else {    for my $file ( @ARGV ) {        count_chars( \%char_hist, $file, $inmode );    }}my $nonchrformat = "%04X %d\t%s\n";my $chrformat = ( $opt{hexonly} ) ? "%04X %d\n" :                ( $opt{hex} ) ? "%04X %s %d\n" : "%s %d\n";my @outorder;if ( not exists( $opt{top} )) {    @outorder = sort keys %char_hist;}elsif ( $opt{top} != 0 ) {    $opt{top} = scalar keys %char_hist if ( $opt{top} < 0 );    @outorder = ( sort {$char_hist{$b} <=> $char_hist{$a}}                        keys %char_hist )[0 .. $opt{top}-1];}my %symbols = ( " " => 'SPC',                 "\t" => 'TAB',                 "\n" => 'LFD',                 "\r" => 'RTN',                 "\x00" => 'NUL',                 "\x7F" => 'DEL',                 "\xA0" => 'NBSP',              );for my $char ( @outorder ) {    if ( exists( $unassigned{$char} )) {        my $status = $unassigned{$char} || 'unassigned';        printf( $nonchrformat, ord( $char ), $char_hist{$char}, $status );        next;    }    my @args = ();    push @args, ord( $char ) if ( $chrformat =~ /X/ );    if ( $chrformat =~ /s/ ) {        push @args, (( exists( $symbols{$char} )) ? $symbols{$char} :                      ( $char lt ' ' || $char =~ /\x80-\x9F/ ) ?                        sprintf( "\\x%02x", ord( $char )) : $char );    }    push @args, $char_hist{$char};    printf( $chrformat, @args );}if ( $opt{chart} ) {    count_classes( \%char_hist, \%class_def, \%unassigned, \%class_hist );    print "\n";    for my $class ( sort keys %class_def ) {        printf( "%04x-%04x %d\t%s\n",                ord($class), ord($class_def{$class}{limit}),                $class_hist{$class}, $class_def{$class}{title} )            if ( $class_hist{$class} );    }    printf( "xxxx-xxxx %d\t unassigned\n", $class_hist{unassigned} )        if ( $class_hist{unassigned} );}sub count_chars{    my ( $hist, $file, $mode ) = @_;    my $fh;    if ( defined $file ) {        open( $fh, "<$mode", $file ) or die "$file: $!";    } else {        $fh = \*STDIN;    }    while ( <$fh> ) {        for my $ch ( split // ) {            $$hist{$ch}++;        }    }}sub count_classes{    my ( $ch_hist, $cl_def, $non_chr, $cl_hist ) = @_;    my @start = sort keys %$cl_def;    my $bgn = shift @start;    for my $chr ( sort keys %$ch_hist ) {        if ( exists( $$non_chr{$chr} )) {            my $class = $$non_chr{$chr} || 'unassigned';            $$cl_hist{$class}++;            next;        }        while ( @start and $chr gt $$cl_def{$bgn}{limit} ) {            $bgn = shift @start;        }        if ( $chr gt $$cl_def{$bgn}{limit} ) {            $$cl_hist{unassigned} += $$ch_hist{$chr};        } else {            $$cl_hist{$bgn} += $$ch_hist{$chr};        }    }}sub listEncodings{   # user is asking for help: list all available encodings    my ( $Usage, @enclist ) = @_;    my $colwidth = length( (sort {length($b) <=> length($a)} @enclist)[0] ) + 2;    my $ncol = int( 80/$colwidth );    my $nrow = int( scalar(@enclist)/$ncol );    $nrow++ if ( scalar(@enclist) % $ncol );    my $fmt = "%-${colwidth}s";    print $Usage, "\n  Acceptable values for ENC are:\n";    foreach my $r ( 0 .. $nrow ) {        foreach my $c ( 0 .. $ncol ) {            my $i = $c * $nrow + $r;            printf( $fmt, $enclist[$i] );        }        print "\n";    }    exit( 0 );}__DATA__0000 - 007F : Basic Latin ASCII0080 - 00FF : Latin-10100 - 017F : Latin Extended A0180 - 024F : Latin Extended B0250 - 02AF : IPA Extensions02B0 - 02FF : Spacing Modifier Letters0300 - 036F : Combining Diacritical Marks0370 - 03FF : Greek0400 - 04FF : Cyrillic0500 - 052F : Cyrillic Supplement0530 - 058F : Armenian0590 - 05FF : Hebrew0600 - 06FF : Arabic0700 - 074F : Syriac0750 - 077F : Arabic Supplement0780 - 07BF : Thaana07C0 - 07FF : N'Ko0900 - 097F : Devanagari0980 - 09FF : Bengali0A00 - 0A7F : Gurmukhi0A80 - 0A8F : Gujarati0B00 - 0B7F : Oriya0B80 - 0BFF : Tamil0C00 - 0C7F : Telugu0C80 - 0CFF : Kannada0D00 - 0D7F : Malayalam0D80 - 0DFF : Sinhala0E00 - 0E7F : Thai0E80 - 0EFF : Lao0F00 - 0FFF : Tibetan1000 - 109F : Myanmar10A0 - 10FF : Georgian1100 - 11FF : Hangul Jamo1200 - 137F : Ethiopic1380 - 139F : Ethiopic Supplement13A0 - 13FF : Cherokee1400 - 167F : Canadian Syllabics1680 - 169F : Ogham16A0 - 16FF : Runic1700 - 171F : Tagalog1720 - 173F : Hanunoo1740 - 175F : Buhid1760 - 177F : Tagbanwa1780 - 17FF : Khmer1800 - 18FF : Mongolian1900 - 194F : Limbu1950 - 197F : Tai Le1980 - 19DF : New Tai Lue19E0 - 19FF : Khmer Symbols1A00 - 1AFF : Buginese1B00 - 1B7F : Balinese1D00 - 1D7F : Phonetic Extensions1D80 - 1DBF : Phonetic Extensions Supplement1DC0 - 1DFF : Combining Diacritical Marks Supplement1E00 - 1EFF : Latin Extended Additional1F00 - 1FFF : Greek Extended2000 - 206F : General Punctuation2070 - 209F : Superscripts and Subscripts20A0 - 20CF : Currency Symbols20D0 - 20FF : Combining Diacritical Marks for Symbols2100 - 214F : Letterlike Symbols2150 - 218F : Number Forms2190 - 21FF : Arrows2200 - 22FF : Mathematical Operators2300 - 23FF : Miscellaneous Technical2400 - 243F : Control Pictures2440 - 245F : Optical Character Recognition2460 - 24FF : Enclosed Alphanumerics2500 - 257F : Box Drawing2580 - 259F : Block Elements25A0 - 25FF : Geometric Shapes2600 - 26FF : Miscellaneous Symbols2700 - 27BF : Dingbats27C0 - 27EF : Miscellaneous Mathematical Symbols A27F0 - 27FF : Supplemental Arrows A2800 - 28FF : Braille Patterns2900 - 297F : Supplemental Arrows B2980 - 29FF : Miscellaneous Mathematical Symbols B2A00 - 2AFF : Supplemental Mathematical Operators2B00 - 2BFF : Miscellaneous Symbols and Arrows2C00 - 2C5F : Glagolitic2C60 - 2C7F : Latin Extended C2C80 - 2CFF : Coptic2D00 - 2D2F : Georgian Supplement2D30 - 2D7F : Tifinagh2D80 - 2DDF : Ethiopic Extended2E00 - 2E7F : Supplemental Punctuation2E80 - 2EFF : CJK Radicals Supplement2F00 - 2FDF : Kangxi Radicals2FF0 - 2FFF : Ideographic Description Characters3000 - 303F : CJK Symbols and Punctuation3040 - 309F : Hiragana30A0 - 30FF : Katakana3100 - 312F : Bopomofo3130 - 318F : Hangul Compatibility Jamo3190 - 319F : Kanbun31A0 - 31BF : Bopomofo Extended31C0 - 31EF : CJK Strokes31F0 - 31FF : Katakana Phonetic Extensions3200 - 32FF : Enclosed CJK Letters and Months3300 - 33FF : CJK Compatibility3400 - 4DBF : CJK Unified Ideographs Extension A4DC0 - 4DFF : Yijing Hexagram Symbols4E00 - 9FBF : CJK Unified IdeographsA000 - A48F : Yi SyllablesA490 - A4CF : Yi RadicalsA700 - A71F : Modifier Tone LettersA720 - A7FF : Latin Extended DA800 - A82F : Syloti NagriA840 - A87F : Phags-PaAC00 - D7AF : Hangul SyllablesD800 - D8FF : High Surrogate AreaDC00 - DFFF : Low Surrogate AreaE000 - F8FF : Private Use AreaF900 - FAFF : CJK Compatibility IdeographsFB00 - FB4F : Alphabetic Presentation FormsFB50 - FDFF : Arabic Presentation Forms AFE00 - FE0F : Variation SelectorsFE10 - FE1F : Vertical FormsFE20 - FE2F : Combining Half MarksFE30 - FE4F : CJK Compatibility FormsFE50 - FE6F : Small Form VariantsFE70 - FEFF : Arabic Presentation Forms BFF00 - FFEF : Halfwidth and Fullwidth FormsFFF0 - FFFF : Specials10000 - 1007F : Linear B Syllabary10080 - 100FF : Linear B Ideograms10100 - 1013F : Aegean Numbers10140 - 1018F : Ancient Greek Numbers10300 - 1032F : Old Italic10330 - 1034F : Gothic10380 - 1039F : Ugaritic103A0 - 103DF : Old Persian10400 - 1044F : Deseret10450 - 1047F : Shavian10480 - 104AF : Osmanya10800 - 1083F : Cypriot Syllabary10900 - 1091F : Phoenician10A00 - 10A5F : Kharoshthi12000 - 123FF : Cuneiform12400 - 1247F : Cuneiform Numbers and Punctuation1D000 - 1D0FF : Byzantine Musical Symbols1D100 - 1D1FF : Musical Symbols1D200 - 1D24F : Ancient Greek Musical1D300 - 1D35F : Tai Xuan Jing Symbols1D360 - 1D37F : Counting Rod Numerals1D400 - 1D7FF : Mathematical Alphanumeric Symbols20000 - 2A6DF : CJK Unified Ideographs Extension B2F800 - 2FA1F : CJK Compatibility Ideographs Supplement</pre>
</article>
<article>
<h1>Move/merge directories (diotalevi)</h1>
<pre class="block_code">#!/usr/bin/perluse strict;use warnings;use Getopt::Long 'GetOptions';use autouse 'Pod::Usage' => 'pod2usage';GetOptions( 'tgt=s' => \ my($tgt),            nop     => \ my($nop),            why     => \ my($why),            help => sub { pod2usage( -verbose => 1 ) },            man => sub { pod2usage( -verbose => 2 ) } )  or die pod2usage( -verbose => 0 );if ( not -d $tgt ) {    pod2usage( -verbose => 0 );}=head1 NAMEmerge-move - Moves everything under the current location elsewhere.=head1 SYNOPSIS cd /home/data/blah merge-move --tgt /home/data/somewhere-else Options:   --tgt TARGET-DIRECTORY   --nop   --why=head1 OPTIONS=over=item C<--tgt TARGET-DIRECTORY>This is the place which all the stuff in the current directory will bemerged into.=back=cutuse autouse 'Cwd' => 'cwd';use autouse 'File::Find' => 'find';use autouse 'File::Spec::Functions' => qw( canonpath catfile splitpath catdir );use autouse 'File::Path' => 'mkpath';use autouse 'File::Copy' => 'move';$SIG{CHLD} = 'IGNORE';my $pwd = cwd();my $pwd_rx = qr/\A\Q$pwd/;my ( %dirs );find( { wanted => sub {            return if not -f $_;            my $srcfile = canonpath( $File::Find::name );            my ( undef, $srcdir, $file ) = splitpath( $srcfile );            my $tgtdir = catdir( $tgt, $srcdir );            if ( ! exists $dirs{$tgtdir}                 and ! -d $tgtdir ) {                $dirs{$tgtdir} = undef;                if ( $why ) {                    print "mkdir $tgtdir\n";                }                if ( not $nop ) {                    mkpath $tgtdir, 0, 0775                      or die "Can't create $tgtdir: $!";                }            }            my $tgtfile = catfile( $tgtdir, $file );            if ( -e $tgtfile ) {                die "Couldn't move $srcfile: $tgtfile already exists.\n";            }            if ( $why ) {                print "mv $srcfile $tgtfile\n";            }            if ( not $nop ) {                move $srcfile, $tgtfile                  or die "Couldn't move $srcfile to $tgtfile: $!";            }        },        no_chdir => 1 },      '.' );</pre>
</article>
<article>
<h1>Fixup tabular text file (diotalevi)</h1>
<pre class="block_code">#!/usr/bin/perluse strict;use warnings FATAL => 'all';no warnings 'uninitialized';use Getopt::Long 'GetOptions';use English '$PROGRAM_NAME';use autouse 'Pod::Usage' => 'pod2usage';our %CHANGES;our $VERSION = ~0;=head1 NAMEfix-tabs - Fixes some common problems in tab-delimited files=head1 DESCRIPTIONThis fixes some problems I encountered with tabular text files.=over=item * Removes empty trailing rows=item * Adds missing trailing columns=item * Warns if the header is missing columns=item * Warns if the file isn't a text file=item * Warns if there is only one column.=item * Dos2unix line ending conversion=item * Fixes Excel formatted numbers:=over=item * (...) parens around negative numbers=item * Optional $ sign=item * Optional commas=back=back=head1 SYNOPSISfix-tabs [options] file1 file2 ...  Options:    --help Displays this message    --man  Displays the manual    --clip Removes things off the right edge of the table=cutGetOptions(    help => sub { pod2usage( -verbose => 1 ) },    man  => sub { pod2usage( -verbose => 2 ) },    clip => \our ($CLIP_EDGES),    )    or pod2usage( -verbose => 0 );if ( not scalar @ARGV ) {    pod2usage( -verbose => 0 );}for my $file (@ARGV) {    fix_file($file);}exit;# To regenerate the regex on the following line, run this# command. It'll be uglier than what's below but that's because I made# the one below prettier. It's still equivalent and is the source for# the below.## perl -MRegexp::Common -le 'print qr/(?:$RE{num}{real}|$RE{num}{int}|$RE{num}{real}{-sep=>','}{-group=>3}|$RE{num}{int}{-sep=>','}{-group=>3})/'my $NUMBER;BEGIN {    $NUMBER        = qr/(?-xism:(?:(?:(?i)(?:[+-]?)(?:(?=[0123456789]|[.])(?:[0123456789]*)(?:(?:[.])(?:[0123456789]{0,}))?)(?:(?:[E])(?:(?:[+-]?)(?:[0123456789]+))|))|(?:(?:[+-]?)(?:[0123456789]+))|(?:(?i)(?:[+-]?)(?:(?=[0123456789]|[.])(?:[0123456789]{1,3}(?:(?:[,])[0123456789]{3})*)(?:(?:[.])(?:[0123456789]{0,}))?)(?:(?:[E])(?:(?:[+-]?)(?:[0123456789]+))|))|(?:(?:[+-]?)(?:[0123456789]{1,3}(?:,[0123456789]{3})*))))/;}my $EXCEL_NUMBER;BEGIN {    $EXCEL_NUMBER = qr/(?xsm)(?:    \( \$? $NUMBER \)  |    \$? $NUMBER)/;}sub fix_file {    my ($file) = @_;    -T $file or die "$file isn't a text file.\n";    # Read the header line and get the # of columns I expect every    # other line to have.    open my $fh, '<', $file or die "Can't open $file: $!";    my $header_line = <$fh>;    $header_line =~ m/\t/mx        or die "$file isn't a tab delimited text file.\n";    my %field_names;    {        my @labels = split /\t/, $header_line;        chomp $labels[-1];        for my $index ( 0 .. $#labels ) {            my $column_name = $labels[$index];            if ( $column_name =~ s/\A\s+// ) {                ++$CHANGES{header_whitespace};            }            if ( $column_name =~ s/\s+\z// ) {                ++$CHANGES{header_whitespace};            }            $field_names{$column_name} = $index;        }    }    my $expected_columns = scalar keys %field_names;    # The input file will be copied here. This shouldn't be left    # around after the program is finished.    my $tmpfile = "$file.tmp";    open my $out, '>', $tmpfile        or die "Couldn't open $tmpfile for writing: $!";    # If there are Windows line endings, that's automatically a fix.    if ( $header_line =~ tr/\r//d ) {        ++$CHANGES{windows_cr};    }    # Copy out the header line using the cleaned up headigns.    print {$out} join( "\t",        sort { $field_names{$a} <=> $field_names{$b} }            keys %field_names )        . "\n"        or die "Couldn't write to $tmpfile: $!";    while ( my $line = <$fh> ) {        # Again, fixing Windows line endings.        if ( $line =~ tr/\r//d ) {            ++$CHANGES{windows_cr};        }        if ( not $line =~ m/\S/msx ) {            # Just skip empty lines and cause the file to be            # rewritten.            ++$CHANGES{blank};            next;        }        my @values = split /\t/, $line;        chomp $values[-1];        # Column # fixes. Either too many or too little.        if ( scalar(@values) < $expected_columns ) {            ++$CHANGES{col_count};            push @values, ('') x ( $expected_columns - scalar @values );        }        elsif ( scalar(@values) > $expected_columns ) {            ++$CHANGES{col_count};            if ( not $CLIP_EDGES ) {                while ( $values[-1] eq ''                    and scalar(@values) > $expected_columns )                {                    pop @values;                }            }            else {                splice @values, $expected_columns;            }            if ( scalar(@values) > $expected_columns ) {                warn                    "Too many columns in row $.. Expected $expected_columns, got @{[ scalar @values ]}.\n";            }        }        print {$out} join( "\t", @values ) . "\n"            or die "Couldn't write to $tmpfile: $!";    }    close $out        or die "Couldn't flush $tmpfile: $!";    if ( not keys %CHANGES ) {        print "$file ok.\n";        unlink $tmpfile            or die "Couldn't remove unused $tmpfile: $!";    }    else {        print "$file fixed.\n";        # Report on several named things getting fixed. This just puts        # nice names on the stuff.        for my $change (            [ windows_cr => 'Windows line endings' ],            [ col_count  => 'Column count' ],            [ blank      => 'Blank lines' ],            [ fix_num    => 'Number formatting' ]            )        {            my ( $field, $desc ) = @$change;            my $fix = delete $CHANGES{$field};            if ( not defined $fix ) {                next;            }            print "$desc: $fix\n";        }        for ( sort grep { $CHANGES{$_} } keys %CHANGES ) {            print "$_: $CHANGES{$_}\n";        }        my $backupfile = "$file.old";        # Add a number to the .old to find a file name that isn't used        # yet.        while ( -e $backupfile ) {            my ($id) = $backupfile =~ m/\.(\d+)$/msx;            no warnings 'numeric';            $id += 0;            $backupfile =~ s/\d+$//msx;            $backupfile .= ".$id";        }        rename $file, $backupfile            or die "Couldn't rename $file to backupfile";        rename $tmpfile, $file            or die "Couldn't rename $tmpfile to $file";    }    return 1;}sub fix_excel_number {    my $newnum = $_;    my $oldnum = $_;    $newnum =~ s/\A\s*($EXCEL_NUMBER)\s*\z/normalize_excel_number($1)/e;    if ( $newnum ne $oldnum ) {        $_ = $newnum;        warn "Fix number $oldnum -> $newnum\n";        ++$CHANGES{fix_num};        return 1;    }    else {        return 0;    }}sub normalize_excel_number {    my $num = shift @_;    $num =~ tr/$,//d;    $num =~ s/\A\((.+)\)\z/-$1/;    return $num;}</pre>
</article>
<article>
<h1>diotalevi's grep (diotalevi)</h1>
<pre class="block_code">#!/usr/bin/perl## no critic VersionVaruse strict;use warnings;use Getopt::Long 'GetOptions';use autouse 'File::Find'      => 'find';use autouse 'Pod::Usage'      => 'pod2usage';use autouse 'Term::ANSIColor' => 'colored';use autouse 'IPC::Open3' => 'open3';$SIG{CHLD} = 'IGNORE';use vars qw( $TextOnly );main();exit;sub main {    # Fetch parameters.    GetOptions(        man  => sub { pod2usage( -verbose => 2 ) },        help => sub { pod2usage( -verbose => 1 ) },        t        => \$TextOnly,        l        => \my ($filename_only),        w        => \my ($word),        i        => \my ($ignore_case),        Q        => \my ($quotemeta),        h        => \my ($no_filename),        n        => \my ($line_no),        R        => \my ($no_recursive),        v        => \my ($invert_match),        plain    => \my ($no_ansicolor),        'name=s' => \my ($filename_rx),        )        or pod2usage( -verbose => 0 );    my ( $match, @srcs ) = @ARGV;    if ( not @srcs ) {        @srcs = '.';    ## no critic Noisy    }    # Validate parameters.    if ( not defined $match ) {        pod2usage( -verbose => 0 );    }    # Pre-process the pattern and then compile it.    if ($quotemeta) {        $match = quotemeta $match;    }    if ($word) {        $match = "\\b$match\\b";    }    if ($ignore_case) {        $match = "(?i)$match";    }    my $match_rx = qr/$match/;    # Get a function which formats the output for whatever was    # requested. All info is passed through the globals    # $File::Find::rel_name, $., and $_. The input will contain    # whatever linebreak is currently active so most things don't need    # to add one.    my $prev_file = '';    my $formatter = (        $line_no && $no_filename        ? sub { "$.:" . shift }        : $line_no ? sub {            if ( $File::Find::name ne $prev_file ) {                $prev_file = $File::Find::name;                return ( ( $prev_file eq '' ? '' : "\n" )                    . colored( $File::Find::name, 'bold green' ) . "\n$.:"                        . shift );            }            else {                return "$.:" . shift;            }            }        : $no_filename   ? sub {shift}        : $filename_only ? sub {            if ( $File::Find::name ne $prev_file ) {                $prev_file = $File::Find::name;                return ( ( $prev_file eq '' ? '' : "\n" )                    . colored( $File::Find::name, 'bold green' )                        . "\n" );            }            else {                return;            }            }        : sub {            if ( $File::Find::name ne $prev_file ) {                $prev_file = $File::Find::name;                return ( ( $prev_file eq '' ? '' : "\n" )                    . colored( $File::Find::name, 'bold green' ) . "\n"                        . shift );            }            else {                return shift;            }        }    );    my $grep_file_fn = sub {        grep_file(            ignore_rcs   => 1,            plain        => $no_ansicolor,            match_rx     => $match_rx,            filename_rx  => $filename_rx,            formatter    => $formatter,            invert_match => $invert_match,            match_once   => $filename_only        );    };    # Here's the main loop. For each source directory/file, search it.    for my $src (@srcs) {        # Examine all files in $src.        if ($no_recursive) {            # Mimic the API of File::Find for grep_file().            # local $File::Find::dir = unimplemented            ## no critic            local $File::Find::name = $src;            local $_                = $src;            $grep_file_fn->();        }        else {            find( $grep_file_fn, $src );        }    }    return 0;}sub open_file_harder {    my ($filename) = @_;    return if not defined $filename;    if ( my ($extension) = $filename =~ /(\.[^.]+)\z/mx ) {        my @readers = (            [ qr/\.t(?:ar\.)?gz\z/ => qw( gzcat ),    $filename ],            [ qr/\.zip\z/,         => qw( unzip -p ), $filename ],            [ qr/\.Z\z/            => qw( zcat ),     $filename ],            [ qr/\.gz\z/           => qw( gzcat ),    $filename ],            [ qr/\.bz2\z/          => qw( bzcat ),    $filename ],        );        for my $reader (@readers) {            my ( $pattern, @command ) = @{$reader};            if ( $extension =~ $pattern ) {                open3( undef, my $fh, undef, @command );                return $fh;            }        }    }    open my $fh, '<', $filename        or die "Couldn't open $filename: $!";    return $fh;}sub grep_file {    my %p            = @_;    my $match_rx     = $p{match_rx};    my $formatter    = $p{formatter};    my $invert_match = $p{invert_match};    my $plain        = $p{plain};    my $match_once   = $p{match_once};    my $filename = $_;    # Ignore CVS stuff.    return if $File::Find::name =~ m{/CVS/?};    # If there is a pattern required of filenames, try that one    # first. This requires no checks to the FS so I'm doing this    # before the next stuff.    return        if defined $p{filename_rx}        and not $filename =~ $p{filename_rx};    # Ignore non-existant files.    return if not -f $filename;    # Ignore non-text files if that's what was requested.    return if $TextOnly and not -T _;    eval {        my $fh = open_file_harder($filename);    LINE: while ( my $line = <$fh> ) {            # If the line matches the pattern print it as a formatted            # line.            my $matched;            if ($plain) {                $matched = ( $line =~ /$match_rx/mx );            }            else {                $matched = ( $line =~ /$match_rx/mx );                $line                    =~ s/((?:$match_rx)+)/ colored( "$1", 'yellow on_black' ) /gemx;            }            # Given    Match     then exclusive or is great here.            #            0   1            #          +---+---+            # Invert 0 |   | X |            #        1 | X |   |            if ( $matched xor $invert_match ) {                print $formatter->($line);                last LINE if $match_once;            }        }    };    return 1;}__END__=head1 NAMEdgrep - A recursive grep that uses perl regular expressions.=head1 SYNOPSISdgrep [options] [file ...] Options:   -help      Prints this help message   -man       Prints the manual   -t         Searches only `text' files   -w         Matches only "words" using \b...\b   -i         Case-insensitive matching   -Q         Ignore perl meta-characters   -v         Invert output, match lines that don't match the pattern   -h         Exclude filename from output   -n         Include line number in output   -R         Disable recursion, no directories.   -plain     Disable highliting of matched text   -name EXPR Only open files matching this regular expression=head1 OPTIONS=over 4=item B<-help>Prints a simple message on usage and then exits.=item B<-man>Prints the manual and then exits.=item B<-t>Only `text' files are searched.=item B<-w>When matching, the pattern is surrounded by perl\'s \b assertion. Thatis, the match must be on a "word" boundary, either starting orfinishing. To perl, "word" is locale specific but generally means anyalphanumeric character and underscore.=item B<-i>Match without regard to casing. This is affected by locale.=item B<-Q>Pattern is a literal string. All regex metacharacters will be escapedusing the quotemeta() function.=item B<-v>Print only lines which do B<not> match the pattern. This is equivalentto grep\'s -v parameter.=item B<-h>Omit the filename from the output when a line is matched. This issemi-equivalent to grep\'s -h parameter.=item B<-n>Print the line number.=item B<-R>Do not recurse into any subdirectories.=item B<-plain>C<dgrep> automatically inserts ANSI escape codes to highlight matchedtext. Use the C<-plain> option to disable that.=item B<-name> EXPRC<dgrep> usually searches every file and directory, recursively. WhenC<-name EXPR> is used, only filenames matching this regular expressionare searched.=back=head1 DESCRIPTIONB<dgrep> is an "improved" version of the grep that comes with the Sunbox. It is normally recursive, accepts perl regular expressions, andoptionally prints the filename the match was found in.=cut</pre>
</article>
<article>
<h1>cutf - cut by field name (diotalevi)</h1>
<pre class="block_code">#!/usr/bin/perluse strict;use warnings;use Getopt::Long;use autouse 'Pod::Usage' => 'pod2usage';GetOptions(    'd|delimiter=s' => \( my ($delim)     = "\t" ),    'f|fields=s'    => \( my ($spec_list) = q{} ),    'v'             => \my ($reverse),    help => sub { pod2usage( -verbose => 1 ) },    man  => sub { pod2usage( -verbose => 2 ) },    )    or pod2usage( -verbose => 0 );my $delim_rx = qr/\Q$delim/xm;my $header = <>;my @field_names = map {uc} split /$delim_rx/xm, $header;chomp @field_names;my @selected_fields;SPEC: for my $spec (    map { $_ =~ /\S/xm ? uc $_ : () }    split /,/xm, $spec_list    ){    ## no critic ProhibitCascadingIfElse    if ( $spec =~ /\A(\d+)\z/xm and ( 1 <= $1 and $1 <= @field_names ) ) {        push @selected_fields, $1 - 1;        next SPEC;    }    elsif ( $spec =~ /\A(\d+)-(\d+)\z/xm        and ( 1 <= $1 and $1 <= @field_names )        and ( 1 <= $2 and $2 <= @field_names )        and $1 <= $2 )    {        push @selected_fields, $1 - 1 .. $2 - 1;        next SPEC;    }    elsif ( $spec =~ /\A-(\d+)\z/xm        and ( 1 <= $1 and $1 <= @field_names ) )    {        push @selected_fields, 0 .. $1 - 1;        next SPEC;    }    elsif ( $spec =~ /\A(\d+)-\z/xm        and ( 1 <= $1 and $1 <= @field_names ) )    {        push @selected_fields, $1 - 1 .. $#selected_fields;        next SPEC;    }    else {        for my $ix ( 0 .. $#field_names ) {            # Push *all* columns with the name $            my $found_it;            if ( uc $spec eq $field_names[$ix] ) {                push @selected_fields, $ix;                $found_it = 1;            }            next SPEC if $found_it;        }    }    die qq<Invalid spec "$spec".\n>;}if ($reverse) {    my %selected;    for my $col_idx ( 0 .. $#field_names ) {        $selected{$_} = 1;    }    for my $col_idx (@selected_fields) {        $selected{$_} = 0;    }    @selected_fields        = grep { $selected{$_} } sort { $a <=> $b } keys %selected;}print join( $delim, @field_names[@selected_fields] ) . "\n";while ( my $line = <> ) {    my @line = split /$delim_rx/xm, $line;    chomp @line;    ## no critic NoWarnings    no warnings 'uninitialized';    print join( $delim, @line[@selected_fields] ) . "\n";}__END__=head1 NAMEcutf - remove sections from each line of files=head1 SYNOPSIS  cutf [OPTION]... [FILE]...  cutf --man for more options=head1 DESCRIPTIONPrint selected parts of lines from each FILE to standard output.=head1 OPTIONSMandatory arguments to long options are mandatory for short optionstoo.=over=item -b, --bytes=LISTTODO: output only these bytes=item --output-delimiter=STRINGTODO: use C<STRING> as the output delimiter the default is to use the input delimiter=item --helpdisplay this help and exit=item --versionTODO: output version information and exit=backUse one, and only one of -b, -c or -f. Each LIST is made up of onerange, or many ranges separated by commas. Each range is one of:  N      Nth byte, character or field, counted from 1    N-     from Nth byte, character or field, to end of line    N-M    from Nth to Mth (included) byte, character or field    -M     from first to Mth (included) byte, character or field=over=item -c, --characters=LISTTODO: output only these characters=item -d, --delimiter=DELIMuse DELIM instead of TAB for field delimiter=item -f, --fields=LISToutput only these fields; also print any line that contains nodelimiter character, unless the -s option is specified=item -nTODO: with -b: don't split multibyte characters=item -s, --only-delimitedTODO: do not print lines not containing delimiters=backWith no FILE, or when FILE is -, read standard input.=head1 DIAGNOSTICS=over=item Invalid spec "%s".Your spec wasn't one of the recognized forms: COLUMN FROM-TO -TO FROM-=back=cut</pre>
</article>
<article>
<h1>cksum contents of a tarball (diotalevi)</h1>
<pre class="block_code">#!/usr/bin/perluse strict;use warnings;use Getopt::Long 'GetOptions';use Carp 'croak';use Pod::Usage 'pod2usage';GetOptions(    tgz  => \my ($tgz),    )    or die "Usage: $0 --tgz TARBALL";open my $tgz_fh, '-|', 'tar', 'xvzf', $tgz    or croak "Can't tar xvzf $tgz: $!";# tar will print a file before it is done so I have this reader to# wait for the next file to get mentioned.my $file_reader = do {    my @files;    sub {        # Add to @files if necessary and possible.        while ( @files < 2 and $tgz_fh ) {            chomp( my $file = <$tgz_fh> );            if ( not defined $file ) {                close $tgz_fh;                undef $tgz_fh;            }            else {                push @files, $file;            }        }        if (@files) {            return shift @files;        }        else {            return;        }    };};# For each file, cksum it.# For each directory, plan to remove it in LIFO order.my @directories;while ( my $file = $file_reader->() ) {    if ( -f $file ) {        0 == system 'cksum', $file            or croak "Can't exec cksum $file: $?";        unlink $file            or croak "Can't unlink $file: $!";    }    elsif ( -d _ ) {        unshift @directories, $file;    }}# Remove my directories in LIFO order.while (@directories) {    my $size_before = @directories;    @directories = grep { not rmdir } @directories;    last if @directories == $size_before;}</pre>
</article>
<article>
<h1>socksumm -- Display a summary of open sockets (grinder)</h1>
<pre class="block_code">#! /usr/bin/perl -w## socksumm -- socket usage summary## Copyright (C) 2005-2006 David Landgrenuse strict;use Getopt::Long;my $VERSION = '1.0';my $ok = GetOptions(    'help',         \my $help,    'localport=s',  \my $watch_local_port,    'remoteport=s', \my $watch_remote_port,    'port=s',       \my $watch_port,    'sleep=i',      \my $sleep,    'version',      \my $version,    'num=i',        \my $num,);if( not $ok or $help ) {    eval "use Pod::Usage";    if( $@ ) {        print <<HELP;$0 [-localport=?] [-remoteport=?] [-port=?] [-sleep=n] [-num=n](install Pod::Usage for detailed help)HELP    }    else {        pod2usage(1);    }    exit;}$sleep ||= 60;if( $version ) {    eval "use File::Basename";    print +($@ ? $0 : basename($0)), " v$VERSION\n";    exit 0;}my $netstat_re;my $args;# platform-specific settings;{    my $ip_re = '\d+(?:\.\d+){3}';    if( $^O eq 'freebsd' ) {        $args = '-nf inet';        $netstat_re = qr/^\S+(?:\s+\d+){2}\s+($ip_re)[:.](\d+)\s+($ip_re)[:.](\d+)\s+(\S+)\s*$/;    }    elsif( $^O eq 'linux' ) {        $args = '-n --inet';        $netstat_re = qr/^\S+(?:\s+\d+){2}\s+($ip_re)[:.](\d+)\s+($ip_re)[:.](\d+)\s+(\S+)\s*$/;    }    elsif( $^O eq 'solaris' ) {        $args = '-nf inet';        $netstat_re = qr/^($ip_re)\.(\d+)\s+($ip_re)\.(\d+)(?:\s+\d+){4}\s+(\S+)\s*$/;    }    else {        die "Don't know how to decode netstat on $^O\n" unless defined $args;    }}# resolve service names if we candefined $_ and /\D/ and $_ = getservbyname($_,'tcp') || $_    for ($watch_local_port, $watch_remote_port, $watch_port);my %state;my @col = qw(    ESTABLISHED CLOSE_WAIT TIME_WAIT FIN_WAIT_1 FIN_WAIT_2 SYN_SENT SYN_RECV LAST_ACK);print "estab close twait finw1 finw2 syntx synrx lastk total\n";while( 1 ) {    my $total    = 0;    @state{@col} = (0) x @col;    open my $in, "netstat $args |"        or die "Cannot open pipe from netstat: $!\n";    while( <$in> ) {        chomp;        next unless my($local_host, $local_port, $remote_host, $remote_port, $state)            = /$netstat_re/;        next if $watch_port            and $local_port  != $watch_port            and $remote_port != $watch_port        ;        next if $watch_local_port  and $local_port  != $watch_local_port;        next if $watch_remote_port and $remote_port != $watch_remote_port;        $state =~ s/^(FIN_WAIT)(\d+)$/$1_$2/; # munge Linux variant        ++$state{$state};        ++$total;    }    close $in;    # display one line of data    my $timestamp = sprintf( '%02d:%02d:%02d', (localtime)[2,1,0] );    printf "%5d %5d %5d %5d %5d %5d %5d %5d %5d %s",        @state{@col}, $total, $timestamp;    delete @state{@col};    # deal with unknown or don't-care socket states    if( %state ) {        print ' ', join( ' ', map {"$_=$state{$_}"} sort keys %state );        %state = ();    }    print "\n";    last if defined $num and --$num <= 0;    sleep $sleep;}exit 0;__END__=head1 NAMEsocksumm - Display a summary of open sockets=head1 SYNOPSISB<socksumm> [B<-l>,B<-localport>] [B<-r>,B<-remoteport>] [B<-p>,B<-port>] [B<-s>,B<-sleep>] [B<-n>,B<-num>] [B<-version>]=head1 DESCRIPTIONParse the output of the C<netstat(1)> command and produce a summaryof the socket connections on a port.=head1 OPTIONS=over 5=item B<-l>,B<-localport>Summarise socket connections on this local port. Numeric or symbolic names(for example 389 or C<ldap>) are recognised. In otherwords, use this tomonitor inbound connections.=item B<-r>,B<-remoteport>Summarise socket connections on this remote port. Numeric or symbolic namesare recognised. Use this to monitor outbound connections.=item B<-p>,B<-port>Summarise socket connections on this port. Numeric or symbolic namesare recognised. Use this to monitor eitherbound connections.=item B<-s>,B<-sleep>Time to sleep between invocations of C<netstat>. A sixty (60) second sleeptime is assumed if this switch is omitted.=item B<-n>,B<-number>Produce this many summaries of C<netstat> and then exit.=back=head1 EXAMPLESC<socksumm -l=ldap -s=10>Summarise the inbound connections to the LDAP listener port. Will produceoutput that looks similar to the following: estab close twait finw1 finw2 syntx synrx lastk total   519     0     4     0     0     0     0     0   523 12:42:50   524     0     2     0     0     0     0     1   527 12:43:00   516     0     3     0     0     0     0     0   519 12:43:11C<socksumm -r=22 -s=3600>See how many outbound C<ssh> connections are open every hour.=head1 BUGSAssumes that C<netstat> can be found on the PATH. If you are runningC<netstat> on a platform other than FreeBSD, Linux or Solaris thescript will die. Please mail me the output and I'll endeavour toincorporate it (or, better yet, send me patches).=head1 COPYRIGHTCopyright 2005-2006 David Landgren.This script is free software; you can redistribute it and/or modify itunder the same terms as Perl itself.=head1 AUTHORDavid Landgrenjoin chr(0x40) => reverse qw[landgren.net david]=cut</pre>
</article>
<article>
<h1>Reaped: Email using sendmail (NodeReaper)</h1>
This node was taken out by the <a href="/out/node/NodeReaper">NodeReaper</a> on <a href="/out/localtime/2006-09-12 04-40-50">2006-09-12 04-40-50</a><BR>Reason:  [<a href="/out/node/marto">marto</a>]: Reap, this is a dupe of <a href="/html/572472.html">Email using sendmail</a><p>You may view <a href="/out/href/?node=Visit%20Reaped%20Nodes&nodenum=572473">the original node and the consideration vote tally</a>.</p>
</article>
<article>
<h1>Email using sendmail (alandev)</h1>
<pre class="block_code">#!/usr/bin/perluse Mail::Mailer;$mailer=Mail::Mailer->new("sendmail");print "\nRecipient Address:";$too=<>;chomp($too);@to=split(";",$too);print "\nSubject:";$mail_subject=<>;chomp($mail_subject);print "\nContent:";$mail_content=<STDIN>;$mailer->open( { From    => $from,To      => \@to,Subject => $mail_subject});print $mailer $mail_content;close($mailer); </pre>
</article>
<article>
<h1>Reaped: Oral sex (NodeReaper)</h1>
This node was taken out by the <a href="/out/node/NodeReaper">NodeReaper</a> on <a href="/out/localtime/2006-09-05 20-28-25">2006-09-05 20-28-25</a><BR>Reason:  [<a href="/out/node/liverpole">liverpole</a>]: Total garbage.<p>You may view <a href="/out/href/?node=Visit%20Reaped%20Nodes&nodenum=571357">the original node and the consideration vote tally</a>.</p>
</article>
<article>
<h1>uhead: "head -c" for utf8 data (graff)</h1>
<pre class="block_code">#!/usr/bin/perl=head1 NAMEuhead -- unicode-aware version of unix "head"=head1 SYNOPSISuhead -c N [file ...]   show first N unicode chars from file(s)=head1 DESCRIPTIONThis does what the standard "head -c N" command (GNU version) would do(i.e. show the first N characters from one or more files), with justthe following differences:=over 4=item *The "-c N" option is required (not optional)=item *N refers to a number of UTF-8 encoded unicode characters rather thanbytes=item *"Negative" values for N are not supported (you cannot elect to viewall but the last N characters)=backIf no files are provided on the command line, it will read from STDINinstead. (But if it notices that STDIN is actually the user's tty, nota pipe or redirection from a file, it will exit with a suitable errormessage.)=head1 AUTHORDavid Graff <graff(at)ldc.upenn.edu>=cutuse strict;my $Usage = "Usage: $0 -c N [file ...]\n";die $Usage unless ( @ARGV > 1 and $ARGV[0] eq '-c' and                    $ARGV[1] =~ /^\d+$/ );shift;my $show_chrs = shift;if ( -t ) {    @ARGV or die "You need to provide some data (pipe or file(s))\n$Usage";}else {    @ARGV = ( '__STDIN__' );}binmode STDOUT, ":utf8";my $nfiles = @ARGV;while ( @ARGV ) {    my $file = shift;    my $head;    if ( $file eq '__STDIN__' ) {        binmode STDIN, ":utf8";        read STDIN, $head, $show_chrs;    }    else {        if ( open( I, "<:utf8", $file )) {            read I, $head, $show_chrs;        }        else {            warn "open failed on $file\n";            next;        }    }    print "\n==> $file <==\n" if ( $nfiles > 1 );    print $head,"\n";}</pre>
</article>
<article>
<h1>Yet Another Sudoku Solver (SubStack)</h1>
<pre class="block_code">#!/usr/bin/perl# solve.pl - Solves all sudoku puzzles, even really hard ones# Just feed it a file with each row on a line and spaces for the blanks.use strict;use warnings;use Storable qw(dclone);my $DEBUG = 0;die "usage: $0 file\n" unless @ARGV;open my $fh, "<", $ARGV[0] or die "failed to open '$ARGV[0]': $!\n";# Store all potential squares (by which I mean the board-type thing).# This grows as new potentials solutions manifest and shrinks as they fail.my @squares = [ map [ m/([\d ])/g ], <$fh> ];# Number of potential solutions that will be acceptable for the given search.# This is automatically adjusted based on the availability of good solutions.my $threshold = 1;close $fh;# Iternate through each spot and see how many choices for numbers there are.# If the number of choices meets the threshold, fill the coordinate in, on# multiple instances of the square if needed.scan: while  (grep $_ eq " ", map @$_, @{$squares[0]}) {  # keep track of y coordinate on the square  my $y = -1;  for my $row (@{$squares[0]}) {    $y++;    # keep track of x coordinate on the square    my $x = -1;    for my $number (@$row) {      $x++;      next unless $number eq " "; # only bother solving blank squares      # Load all the numbers in the coordinate's 3x3 magic square.      # They aren't really magic squares of course, but it makes them easier to      # refer to.      my @magic = grep $_ ne " ",        map @{$_}[int($x / 3) * 3 .. int($x / 3) * 3 + 2 ],          @{$squares[0]}[int($y / 3) * 3 .. int($y / 3) * 3 + 2];      # Load all the numbers in the coordinate's row.      my @row_nums = grep $_ ne " ", @$row;      # Load all the numbers in the coordinate's column.      my @col_nums = grep $_ ne " ", grep defined, map $_->[$x], @{$squares[0]};      # Count up the occurances of the numbers the coordinate can't be.      my %count = map { $_ => 0 } 1 .. 9;      $count{$_}++ for @magic, @row_nums, @col_nums;      # All the possible values for the coordinate      my @possible = grep $count{$_} == 0, keys %count;      print "($x, $y): ",        "  possible = @{[ sort @possible ]}\n",        "  magic    = @{[ sort @magic ]}\n",        "  cols     = @{[ sort @col_nums ]}\n",        "  rows     = @{[ sort @row_nums ]}\n"      if $DEBUG;      if (@possible == $threshold) {        # Number of possibilities meets the threshold        print "Solved coordinate ($x, $y) == (@possible)\n" if $DEBUG;        # Throw the first possibility onto the current square.        $squares[0][$y][$x] = shift @possible;        for (@possible) {          # Throw the other possibilities into copies of the current square.          push @squares, dclone($squares[0]);          $squares[$#squares][$y][$x] = $_;        }        # Set the threshold back to 1 for a successful match.        $threshold = 1;        next scan;      }      # Scrap squares that don't have any possible choices for a particular      # coordinate.      if (@possible == 0) {        print "Scrapping guess due to ($x, $y)\n" if $DEBUG;        shift @squares;        die "No more guesses! Unsolvable!\n" unless @squares;        $threshold = 1;        next scan;      }    }  }  # The possibilities weren't good enough. Be less picky next iteration.  $threshold++;}show(0);sub show { # useful for debugging the squares while running  print join("", @$_), "\n" for @{$squares[$_[0]]};}</pre>Spaces are used for blanks. Here's an example to try out:<pre class="block_code">    9  4  7  6    89    21      36 8  42 67  9 68      61    54    8  7  4  1    </pre>
</article>
<article>
<h1>spamstats.pl (tcf03)</h1>
<pre class="block_code">#!/usr/bin/perl -wuse strict;#use diagnostics;#use Data::Dumper;my %action = ( 'RECV' => { 0   => 'Allowed Message',                           1   => 'Aborted Message',                           2   => 'Blocked Message',                           3   => 'Quarantined Message',                           4   => 'Tagged Message',                           5   => 'Deferred Message',                           6   => 'Per-User Quarantined Message',                           7   => 'Whitelisted Message',                           '-' => 'Undefined' },               'SEND' => { 1   => 'Delivered Message',                           2   => 'Rejected Message',                           3   => 'Deferred Message',                           4   => 'Expired Message',                           '-' => 'Undefined' } );$action{'SCAN'} = $action{'RECV'};my %reason = ( 0    => 'Undefined',               1    => 'Virus',               2    => 'Banned Attachment',               3    => 'RBL Match',               4    => 'Rate Control',               5    => 'Too Many Message In Session',               6    => 'Timeout Exceeded',               7    => 'No Such Domain',               8    => 'No Such User',               9    => 'Subject Filter Match',               10   => '',               11   => 'Client IP',               12   => 'Recipient Address Rejected',               13   => 'No Valid Recipients',               14   => 'Domain Not Found',               15   => 'Sender Address Rejected',               16   => '',               17   => 'Need Fully Qualified Recipient',               18   => 'Need Fully Qualified Sender',               19   => 'Unsupported Command',               20   => 'MAIL FROM Syntax Error',               21   => 'Bad Address Syntax',               22   => 'RCPT TO Syntax Error',               23   => 'Send EHLO/HELO first',               24   => 'Need MAIL Command',               25   => 'Nested Mail Command',               26   => '',               27   => 'EHLO/HELO Syntax Error',               28   => '',               29   => '',               30   => 'Mail Protocol Error',               31   => 'Score',               32   => '',               33   => '',               34   => 'Header Filter Match',               35   => 'Sender Block/Accept',               36   => 'Recipient Block/Accept',               37   => 'Body Filter Match',               38   => 'Message Size Bypass',               39   => 'Intention Analysis Match',               40   => 'SPF/Caller-ID',               41   => 'Client Host Rejected',               42   => '',               43   => '',               44   => 'Authentication Not Enabled',               45   => 'Allowed Message Size Exceeded',               46   => 'Too Many Recipients',               47   => 'Need RCPT Command',               48   => 'DATA Syntax Error',               49   => 'Internal Error',               50   => 'Too Many Hops',               51   => '',               52   => '',               53   => '',               54   => '',               55   => 'Invalid Parameter Syntax',               56   => 'STARTTLS Syntax Error',               57   => 'TLS Already Active',               58   => 'Too Many Errors',               59   => 'Need STARTTLS First',               60   => 'Spam Fingetpront Found',               '-'  => 'Undefined' );## Check Usage ##die "usage: spamstat.pl <logfile>\n"    unless ( defined ($ARGV[0]) and -f $ARGV[0]);my $file;open $file, $ARGV[0] or    die "Unable to open $ARGV[0]: $!\n";# Define our buckets for collecting datamy %bucket  = ();my %USER    = ();my %VIRUS   = ();my %SPAM    = ();# These numbers must be valid reason codes...my @wanted = ( 1, 60 );# We rely on autovivification for counting # it almost seems like cheating...for (<$file>){    chomp;        my ( $month, $day, $time, $host,         $process, $clientIP, $MessageID,         $timeStart, $timeEnd, $service, @INFO ) = split /\s+/;    # anything after this point can/should be changed depending on your needs.    my ( $sender, $recip, $action_, $reason_, @reasonextra,         $encrypted, $score, $queueid, @response );       if ( $service =~ /^RECV/ )    {        ( $sender, $recip, $action_, $reason_, @reasonextra ) = (@INFO);        print "Action = $action_ Service = $service\n" unless            $action{$service}{$action_};        print "Reason = $reason_  Service = $service\n" unless            $reason{$reason_};        $VIRUS{$host}{$reasonextra[0]}{'count'}++ if ( $reason_ == 1 );        $SPAM{$host}{$recip}{'count'}++ if ( $action_  == 2 and                                             $reason_  == 60 );        $USER{$host}{$recip}{$action{$service}{$action_}}{$reason{$reason_}}{'count'}++;            #if ( grep /^$reason_$/, @wanted );        $bucket{$host}{$service}{$action{$service}{$action_}}{$reason{$reason_}}{'count'}++    }    if ( $service =~ /^SCAN/ )    {        ( $encrypted, $sender, $recip, $score, $action_, $reason_, @reasonextra ) = (@INFO);        print "Action = $action_ Service = $service\n" unless            $action{$service}{$action_};        print "Reason = $reason_  Service = $service\n" unless            $reason{$reason_};                $VIRUS{$host}{$reasonextra[0]}{'count'}++ if ( $reason_ == 1 );        $SPAM{$host}{$recip}{'count'}++ if ( $action_  == 2 and                                             $reason_  == 60 );        $USER{$host}{$recip}{$action{$service}{$action_}}{$reason{$reason_}}{'count'}++;            #if ( grep /^$reason_$/, @wanted );        $bucket{$host}{$service}{$action{$service}{$action_}}{$reason{$reason_}}{'count'}++;    }    if ( $service =~ /^SEND/ )    {        ( $encrypted, $action_, $queueid, @response ) = (@INFO);        $bucket{$host}{$service}{$action{$service}{$action_}}{'count'}++;    }}# Example reports...#for my $host ( keys %VIRUS )#{#    print "[$host]\n";#    for my $virus ( sort keys %{$VIRUS{$host}} )#    {#        printf "\t%-50s %3d\n", $virus, $VIRUS{$host}{$virus}{'count'};#    }                #}#for my $host ( keys %USER )#{#    print "[$host]\n";#    for my $user ( keys %{$USER{$host}} )#    {#        print " $user\n";#        for my $action ( keys %{$USER{$host}{$user}} )#        {#            print "\t  $action\n";#            for my $reason ( keys %{$USER{$host}{$user}{$action}} )#            {#                print "\t\t$reason", #                " $USER{$host}{$action}{$reason}{'count'}\n";#            }#        }#    }#}#for my $host ( keys %SPAM )#{#    for my $user ( keys %{ $SPAM{$host} } )#    {#        print "$user [$SPAM{$host}{$user}{'count'}]\n";#    }#}</pre>
</article>
<article>
<h1>BigDemon (LordScinawa)</h1>
<pre class="block_code"># # To install this program:# # mkdir /etc/abdemon# # cd /etc/abdemon# # jed /user.conf# # write here user and pass coded in base64 :) # # user:pass# # jed /abcomand.conf# # write here the command to startup or shtudown the demon# # Demon Name:command:Description#!/usr/bin/perl -wuse strict;use warnings;use IO::Socket::INET;use MIME::Base64;sub login{print"Starting LogIN\n";my $session = $_[0];print $session "LogIN: AbsoluteDemon\n\r";print $session "UserName:";my $ut=<$session>;print $session "Pass:";my $pa=<$session>;open DB, "<", "user.conf";#open DB, ">", "/etc/abdemon/user.conf";$a=<DB>;my @vagone=split( /:/, $a);my $user=beis($vagone[0]);my $pass=beis($vagone[1]);chomp($user, $pass);$ut =~ s/\r\n\z//;$pa =~ s/\r\n\z//;chomp($ut, $pa);if ($ut eq $user) {if ($pa eq $pass){print "LogIN Succesfull\n";choose($session);}}else {print $session "User can NOT log in";sleep 1;uail(); }}sub choose {my $session=$_[0];my @comz;my $ch;#open COM, "<", "/etc/abdemon/adcomand.conf";open COM, "<", "C:/abd/abcomand.conf";my $num=0;while (my $riga=<COM>) {$num=$num+1;print $session "$num, $riga\n\r";    $comz[$num]=$riga;                                #array che contiene i comandi pi il numero }do  { $ch=<$session>;#ricevo il numero di comando    $ch =~ s/\n\r\z//;my $dirty=$comz[$ch];#tiro fuori la riga e la chompochomp($dirty);my @command=split( /:/, $dirty);#tiro fuori il comandoprint $session "$command[1]\n\r";print "$ch\n\r"; system($command[1]);print $session "And now?"}while ($ch ne "0");close $session;close COM;sleep 10;uail();}sub beis { my $a=decode_base64($_[0]); print "Decoding..\n";return $a;} sub uail {my @time = (localtime);my $sock = new IO::Socket::INET(LocalPort => '7350',#Localaddr =>'localhost',Proto => 'tcp',Listen => '1') or die "Cannot Listen on sock! $!\n";my $session = $sock->accept;print "Socket Created\n";#open LOGZ, '>>', '/etc/abdemon/access_log';open LOGZ, '>>', 'logz.txt';my $ip=$session->peerhost;print (LOGZ "$ip at time: $time[2]h $time[1]m $time[0]s Day: $time[3]/$time[4]($time[5]-100) ");close LOGZ;print"Logged IP\n";login($session);close $sock;}print"Absolute Demon 1.0 (un)stable relase\n";chdir "C:/abd";uail();</pre>
</article>
<article>
<h1>perl-assoc 0.31 (Maze)</h1>
<pre class="block_code">#!/usr/bin/perl#perl-assoc 0.31#by Chris Monahan + help from perl monks##This is free software, you can distribute it under the same#terms as perl itself####a simple listing script for associations on a win32 system####like assoc for win 2000/XP except there isn't ####yet any functionality to change association####Just list them...####could be used on win 9.x or others without assoc##since 0.1 added options and help and rewrote to make clearer (thanks ikegami)#but for some reason looking up a specific extension has been broken... at a loss here...#since: 0.2 fixed bugs - albiet a little sloppily turns out looking up specific extension#was just me using = instead of ==, *slaps forhead*#since: 0.25 added functionality for changing (not deleting or creating) a single association#and listing more than one extension, also a foil to bail when it tries to be executed in a #non win32 enviromentuse warnings;use strict;unless ($^O =~ /Win32/){die "This program requires a full Win32 enviroment"}else{## not using indents for this master block because it's so huge and boringuse Win32::TieRegistry (Delimiter => ":");#define subroutines --sub scan { #for scanning arrays in generalmy $hunt = $_[0];my @founda = 0;#if (defined($hunt)){@founda = grep {/$hunt/} @_;#}#else{#$founda[$#_] = 1;#}return $#founda;}sub help { # output helpprint<<EOF;perl-assoc 0.2Displays file extension associations-to see particular extensions: ASSOC .ext1 .ext2 .ext3... [options]  .ext  Specifies the file extension to display  -to see all file extensions: ASSOC [options]will show a list of all known file associations-to change a single extension association (creating/destroying associations not yet supported):ASSOC .ext=filetypefiletype specifies what identifier this extension will use in the registry and the interface available options are: /W - warn about extensions not assigned with a filetype /F - format output with paddingeg: assoc .htm .pl /Fmight give you:.htm \t = \t FireFoxHTML.pl \t = \t Perl EOF}sub mainlist {#simple abstraction for problem with calling with no variablesforeach my $ext (keys %{ $Registry->{"Classes:"} }) {  next unless substr($ext, 0, 1) eq '.';  my $RegHash = $Registry->{"Classes:$ext"};  if (not exists $RegHash->{':'}) {    print "\t --No filetype associated with $ext\n" if scan("/W", @_);    next;  }  my $class = $RegHash->{":"};  chop $ext;  if (scan("/F", @_)){     print "$ext \t = \t $class \n";  }  else {  print "$ext=$class \n"} }} #declare my variablesmy $ext;my $RegHash;my $class;my $extcnt = 0;my $warnalert;my @cnvbits;if(@ARGV){#-beginning of silly solution for calling it with no variables#finding pleas for helpif ($ARGV[0] eq "/?") { help();}elsif ($ARGV[0] eq "help") {help();}##what to do when called with extension's (plural)elsif (substr ($ARGV[0] ,0,1) eq '.'){@cnvbits = (split /=/, $ARGV[0]);if (@cnvbits == 2 ){my $RegHash = $Registry->{"Classes:$cnvbits[0]"};$RegHash->{':'} = $cnvbits[1];print "$cnvbits[0] = $cnvbits[1] \n";}else{while (substr ($ARGV[$extcnt] ,0,1) eq '.'){my $ext = $ARGV[$extcnt];my $RegHash = $Registry->{"Classes:$ext"};$warnalert = 0; if (not exists $RegHash->{':'}) {   if (scan("/W", @ARGV)) {print "\t  --No filetype found associated with $ext\n"}    else {print "$ext=? \n"};   $warnalert = 1; } unless($warnalert){ my $class = $RegHash->{":"}; if (scan("/F", @ARGV)){  print "$ext \t = \t $class \n";}else { print "$ext=$class \n"}}$extcnt++} }}##and finally when all else fails just list everythingelse {mainlist(@ARGV);}}else {#-end of silly solution for calling it with no variblesmainlist();}}#end of master block#to-do##lots##need to find out why I can't seem to create a default value when one doesn't already exist#create a subroutine #since it'll have to be renamed to work on NT, add a sub for pinpointing the name used to run it for use in the help sub#abstract common functions as it gets larger, can't rely on copy and paste##add the abstract functions to a perl module##create an ftype tool to go with this one</pre>
</article>
<article>
<h1>perl-assoc 0.1 (Maze)</h1>
<pre class="block_code">#perl-assoc 0.1#by Chris Monahan + help from perl monks##This is free software, you can distribute it under the same#terms as perl itself####a simple listing script for associations on a win32 system####like assoc for win 2000/XP except there isn't ####yet any functionality to change association####Just list them...quite uselessly - just proof of concept#use warnings;use strict;use Win32::TieRegistry (Delimiter => ":");#use Data::Dumper;my $class;my $val;my $key;#my $error;if (not defined($ARGV[0])){ foreach $class (keys %{ $Registry->{"Classes:"} }){if ($class =~ /^[.]/) {my $RegHash = $Registry->{"Classes:$class"};#$error = Dumper %RegHash;while (my ($key, $val) = each(%$RegHash)){#or die "failure to read registry: $! \nlast contents of Registry Hash = $error \n"; if ($key eq ":"){ print "$class \t = \t $val\n"; } #else{#warn "unable to recognise association for $class"#}}}}}else {$class = $ARGV[0];if ($class =~ /^[.]/) {my $RegHash = $Registry->{"Classes:$class"};#$error = Dumper %RegHash;while (my ($key, $val) = each(%$RegHash)){#or die "failure to read registry: $! \nlast contents of Registry Hash = $error \n"; if ($key eq ":"){ print "$class \t = \t $val\n"; } #else{#warn "unable to recognise association for $class"#}}}}#To-Do:#everything#use more sensible looping for listing - thank you ikegami#enable formatting and verbose options#enable changing types## in the end possibly going into more advanced file type stuff## </pre>
</article>
<article>
<h1>Color diff for terminal (frodo72)</h1>
<pre class="block_code">#!/usr/bin/perluse strict;use warnings;use Carp;use Pod::Usage qw( pod2usage );use Getopt::Long qw( :config gnu_getopt require_order pass_through );use Fatal qw( open );use Term::ANSIColor qw( :constants );use File::Basename qw( basename );use version; my $VERSION = qv('0.0.1');# Pre-mangling based on the name used to install the programmy %config;if (basename($0) eq 'cdiff') {   # Blindly re-route all options to diff. @ARGV shall be used to   # build the external command that will output the text to be colorised   unshift @ARGV, 'diff';}else {   GetOptions(\%config, 'usage', 'help', 'man', 'version');   pod2usage("$0 v$VERSION") if $config{version};   pod2usage(-verbose => 99, -sections => 'USAGE') if $config{usage};   pod2usage(-verbose => 99, -sections => 'NAME|USAGE|OPTIONS|EXAMPLES')     if $config{help};   pod2usage(-verbose => 2) if $config{man};}# Other recommended modules (uncomment to use):#  use IO::Prompt;#  use Readonly;#  use Data::Dumper;#  use Log::Log4perl qw( :easy );# Script implementation heremy %color_for = (   '<' => RED,   '-' => RED,   '>' => GREEN,   '+' => GREEN,   '@' => BLUE,);# Establish inputmy $fh;if (scalar @ARGV) {   my $command = join ' ', map { quotemeta } @ARGV;   open $fh, '-|', $command;}else {   $fh = \*STDIN;}# Iterate over input and color itwhile (<$fh>) {   my $first_char = substr $_, 0, 1;   delete $color_for{'-'} if $first_char eq '<';   print BOLD, $color_for{$first_char} if exists $color_for{$first_char};   print;   print RESET if exists $color_for{$first_char};}close $fh;__END__=head1 NAMEcolordiff - colorise a C<diff> output, optionally invoking a command cdiff     - call C<diff(1)> and colorise its output=head1 VERSIONCall with C<--version> (not available in C<cdiff>). It should be 0.0.1.=head1 USAGE   colordiff [--usage] [--help] [--man] [--version]   [ some command producing diff output ] | colordiff   colordiff < some-diff-file   colordiff [ some command producing diff output ]   cdiff [ diff(1) options and command line ]=head1 OPTIONSC<colordiff> has the same options of the subcommand it's required tocall, with the following exceptions:=over=item --helpprint a somewhat more verbose help, showing usage, this description ofthe options and some examples from the synopsis.=item --manprint out the full documentation for the script.=item --usageprint a concise usage line and exit.=item --versionprint the version of the script.=backC<cdiff> always I<forwards> the command line to C<diff(1)>, so seethe manpage to find the options. Note that not all options will bemeaningful to use with C<cdiff>; notably, if you want to produce acompact style diff the colorisation will be mostly unuseful.=head1 EXAMPLES   # get full documentation   shell$ colordiff --man   # Use as a filter   shell$ diff file1 file2 | colordiff   # We can spare a few typing, simple invocation of diff   shell$ cdiff file1 file2   # Pass options to diff, e.g. get unified diff   shell$ cdiff -u file1 file2   # The filter incarnation is still useful, anyway - e.g.   # with version control systems   shell$ cvs diff -u -r REL_1_0 somefile | colordiff   shell$ svk diff somefile | colordiff   # Save a few types   shell$ colordiff cvs diff -u -r REL_1_0 somefile   shell$ colordiff svk diff somefile   # These two are equivalent, choose the best for you   shell$ colordiff diff -u file1 file2   shell$ cdiff -u file1 file2   # These aliases could turn useful, assumes sh or compatibles   shell$ alias svkdiff='colordiff svk diff'   shell$ svkdiff somefile   shell$ svkdiff -r -1 somefile   shell$ alias cvsdiff='colordiff cvs diff -u' # I like unified diff   shell$ cvsdiff -r REL_1_0 somefile  =head1 DESCRIPTIONC<colordiff> colorises a C<diff(1)> text on the terminal, in order to makeit visually clear where the changes are. It is best suited to situation wherethe differences are small, i.e. they do not take pages and pages, becauseall colorisation happens in the terminal.When the command line of C<colordiff> is empty, the input text to coloriseis assumed to be on standard input. Otherwise, the command line isassumed to be a command which is invoked and whose output must becolorised. So, the following are equivalent:   shell$ command foo bar baz | colordiff   shell$ colordiff command foo bar bazbut you can save a little typing with the latter.When installed as C<cdiff>, it is assumed to be a blind wrapper aroundC<diff(1)>. In this case, C<diff(1)> will be invoked with the remainingoptions, so the following are equivalent:   shell$ cdiff foo bar baz   shell$ colordiff diff foo bar bazbut the former is stunningly faster to type and better to remember.Note that only "plain diff" and unified styles are supported forcolorisation.=head1 DIAGNOSTICSNone particular. If for some reason the pipe from the diff command cannotbe established the script will die with a hopefully meaningful message.=head1 CONFIGURATION AND ENVIRONMENTcolordiff requires no configuration files or environment variables.=head1 DEPENDENCIESYou won't get far without Term::ANSIColor.=head1 BUGS AND LIMITATIONSNo bugs have been reported.The error code from the diff command is not replicated as exit code ofC<colordiff>. This should not be a real limitation, because C<colordiff>is intended for interactive usage more than batch.Please report any bugs or feature requests through http://rt.cpan.org/=head1 AUTHORFlavio Poletti C<flavio@polettix.it>=head1 LICENCE AND COPYRIGHTCopyright (c) 2006, Flavio Poletti C<flavio@polettix.it>. All rights reserved.This script is free software; you can redistribute it and/ormodify it under the same terms as Perl itself. See L<perlartistic>and L<perlgpl>.Questo script  software libero: potete ridistribuirlo e/omodificarlo negli stessi termini di Perl stesso. Vedete ancheL<perlartistic> e L<perlgpl>.=head1 DISCLAIMER OF WARRANTYBECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTYFOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHENOTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIESPROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHEREXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIEDWARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THEENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITHYOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALLNECESSARY SERVICING, REPAIR, OR CORRECTION.IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITINGWILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/ORREDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BELIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL,OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USETHE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEINGRENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR AFAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IFSUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OFSUCH DAMAGES.=head1 NEGAZIONE DELLA GARANZIAPoich questo software viene dato con una licenza gratuita, nonc' alcuna garanzia associata ad esso, ai fini e per quanto permessodalle leggi applicabili. A meno di quanto possa essere specificatoaltrove, il proprietario e detentore del copyright fornisce questosoftware "cos com'" senza garanzia di alcun tipo, sia essa espressao implicita, includendo fra l'altro (senza per limitarsi a questo)eventuali garanzie implicite di commerciabilit e adeguatezza peruno scopo particolare. L'intero rischio riguardo alla qualit edalle prestazioni di questo software rimane a voi. Se il softwaredovesse dimostrarsi difettoso, vi assumete tutte le responsabilited i costi per tutti i necessari servizi, riparazioni o correzioni.In nessun caso, a meno che ci non sia richiesto dalle leggi vigentio sia regolato da un accordo scritto, alcuno dei detentori del dirittodi copyright, o qualunque altra parte che possa modificare, o redistribuirequesto software cos come consentito dalla licenza di cui sopra, potressere considerato responsabile nei vostri confronti per danni, iviinclusi danni generali, speciali, incidentali o conseguenziali, derivantidall'utilizzo o dall'incapacit di utilizzo di questo software. Ciinclude, a puro titolo di esempio e senza limitarsi ad essi, la perditadi dati, l'alterazione involontaria o indesiderata di dati, le perditesostenute da voi o da terze parti o un fallimento del software adoperare con un qualsivoglia altro software. Tale negazione di garanziarimane in essere anche se i dententori del copyright, o qualsiasi altraparte,  stata avvisata della possibilit di tali danneggiamenti.Se decidete di utilizzare questo software, lo fate a vostro rischioe pericolo. Se pensate che i termini di questa negazione di garanzianon si confacciano alle vostre esigenze, o al vostro modo diconsiderare un software, o ancora al modo in cui avete sempre trattatosoftware di terze parti, non usatelo. Se lo usate, accettate espressamentequesta negazione di garanzia e la piena responsabilit per qualsiasitipo di danno, di qualsiasi natura, possa derivarne.=cut</pre>
</article>
<article>
<h1>Subversion(SVN) pre-commit hook (runrig)</h1>
<pre class="block_code">#!/usr/bin/perlrequire SVN::Core;require SVN::Repos;require SVN::Fs;require SVN::Delta;package ChangeReceiver;my $file_re = qr/\.txt/;my $bad_re = qr/foo/;our @ISA = qw(SVN::Delta::Editor);sub add_file {  return [0, $_[1]];}sub open_file {  return [0, $_[1]];}sub apply_textdelta {  $_[1]->[0] = 1;  return;}sub close_file {  my ($self, $file_baton) = @_;  my ($changed, $path) = @$file_baton;  return unless $changed;  return unless $path =~ /$file_re/;  my $pool = SVN::Pool->new_default_sub;  my $stream = SVN::Fs::file_contents( $self->{txn_root}, $path, $pool );  my $bytes;  my $byte_cnt = 0;  my $exit_code = 0;  my $buffer = '';  while ( $bytes = $stream->read( $buffer, $SVN::Core::STREAM_CHUNK_SIZE, 0 ) ) {    if ( $buffer =~ /$bad_re/ ) {      $exit_code=1;      last;    }    $byte_cnt += $bytes;    $buffer = '';  }  $stream->close;  if ($exit_code) {    warn "Bad file: $path\n";    exit $exit_code;  }  return;}package main;my ($rep, $txn) = @ARGV;my $rep = SVN::Repos::open($rep);my $fs = $rep->fs;my $txn_ptr = $fs->open_txn($txn);my $txn_root = SVN::Fs::txn_root($txn_ptr);my $base_root = $fs->revision_root($fs_ptr, SVN::Fs::txn_base_revision($txn_ptr));my $editor = ChangeReceiver->new;$editor->{txn_root} = $txn_root; # Bad OO I knowSVN::Repos::dir_delta($base_root, '', '', $txn_root, '', $editor, sub{1}, 1, 1, 0, 0);exit 0;</pre>
</article>
<article>
<h1>lspm  list names and descriptions of Perl modules in a directory (Aristotle)</h1>
<pre class="block_code">#!/usr/bin/perl=head1 NAMElspm - list names and descriptions of Perl modules in a directory=head1 SYNOPSIS lspm -h lspm [-p] [-a] [-c [num]] [-l len] [dir [dir dir ...]]=head1 DESCRIPTIONLists all or a subset of installed Perl modules, with version numbers and descriptions.It will look in Perl's default search path for modules, C<@INC>, if you don't explicitly list any directories to walk. Note that this default search excludes the current directory.=head1 OPTIONS=over 4=item B<-h>, B<--help>See a synopsis.=item B<--man>Browse the manpage.=item B<-p>, B<--show-path>Include path of found modules in output.=item B<-a>, B<--align>Vertically align descriptions.=item B<-c>, B<--align-local>, B<--align-cont>Align descriptions in blocks where the module names don't differ too much in length, to avoid pushing all descriptions way over to the right just because a few names are long. The output looks more ragged than with full alignment, but is still lined up locally and only requires the eye to cross small gaps between columns, so is usually more readable.You can pass an optional positive integer argument to specify the length threshold; the default is 7.=item B<-l>, B<--max-length>, B<--limit>Cut off descriptions at specified length.=back=head1 SEE ALSOL<http://www.cpan.org/modules/by-authors/id/TOMC/scripts/pmdesc.gz>=head1 BUGSI need something to write here.=head1 COPYRIGHT AND LICENCEWritten by Aristotle Pagaltzis, (c)2006.This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself.=cutuse 5.6.1;use strict;use warnings;use List::Util qw( min max );use File::Find qw( find );use File::Spec::Functions qw( rel2abs abs2rel no_upwards );use ExtUtils::MakeMaker ();use Getopt::Long 2.24, qw( :config bundling no_ignore_case no_auto_abbrev );use Pod::Usage qw( pod2usage );$|++;sub module_name_from_filename {local $_ = shift;s! \.p(?:m|od) \z!!x;s!/!::!g;return $_;}sub get_module_description {my ( $file, $max_length ) = @_;my $desc;open my $pod, "<", $fileor ( warn( "\tCannot open $file: $!" ), return );my $get_line = sub {$_ = <$pod>;defined and s/\x0D?\x0A/\n/g; # fix DOS crud; see perlport$_;};local $_;# find descriptionwhile ( $get_line->() ) {last if m{\A=head\d\s+NAME\b};}# skip leading junkwhile ( $get_line->() ) {last if /\A=\w/;if( s{\A.*? - \s*}{} ) {$desc .= $_;last;}}# collect descriptionwhile ( $get_line->() ) {last if /\A=\w/;s/\A\s+\z//;$desc .= $_;last if not length;}for( $desc ) {last if not defined;s/\s*\z//;s/\s+/ /g;$_ = substr $_, 0, $max_length if $max_length;undef $_ if not length;}return $desc;}sub get_module_version {my ( $file ) = @_;local $_ = MM->parse_version( $file );$_ = eval if $_ and /[^\d._]/;return $_;}{my %visited;sub visited {my ( $dir ) = @_;my $unique_id;if( $^O eq "MSWin32" ) {$unique_id = $dir;}else {my ( $dev, $inode ) = stat $dir or return;$unique_id = join ':', $dev, $inode;}return ! ! $visited{ $unique_id }++;}}sub name_width {my ( $module, $version ) = @_;length( $module . ( defined $version ? $version : '' ) );}sub print_module_info {my ( $module, $version, $desc, $path, $name_width ) = @_;my @output;push @output, do {local $_ = $version;$_ = '' if not defined;my $name = "$module ($_)";$name = sprintf '%-*s', $name_width + 3, $name if defined( $desc and $name_width );$name;};push @output, "[$path]" if defined $path;push @output, '-', $desc if defined $desc;print "@output\n";}GetOptions('h|help'                     => sub { pod2usage( -verbose => 1 ) },'man'                        => sub { pod2usage( -verbose => 2 ) },'show-path|p!'               => \( my $opt_path = '' ),'align|a'                    => \( my $opt_align = 0 ),'align-local|align-cont|c:7' => \( my $opt_cont ),'max-length|limit|l'         => \( my $opt_limit = 0 ),) or pod2usage( -verbose => 1 );pod2usage 'argument to --align-local must be a positive integer'if $opt_cont and $opt_cont < 1;@ARGV = no_upwards( @INC ) unless @ARGV;my @info;my $min_w = 100;my $max_w = 0;for my $inc_dir ( sort { length $b <=> length $a } map rel2abs( $_ ), @ARGV ) {find({wanted => sub {return unless /\.p(?:m|od)\z/;s/\.pod\z/.pm/; # if it's POD, parse the corresponding codereturn if not -f;my @details = (module_name_from_filename( abs2rel $File::Find::name, $inc_dir ),get_module_version( $_ ),get_module_description( $_, $opt_limit ),$opt_path ? $File::Find::name : undef,);if( $opt_cont ) {my $cur_w = name_width @details;$max_w = max $max_w, $cur_w;$min_w = min $min_w, $cur_w;if( $max_w - $min_w > $opt_cont ) {print_module_info @$_, $max_w for @info;@info = ();$min_w = $max_w;$max_w = 0;}}if( $opt_align or $opt_cont ) {push @info, \@details;}else {print_module_info @details;}},preprocess => sub { visited( $File::Find::dir ) ? () : @_ },},$inc_dir,);}if( @info ) {my $name_width = max map name_width( @$_ ), @info;print_module_info @$_, $name_width for @info;}</pre>
</article>
<article>
<h1>A complete perl roguelike (dabreegster)</h1>
<pre class="block_code">// None, the game is at http://assilem.org/breegrl/trunk/emotionrl.tgz</pre>
</article>
<article>
<h1>ReorgXSD.pl (dsilvia)</h1>
<pre class="block_code">#!perluse strict;#use warnings;use File::Spec::Functions ':ALL';sub escapeSpecial($){my $str=shift(@_);return(quotemeta($str));}sub getEntityType($){my $wholeStr=shift(@_);if(!$wholeStr || $wholeStr=~m{^\s*$}){return('','');}my $comparator='(\s*?<(\b\w+?\b:?\b\w+?\b).*?(?:\bname\b.*?=.*?(?:\"|\')\b\w*?\b(?:\"|\'))?.*?>)';if(!($wholeStr=~m{$comparator}s)){return('','');}return($1,$2);}sub getEntry($){my $wholeStr=shift(@_);my $entityType=getEntityType($wholeStr);my $entry;my $comparator;my $tail;if(!$entityType){return($wholeStr,'','','','');}($entry,$entityType)=getEntityType($wholeStr);$tail=substr($entry,length($entry)-2,2);if($tail eq '/>'){return getSimpleEntry($wholeStr,$entityType,$entry);}else{return getComplexEntry($wholeStr,$entityType,$entry);}}sub getComplexEntry($$$){my $wholeStr=shift(@_);my $entityType=shift(@_);my $anyTag='.*?</?(?:[a-z_][a-z0-9.:_-]*?).*?>';my $closeTag='</(?:xs:|.).*?>';my $comparator;my $entityName;my $entityDefinition;my $resultStr;my $beginMatch;my $matchLen;my $chunk;my $theHead;my $theTail;my $matches=0;$comparator=$anyTag;if($entityType =~ m{(?:xs.*?|.*?)?:?import}){$wholeStr=~m{($comparator)}sg;$entityDefinition=$1;$matchLen=pos($wholeStr);$beginMatch=0;if($wholeStr=~m{(?=$entityDefinition).}sg){$beginMatch=pos($wholeStr)-1;}$resultStr=substr($wholeStr,0,$beginMatch).substr($wholeStr,$matchLen);$comparator='namespace.*?=.*?(?:\"|\')(.*?)(?:\"|\')';$wholeStr=~m{$comparator}s;$entityName=$1;return($resultStr,$entityDefinition,$entityName,$entityType,'complex');}$chunk=$wholeStr;$chunk=~m{$anyTag}s;$beginMatch=$-[0];$matchLen=$beginMatch;$comparator='\bname\b.*?=.*?(?:\"|\')(\b\w*?\b)(?:\"|\')';$chunk=~m{$comparator}s;$entityName=$1;while($chunk=~m{($anyTag)}sg){my $endOfMatch=$+[0];my $tmp=$1;$tmp=~m{<}s;my $tmpBegin=$-[0];$theHead=substr($tmp,$tmpBegin,2);$theTail=substr($tmp,length($tmp)-2);if($theHead ne '</'){if($theHead=~m{<.} and $theTail ne '/>'){$matches++};}else{$matches--};if(!$matches){$closeTag='</'.$entityType.'.*?>';$chunk=~m{$closeTag}s;$matchLen+=$+[0];last;}$matchLen+=$endOfMatch;$chunk=substr($chunk,$endOfMatch);}$entityDefinition=substr($wholeStr,$beginMatch,$matchLen);$resultStr=substr($wholeStr,0,$beginMatch).substr($wholeStr,$beginMatch+$matchLen);return($resultStr,$entityDefinition,$entityName,$entityType,'complex');}sub getSimpleEntry($$$){my $wholeStr=shift(@_);my $entityType=shift(@_);my $entityDefinition;my $comparator;my $entityName;my $resultStr;my $beginMatch;my $endMatch;$comparator='\s*?<'.$entityType.'.*?(?:\bname\b.*?=.*?(?:\"|\')(\b\w*?\b)(?:\"|\'))?.*?/>';if($wholeStr=~m{($comparator)}sg){$entityDefinition=$1;$beginMatch=$-[0];$endMatch=$+[0];$comparator='\bname\b.*?=.*?(?:\"|\')(\b\w*?\b)(?:\"|\')';if($wholeStr=~m{$comparator}s){$entityName=$1;}$resultStr=substr($wholeStr,0,$beginMatch).substr($wholeStr,$endMatch);return($resultStr,$entityDefinition,$entityName,$entityType,'simple');}return($wholeStr,'','','','');}my @myArgs=@ARGV;if(!$myArgs[0]){my @myPath=splitpath(__FILE__);my $myName=$myPath[2];print "\nUsage: ".$myName." file(s)\n\n";print "Reorganizes xsd files to be more human readable.  Puts any header information\n";print "first, then tries to determine a root entity and places it next.  Should more\n";print "than one entity be a possible root entity, all are listed, and if none are\n";print "found, a comment to that effect is entered.  Next, any remaining complex\n";print "elements, then simple elements, then complex entities, and simple entities.\n";print "Last whatever is left (if any!;)\n\n";print "The only requirement is a well-formed file.  Qualification for a root entity\n";print "is that it not be referenced by any other entity.\n\n";print "Results of the process are placed in a like named file with the prefix of\n";print "'ReorgXSD.\n\n";print "Shortcomings:\n";print "\tDoes not analyze DTD entries to determine proper settings for\n";print "\ttype/attribute/ref, specifically, prefixes.  It merely assumes that\n";print "\tany prefix ending in a colon (:) is valid an has been provided for.\n\n";print "\tCannot distinguish between relevance of entities if they are named\n";print "\talike.\n\n";print "\tComments are not preserved as they cannot be meaningfully\n";print "\tinterpolated.  There is no way to tell if a comment goes with a\n";print "\tspecific entity or group of entities or the whole file!:-(\n\n";print "\tThe concept of non-reference indicating a root element can be\n";print "\tnaive in the case of very complicated xsd files with imports and\n";print "\tother outside references.\n\n";exit 0;}while(@myArgs){my $inFileName=$myArgs[0];my @pathMembers=splitpath($inFileName);my $outFileName=$pathMembers[0].$pathMembers[1]."ReorgXSD.".$pathMembers[2];my ($initFile,$fileHdr,$fileFtr);{local $/=undef;open(INITFILE,"< $inFileName") or die "Could not open initialization file '".$inFileName."': $!\n";$initFile=<INITFILE>;close(INITFILE);}my $comparator;# normalize the parsing input:#remove comments (cannot meaningfully interpolate these)#  remove the <?xml... and <xs:schema... header#  remove the </xs:schema... footer#reduce newlines to single occurrences.$comparator='(^(?:<\?xml.*?>)*.*?<(?:xs.*?|.*:)schema\b.+?>)';$initFile=~m{$comparator}s;$fileHdr=$1;$initFile=$';$comparator='(^</(?:xs.?|.*):?\bschema\b.*?>)';$initFile=~m{$comparator}ms;$fileFtr=$1;$initFile=$`;$comparator='\s*?<!--.*?-->';$initFile=~s/$comparator//sg;$comparator='(\r\n|[\r\n]){2,}';$initFile=~s/$comparator/$1/g;my @AllEntities;my @AllElements;my %UnReferenced;my %ComplexElements;my %SimpleElements;my @xsImports;my %ComplexEntities;my %SimpleEntities;my $fileIterator=$initFile;my $elmDef;my $elmName;my $elmType;my $tagType;($fileIterator,$elmDef,$elmName,$elmType,$tagType)=getEntry($fileIterator);while($elmDef){if($tagType eq 'complex'){if($elmType =~ m{(?:xs.*?|.*?):?element}){%ComplexElements=(%ComplexElements,$elmName=>$elmDef);@AllEntities=(@AllEntities,$elmName);@AllElements=(@AllElements,$elmName);}elsif($elmType =~ m{(?:xs.*?|.*?):?import}){@xsImports=(@xsImports,$elmDef);}elsif($elmName){%ComplexEntities=(%ComplexEntities,$elmName=>$elmDef);@AllEntities=(@AllEntities,$elmName);}}else{if($elmType =~ m{(?:xs.*?|.*?):?element}){%SimpleElements=(%SimpleElements,$elmName=>$elmDef);@AllEntities=(@AllEntities,$elmName);@AllElements=(@AllElements,$elmName);}elsif($elmType =~ m{(?:xs.*?|.*?):?import}){@xsImports=(@xsImports,$elmDef);}elsif($elmName){%SimpleEntities=(%SimpleEntities,$elmName=>$elmDef);@AllEntities=(@AllEntities,$elmName);}}($fileIterator,$elmDef,$elmName,$elmType,$tagType)=getEntry($fileIterator);}my $rootName='';my @rootDefn;foreach my $entity (sort @AllEntities){my $refd=0;foreach my $key (sort @AllElements){next if $key eq $entity;if(($ComplexEntities{$key}=~m{((?:\b\w+\b)(?<!name)\s*?=\s*?(?:\"|\')(?:\w+?:)?\b$entity\b(?:\"|\'))}) ||($ComplexElements{$key}=~m{((?:\b\w+\b)(?<!name)\s*?=\s*?(?:\"|\')(?:\w+?:)?\b$entity\b(?:\"|\'))}) ||($SimpleEntities{$key}=~m{((?:\b\w+\b)(?<!name)\s*?=\s*?(?:\"|\')(?:\w+?:)?\b$entity\b(?:\"|\'))}) ||($SimpleElements{$key}=~m{((?:\b\w+\b)(?<!name)\s*?=\s*?(?:\"|\')(?:\w+?:)?\b$entity\b(?:\"|\'))})){$refd=1;last;}}if(!$refd){%UnReferenced=(%UnReferenced,$entity=>1);}}foreach my $key (sort @AllElements){if($UnReferenced{$key}){if($ComplexElements{$key}){@rootDefn=(@rootDefn,$ComplexElements{$key});delete $ComplexElements{$key};}elsif($SimpleElements{$key}){@rootDefn=(@rootDefn,$SimpleElements{$key});delete $SimpleElements{$key};}elsif($ComplexEntities{$key}){@rootDefn=(@rootDefn,$ComplexEntities{$key});delete $ComplexEntities{$key};}elsif($SimpleEntities{$key}){@rootDefn=(@rootDefn,$SimpleEntities{$key});delete $SimpleEntities{$key};}}}open(OUTFILE,"> $outFileName") or die "Could not open output file $!\n";print OUTFILE $fileHdr."\n";if(@xsImports){print OUTFILE "\n<!-- imports (ReorgXSD) -->\n";foreach my $entity (@xsImports){print OUTFILE $entity."\n";}}if(@rootDefn && @rootDefn == 1){print OUTFILE "\n<!-- Root Element (ReorgXSD) -->\n";print OUTFILE $rootDefn[0]."\n";}elsif(@rootDefn){my $numRoots=@rootDefn;print OUTFILE "\n<!-- No Root Element Found ($numRoots possible) (ReorgXSD) -->\n";foreach my $defn (@rootDefn){print OUTFILE $defn."\n";}}else{print OUTFILE "\n<!-- No Root Element Found (ReorgXSD) -->\n";}if(%ComplexElements){print OUTFILE "\n<!-- Complex elements (ReorgXSD) -->\n";foreach my $key (sort keys %ComplexElements){print OUTFILE $ComplexElements{$key}."\n";}}if(%SimpleElements){print OUTFILE "\n<!-- Simple elements (ReorgXSD) -->\n";foreach my $key (sort keys %SimpleElements){print OUTFILE $SimpleElements{$key}."\n";}}if(%ComplexEntities){print OUTFILE "\n<!-- other named complex entities (ReorgXSD) -->\n";foreach my $key (sort keys %ComplexEntities){print OUTFILE $ComplexEntities{$key}."\n";}}if(%SimpleEntities){print OUTFILE "\n<!-- other named simple entities (ReorgXSD) -->\n";foreach my $key (sort keys %SimpleEntities){print OUTFILE $SimpleEntities{$key}."\n";}}if($fileIterator and $fileIterator !~ m{^\s*$}){print OUTFILE "\n<!-- misc entities (ReorgXSD) -->\n";print OUTFILE $fileIterator;}print OUTFILE "\n";print OUTFILE $fileFtr;print OUTFILE "\n";close(OUTFILE);print "Results are in file '".$outFileName."'\n";shift(@myArgs);}</pre>
</article>
<article>
<h1>Win32 iTunes Alarm Clock (Ole!) (Adam)</h1>
<pre class="block_code">#!perluse strict;use Time::Local;use Warnings;use Win32;use Win32::OLE;my $start = shift || -1;  # Use -1 for immediate start.my $playlist = shift;my $fadeup = 1;if ( not defined $playlist ){    if ( $start !~ m/^\s*-?\d+\s*$/ )    {        $playlist = $start;        $start = -1;        $fadeup = 0;    }    else    {        $playlist = "Party Shuffle";    }}if ( $start != "-1" ) # Determine when to proceed, then wait until then.{    my ( $sH, $sM ) = $start =~ m/^\s*(\d\d?)(\d\d)\s*$/;    die "$0 '$start'\nTime should be in military time with no symbols, e.g.:\n6:30 am = 630, 10:15 pm = 2215\n"         unless defined( $sH ) and defined( $sM );    my $t = time();    my @p = localtime($t); # ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst)    my ( $tM, $tH ) = ( $p[1], $p[2] );    my $s = 0;    my $today = 0;    if ( $sH < $tH || ( $sH == $tH && $sM <= $tM ) )    {        my @sP = localtime($t + 86400);        $s = timelocal( 0, $sM, $sH, $sP[3], $sP[4], $sP[5] );    }    elsif ( $sH > $tH || ( $sH == $tH && $sM > $tM ) )    {        $s = timelocal( 0, $sM, $sH, $p[3], $p[4], $p[5] );        $today = 1;    }    else    { die "ASSERT( '$sH', '$tH' )" }    print "Set for ", ( $today ? "today, " : "tomorrow, " ), scalar( localtime( $s ) ), "\n";    sleep( ( $s - $t ) - 59 ) if ( ( $s - $t ) > 59 );    print "Ready? One Minute to Go!\n";    sleep( 15 ) while time() < $s;}else{    # no delay? then no fade either.    $fadeup = 0;}print "Starting iTunes . . .\n";my $G_iTA = new Win32::OLE("iTunes.Application");$G_iTA->{ "BrowserWindow" }->{ "MiniPlayer" } = 1;$G_iTA->{ "SoundVolume" } = $fadeup ? 10 : 90;print "Playing...\n";$G_iTA->{ "LibrarySource" }->{ "Playlists" }->ItemByName( $playlist )->PlayFirstTrack();if ( $fadeup ){    print "Fading up...\n";    for my $v ( 11 .. 90 )    {        sleep( 1 );        $G_iTA->{ "SoundVolume" } = $v;    }        print "Have a nice day!\n\n";}else{    print "iTunes load complete.\n\n";}</pre>
</article>
<article>
<h1>SSH Failed Attempt Monitor (Anonymous Monk)</h1>
<pre class="block_code">#!/usr/bin/perl# This script watches the /var/log/secure for failed ssh attempts.  When found, it will add a reject route to your routing table, making it impossible for your machine to communicate with that host again.## Written By: Matt Joubert (matt __at__ uucp _dot_ ca)# Date: June 2, 2006#use strict;use warnings;use Sys::Syslog;# define ssh log file locationmy $logFile = '/var/log/secure';# syslog facilitymy $syslogFac = 'local0';# syslog levelmy $syslogLevel = 'info';# SAFE IPS, NEVER BLOCK  (I sometimes forget a password..)my @safe = qw/ 192.168.0.1 /;# define threshold in minutes to reset the failed attempt counter# note, this shouldn't be nuts because if set to high, you could shoot yourself in the footmy $thresHold   = 10;    # minutesmy $maxAttempts = 5;##### Probably wont need to change anything below #####use File::Tail;use Time::ParseDate;$thresHold *= 60;        # convert to seconds;my $fh = File::Tail->new(  name        => $logFile,  maxinterval => 10,  interval    => 10,  adjustafter => 5) || die ("could not open log file: $!");# at this point, the file is open.. so the rest should be able to work fine in fork.defined(my $pid = fork)   or die "Can't fork: $!";exit if $pid;my %db;my @rejects;while ( my $line = $fh->read ) {    # ignore all lines except for the failed ones    next unless $line =~ /Failed password/ig;    my @column = split ( /\s+/, $line );    # grab the IP address    $line =~ m/(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})/g;    my $ip = $1;    next unless $ip;    next if safe( $ip, @safe );    my ( $mon, $day, $time ) = (@column)[ 0, 1, 2 ];    my $epoch = parsedate("$mon $day $time");    if ( !defined( $db{$ip} ) ) {        push ( @{ $db{$ip} }, $epoch );    }    else {        push ( @{ $db{$ip} }, $epoch );        # past threshold.. start over from scratch        if ( $db{$ip}[ $#{ $db{$ip} } ] - $db{$ip}[ $#{ $db{$ip} } - 1 ] > $thresHold ) {            undef( $db{$ip} );            push ( @{ $db{$ip} }, $epoch );        }        else {    # threshold is good - check for attempts            if ( scalar @{ $db{$ip} } > $maxAttempts ) {                if ( !isRejected( $ip, @rejects ) ) {                    push ( @rejects, $ip );                    syslog("$syslogLevel|$syslogFac", "Adding $ip to reject route table for too many failed attempts");                    system("/sbin/route add -host $ip reject");                }            }        }    }}# check if ip is "safe" from being blockedsub safe {    my $ip   = shift;    my @safe = @_;    foreach (@safe) {        return 1 if $ip eq $_;    }    return 0;}# check if ip has alread been recently reacted toosub isRejected {    my $ip      = shift;    my @rejects = @_;    foreach (@rejects) {        return 1 if $ip eq $_;    }    return 0;}</pre>
</article>
<article>
<h1>JavaScript::XRay + HTTP::Proxy equals Crazy Delicious (diotalevi)</h1>
<pre class="block_code">#!/usr/bin/perluse strict;use warnings;=head1 NAMEjsxray-proxy - A JavaScript::XRay proxy=head1 SYNOPSIS jsxray [options]  Options:   -port   -switches   -no-xray   -help   -man=head1 DESCRIPTIONStraps L<HTTP::Proxy> onto L<JavaScript::XRay> so I can useJavaScript::XRay really easily and on arbitrary web sites.=over=item -port ...Specifies a port to listen on. The default is 8080.=item -switchesSpecifies switches to use for JavaScript::XRay. Prefix your switch with no- to pass it as a turned off switch.=item -no-xrayDoesn't install JavaScript::XRay. It's just a simple proxy now.=item -helpDisplays the program's options.=item -manDisplays the entire manual.=back=cutuse Getopt::Long 'GetOptions';use autouse 'Pod::Usage', 'pod2usage';GetOptions(    help         => \&help,    man          => \&man,    'port=i'     => \( my ($port) = 8080 ),    'switches=s' => \( my ($switches) = 'all' ),    'no-xray'    => \my ($no_xray)    )    or pod2usage( -verbose => 0 );sub help { pod2usage( -verbose => 1 ) }sub man  { pod2usage( -verbose => 2 ) }require HTTP::Proxy;my $proxy = HTTP::Proxy->new( port => $port );if ( not $no_xray ) {    require HTTP::Proxy::BodyFilter::simple;    require JavaScript::XRay;    my %switches = map { /^no-(.+)/ ? ( $1 => 0 ) : ( $_ => 1 ) }        $switches =~ /((?:no-)?[a-z]+)/g;    my $filter = HTTP::Proxy::BodyFilter::simple->new(        sub {            return unless $_[2]->header('content-type') =~ /text/;            my $uri  = $_[2]->request->uri;            my $xray = JavaScript::XRay->new(                abs_uri  => $uri,                switches => \%switches            );            ${ $_[1] } = $xray->filter( ${ $_[1] } );        }    );    $proxy->push_filter( response => $filter );}$proxy->start;</pre>
</article>
<article>
<h1>ypne (LordScinawa)</h1>
<pre class="block_code">#/usr/bin/perluse warnings; use strict;use File::Copy;#enter here the path of your nmap!my $pathofnmap = "C:/Programmi/nmap-4.03";#don't change :)my $mi = (localtime)[1];#set in minute the gap between every scanmy $gap=1;#don't change :)my $mid; increm();##################################################print "Your personal namp executor\n";print "\n";print "                 LordScinawa    ;)\n";##################################################sub increm { $mid = ($mi + $gap) % 60; }sub meinz{while(1){sleep 1;$mi = (localtime)[1];if ($mi >= $mid) {print"$mi, $mid\n";increm();esegui();  }}}sub esegui {chdir "$pathofnmap";if (open(NMAP, "nmap.exe -sS -P0 -S 127.0.0.1 -f -vv -O 80.104.113.95 |")){    chdir "C:/Documents and Settings/Wxp/Documenti/pubz";if (open CAC, "+>", "cache.html") {print"opened cache\n";while (<NMAP>) {print"nmap!!\n";if (/\n/) {print (CAC "$_<br>\n");} else {die "omfg";} }close CAC; my $filetobecopied = "cache.html.";my $newfile = "nmapresult.html.";copy($filetobecopied, $newfile) or die "File cannot be copied.";print"copiati\n"; } else { die "Impossibile aprire/creare il file di cache $! \n"};close NMAP;} else {die "Impossibile aprire Nmap $!\n"}}meinz();</pre>
</article>
<article>
<h1>FSInfo (bpoag)</h1>
<pre class="block_code">#!/usr/bin/perl## FSInfo v0.1 written 061306:1135 by BJP## FSInfo will dump useful information about LVM structure of a given filesystem.## Usage: fsinfo <mountpoint># Example: fsinfo /tmp#main();sub usage(){  print "\n   Usage: fsinfo <mountpoint>\n";  print " Example: fsinfo /tmp\n\n";  exit();}sub sanityCheck(){  if($#ARGV<0 || $#ARGV>0) ## Hee haw!   {    usage();  }  else  {    $targetFS=$ARGV[0];  }  ## OS level check..  @unameDump=split(/\s+/,`uname -a`);  if ($unameDump[3]<5)  {    print "fsinfo only works in AIX 5L or later.\n";    usage();  }  ## Check to see if the filesystem actually exists...  @dfContents=split(/\s+/,`df -m | grep " $targetFS\$"`);  if(length($targetFS)==length($dfContents[6]))  {    print "\nFSInfo: Starting up..\nFSInfo:\n";  }  else  {    print "\nFSInfo: Ack! Can't find the filesystem you specified ($targetFS)..!  Exiting.\n\n";    exit();  }}sub main(){  sanityCheck();  ## So far so good. Pull up the VG info for this filesystem..  $dfContents[0]=~/\/dev\//;  $targetLV=$';  @lslvContents=split(/\s+/,`lslv $targetLV|head -n1` );  $targetVG=$lslvContents[5];  print "FSInfo: Filesystem \"$targetFS\" belongs to logical volume $targetLV which sits inside $targetVG. Details shown below.\n";  @vgdump=`lsvg -L $targetVG`;  @lvdump=`lslv -L $targetLV`;  ## Dump it all out...  print "FSInfo:\nFSInfo: Volume Group information for $targetFS..\n";  print "FSInfo:\n";  foreach $line (@vgdump)  {    print "FSInfo: $line";  }  print "FSInfo:\nFSInfo: Logical Volume information for $targetFS..\n";  print "FSInfo:\n";  foreach $line (@lvdump)  {    print "FSInfo: $line";  }  print "FSInfo:\nFSInfo: Spinning down..\n\n";}</pre>
</article>
<article>
<h1>LSVPMembers (bpoag)</h1>
<pre class="block_code">#!/usr/bin/perl#### LSVPMembers written 062606:1051 by BJP#### LSVPMembers displays what hdisks belong to which vpaths on a given host.##@vpList = `lsdev -Cc disk | grep ^vp | cut -d" " -f1`;print "\nLSVPMembers: Spinning up..\n";foreach $item (@vpList){  $counter=0;  chomp($item);  chomp($LUN=`lsattr -El $item | grep disk | head -n1 | cut -d\/ -f2`);  $lunID=substr($LUN,0,3)."-".substr($LUN,3)  ;      print "LSVPMembers: \"$item\" ($lunID) encompasses ";  @vpMembers=split(/\s+/,`lsattr -El $item | cut -d" " -f2-3 | cut -c2- | grep disk | cut -d\/ -f1`);    foreach $vp (@vpMembers)  {    print "$vp";    $counter++;      if ($counter<@vpMembers)    {      print ", ";    }    else    {      print ".";    }        if ($counter+1==@vpMembers)    {      print "and ";    }  }  print "\n";}print "LSVPMembers: Spinning down..\n\n";</pre>
</article>
<article>
<h1>LSVGMembers (bpoag)</h1>
<pre class="block_code">#!/usr/bin/perl#### LSVGMembers written 062606:1051 by BJP#### LSVGMembers displays what logical volumes belong to each volume group on a system.##@vgList = `lsvg`;print "\nLSVGMembers: Spinning up..\n";foreach $item (@vgList){  $counter=0;  chomp($item);  print "LSVGMembers: \"$item\" encompasses ";  @vgMembers=split(/\s+/,`lsvg -l $item | grep -v POINT\$ | grep -v $item: | cut -d" " -f1`);  foreach $lv (@vgMembers)  {    print "$lv";     $counter++;      if ($counter<@vgMembers)    {      print ", ";    }    else    {      print ".";    }    if ($counter+1==@vgMembers)    {      print "and ";    }  }  print "\n";}print "LSVGMembers: Spinning down..\n\n";</pre>
</article>
<article>
<h1>LSLVMembers (bpoag)</h1>
<pre class="block_code">#!/usr/bin/perl#### LSLVMembers written 062306:1606 by BJP#### LSLVMembers displays what member hdisks belong to each logical volume.##@lvList = split(/\s+/,`lsvg -o | lsvg -i -l | grep -v : | grep -v ^LV| cut -d\" \" -f1`);print "\nLSLVMembers: Spinning up..\n";foreach $item (@lvList){  print "LSLVMembers: \"$item\" encompasses ";  @lvResults=split(/\s+/,`lslv -l $item`);  $counter=0;  $moreComing=0;  $totalSize=@lvResults;  while ($counter<=@lvResults)  {    if (($lvResults[$counter]=~/hdisk/  || $lvResults[$counter]=~/vpath/) && $counter<$totalSize-5)    {      print "$lvResults[$counter], ";      $moreComing++;    }    if (($lvResults[$counter]=~/hdisk/ || $lvResults[$counter]=~/vpath/) && $counter>($totalSize-5))    {      if ($moreComing>0)      {        print "and ";      }      print "$lvResults[$counter]. ";    }    $counter++;  }  print "\n";}print "LSLVMembers: Spinning down..\n\n";</pre>
</article>
<article>
<h1>CeilingReport (bpoag)</h1>
<pre class="block_code">#!/usr/bin/perl### ceilingreport.pl written 022806:1022 by BJP###### This script examines how many free PPs remain in each volume group.@vgs=`lsvg -L`;$hostName=`hostname`;chomp($hostName);foreach $i (@vgs){        chomp($i);        $numFree=`lsvg -L $i| grep FREE`;        $numFree=~/PPs:/;        $numFree=$';        chomp($numFree);        $numFree=~s/^\s+//g;        print "CeilingReport (on $hostName): $i has $numFree PPs remaining.\n";}</pre>
</article>
<article>
<h1>Exchange to Postfix firewall Configuration (madbombX)</h1>
<pre class="block_code">#!/usr/bin/perl -wuse strict;use Benchmark;use Config::ApacheFormat;use Fcntl qw(:flock);use Getopt::Std qw(getopts);use Log::Log4perl qw(get_logger :levels);use Net::hostent;use Net::LDAP;use Net::LDAP::Control::Paged;use Net::LDAP::Constant ( "LDAP_CONTROL_PAGED" );use Parallel::ForkManager;use POSIX qw(strftime);use Socket;use vars qw(  %opt  @Server @addresses @ldap_args @mynetworks @_t  $LOG $_appender $_layout $_pm  $HEAD  $config $domains $ldap $relay_domains);sub Bench_Begin();sub Bench_End();sub Create_PID();sub Die_Clean($$);sub GetExchange($);sub GetNitix($);sub Setup_Defaults();sub Setup_ForkManager($);sub Setup_Log();sub Usage();sub Version();sub Write_Networks($);sub Write_Relay_Domains($);sub Write_Relay_Recipients($);sub Write_SenderScores($);sub Write_Transport($);################################################################################# DO NOT EDIT BELOW HERE!!!#   Unless you are hacking up the script :)################################################################################ # Just in case we get through the whole script Bench_Begin(); # Get the options from the command line getopts('c:hl:s:V',\%opt); # Parse the options and do Usage/Version when necessary Usage() if $opt{'h'}; Version() if $opt{'V'}; $config = Config::ApacheFormat->new( expand_vars=>1,hash_directives =>[qw( PostfixBase )],valid_blocks=>[qw( Server )]     ); # Use the new config file if its specified if ($opt{'c'}) { $config->read($opt{'c'}); } else { $config->read("/etc/getcrr.conf")   or die "Config File: $!"; } Setup_Log(); Create_PID(); Setup_ForkManager($config->get("MaxProc")); Setup_Defaults();# Log completed initialization@Server = $config->get("Server");$LOG->info("Loaded ". ($#Server + 1) ." Total Servers");# Iterate over our Server hashforeach my $sid (@Server) {  my $host = $config->block($sid);  # Skip it if the record's ACTIVE boolean is < 1  if ($host->get("Active") < 0) {    $LOG->info("Skipping Record: ". join(" ",$host->get("Company")) ." - ". $host->get("Host"));    next;  } elsif ($host->get("Active") == 1) {    push @mynetworks,      "/^". inet_ntoa(inet_aton($host->get("Host"))) ."\\/32\$/OK\n";  }   # Fork off the children and get going on the queries  my $pid = $_pm->start($host) and next;   if ($host->get("Type") =~ /Exchange/) { GetExchange($host); }  elsif ($host->get("Type") =~ /Nitix/) { GetNitix($host); }  else {    $LOG->error(join(" ",$host->get("Company")). ": '". $host->get("Type") ."' is unknown server type.");    $_pm->finish;  }  # Closing the forked process  $_pm->finish;}# Ensure all the child processes finish$_pm->wait_all_children; # Generate all the Postfix Files Write_Networks($config->get("MyNetworks")); Write_Relay_Domains($config->get("RelayDomains")); Write_Transport($config->get("TransportMaps")); Write_Relay_Recipients($config->get("RelayRecipients")); Write_SenderScores($config->get("SenderScoresFile"))   if ($config->get("SenderScoresFile"));# We're done, so remove the PID file.unlink $config->get("PIDFile");$LOG->debug("Removed PID file:". $config->get("PIDFile")); Bench_End();################################################################################# DESCRIPTION:Does the Benchmark open and logs it to the $LOG# PARAMETERS:None# RETURN:Nothing# NOTES:################################################################################sub Bench_Begin(){  $_t[1] = new Benchmark;}################################################################################# DESCRIPTION:Does the Benchmark diff and writes it to $LOG# PARAMETERS:None# RETURN:Nothing# NOTES:################################################################################sub Bench_End(){  $_t[2] = new Benchmark;  $_t[0] = timediff($_t[2], $_t[1]);  $LOG->info("$0 took: ". timestr($_t[0]));}################################################################################# DESCRIPTION:Creates the PID file if it doesn't alreay exist# PARAMETERS:None# RETURN:Nothing# NOTES:Dies if PIDFile exists################################################################################sub Create_PID(){   Die_Clean("$0 is already running or ended improperly",            "$0 is already running or ended improperly.\n".               "Either delete ". $config->get("PIDFile") ."or wait for the process to end.\n")    if (-e $config->get("PIDFile"));  open (PID, ">".$config->get("PIDFile"));  print PID $$;  close (PID);  $LOG->debug("Created PID file: ". $config->get("PIDFile"));}################################################################################# DESCRIPTION:Removes the PID file and dies with @param text# PARAMETERS:Text of $LOG->fatal(), Text of die()# RETURN:Nothing# NOTES:################################################################################sub Die_Clean($$){  my ($fatal, $die) = @_;  $LOG->fatal($fatal);  unlink $config->get("PIDFile");  $LOG->debug("Removed PID file: ". $config->get("PIDFile"));  Bench_End();  die($die);}################################################################################# DESCRIPTION:Queries Exchange Server for email addresses# PARAMETERS:$host hash# RETURN:Nothing# NOTES:################################################################################sub GetExchange($){  my $host = shift;  # Connecting to Active Directory domain controllers  $LOG->debug("Beginning ". join(" ",$host->get("Company")));  unless ($ldap = Net::LDAP->new($host->get("IP"))) {    $LOG->warn($host->get("Host"). ": Error connecting to specified domain controllers $@ \n");    $_pm->finish;    next;  }  my $mesg = $ldap->bind ( dn => $host->get("User"),                          password => $host->get("Pass"));  if ( $mesg->code()) {      $LOG->warn ($host->get("Host"). ":\n". "error:", $mesg->code(),"\n","error name: ",$mesg->error_name(),          "\n", "error text: ",$mesg->error_text(),"\n");      $_pm->finish;      next;  }  # How many LDAP query results to grab for each paged round  # Set to under 1000 for Active Directory  my $page = Net::LDAP::Control::Paged->new( size => 990 );  @ldap_args = (   base     => $host->get("Base"),# Change to grab various objects (Contacts, Public Folders, etc.)# A minimal filter for just users with email would be:# filter => "(&(sAMAccountName=*)(mail=*))"        filter => "(& (mailnickname=*) (| (&(objectCategory=person)                      (objectClass=user)(!(homeMDB=*))(!(msExchHomeServerName=*)))                      (&(objectCategory=person)(objectClass=user)(|(homeMDB=*)                      (msExchHomeServerName=*)))(&(objectCategory=person)(objectClass=contact))                      (objectCategory=group)(objectCategory=publicFolder) ))",        control  => [ $page ],        attrs  => "proxyAddresses",  );  my $cookie;  while(1) {    # Perform search    $LOG->debug(join(" ",$host->get("Company")). ": Performming Search");    my $mesg = $ldap->search( @ldap_args );    $LOG->debug(join(" ",$host->get("Company")). ": Search Completed");    # Setup filenames and open the files    my $DC_DOMAIN = $config->get("Libdir"). "/". $host->get("Host") ."_domain";    my $DC_RECIPIENT = $config->get("Libdir"). "/". $host->get("Host") ."_recipients";    my $DC_TRANSPORT = $config->get("Libdir"). "/". $host->get("Host") ."_transport";    open DC_DOMAIN, ">$DC_DOMAIN";    open DC_RECIPIENT, ">$DC_RECIPIENT";    open DC_TRANSPORT, ">$DC_TRANSPORT";    $LOG->debug(join(" ",$host->get("Company")). ": Opened Lib Files");    # Print the headers for each file    print DC_DOMAIN $HEAD; print DC_RECIPIENT $HEAD; print DC_TRANSPORT $HEAD;    # Filtering results for proxyAddresses attributes      $LOG->debug(join(" ",$host->get("Company")). ": Filtering Results");    foreach my $entry ( $mesg->entries ) {      my $name = $entry->get_value( "cn" );      # LDAP Attributes are multi-valued, so we have to print each one.      foreach my $mail ( $entry->get_value( "proxyAddresses" ) ) {        # Test if the Line starts with one of the following lines:        # proxyAddresses: [smtp|SMTP]:        # and also discard this starting string, so that $mail is only the        # address without any other characters...        if ( $mail =~ s/^(smtp|SMTP)://gs ) {          # Escape '/' in addresses      $mail =~ s/\//\\\//g;  # Split the address into domains to build the relay_domains file  my ($u, $domain) = split ('@', $mail);  $relay_domains->{$domain} = $host->get("Host");  # Address the address to the array          print DC_RECIPIENT "/^". $mail ."\$/OK\n";         }      }    }    $LOG->debug(join(" ",$host->get("Company")). ": Wrote out $DC_RECIPIENT");        # Create the $DC_DOMAIN file    foreach my $dom ( keys %{$relay_domains} ) {      print DC_DOMAIN   "/$dom\$/OK\n"."/\\.?$dom\$/OK\n";       print DC_TRANSPORT  "/$dom\$/smtp:[". $host->get("IP") ."]\n".        "/\\.?$dom\$/smtp:[". $host->get("IP") ."]\n";    }    undef $relay_domains;    $LOG->debug(join(" ",$host->get("Company")). ": Wrote out $DC_DOMAIN");    $LOG->debug(join(" ",$host->get("Company")). ": Wrote out $DC_TRANSPORT");    close DC_DOMAIN; close DC_RECIPIENT; close DC_TRANSPORT;    $LOG->debug(join(" ",$host->get("Company")). ": Closed Lib Files");    # Only continue on LDAP_SUCCESS    $mesg->code and last;    # Get cookie from paged control    my($resp)  = $mesg->control( LDAP_CONTROL_PAGED ) or last;    $cookie    = $resp->cookie or last;    # Set cookie in paged control    $page->cookie($cookie);    $LOG->debug(join(" ",$host->get("Company")). ": Completed");  }  if ($cookie) {    # We had an abnormal exit, so let the server know we do not want any more    $page->cookie($cookie);    $page->size(0);    $ldap->search( @ldap_args );    $LOG->warn(join(" ",$host->get("Company")). ": LDAP query unsuccessful");    $_pm->finish;  }  # Completed a server  $LOG->debug(join(" ",$host->get("Company")). ": Completed");}################################################################################# DESCRIPTION:Sets up global program defaults# PARAMETERS:None# RETURN:Nothing# NOTES:################################################################################sub Setup_Defaults(){  # Prepare and write the file header  my ($now) = strftime("%Y-%b-%d %H:%M:%S ", localtime(time));  $HEAD =  <<HEAD;# File automatically generated# DO NOT EDIT BY HAND.  YOUR CHANGES WILL BE LOST.# Last created on: $nowHEAD  # Add the localhost class to @mynetworks  push @mynetworks,"/^127.0.0.0\\/8\$/OK\n";  return;}################################################################################# DESCRIPTION:Sets up everything for $LOG# PARAMETERS:None# RETURN:Help text to STDOUT# NOTES:################################################################################sub Setup_Log(){ # Setup the logging functionality # Logging Levels: WARN,DEBUG,ERROR,INFO,FATAL $LOG = get_logger(); $LOG->level($INFO); $LOG->level($DEBUG) if ($config->get("Debug")); $_appender = Log::Log4perl::Appender->new(   "Log::Dispatch::File",   filename => $config->get("LogFile"),   mode   => "append", ); # Create the log formatting $_layout = Log::Log4perl::Layout::PatternLayout->new(   "%d{MMM dd HH:mm:ss} %p> %F{1}[%P]: %L: %m%n"); $LOG->add_appender($_appender); $_appender->layout($_layout); return;}################################################################################# DESCRIPTION:Sets up everything for the Parallel Forkmanager# PARAMETERS:None# RETURN:Nothing# NOTES:################################################################################sub Setup_ForkManager($){ # Begin ForkManager my $_max_procs = shift; $_pm = new Parallel::ForkManager($_max_procs);  # Log at process fork $_pm ->run_on_start(   sub { my ($pid, $host) = @_;     $LOG->debug("Forking process PID: $pid\n");   } );  # Log at process copmletion $_pm ->run_on_finish(   sub { my ($pid, $exit_code, $host) = @_;     $LOG->debug("Finishing up process PID: $pid\n");   } );  $_pm->run_on_wait(   sub {     $LOG->debug("Waiting for children to finish")   },   5.0 ); $LOG->debug("ForkManger initialized"); return;} ################################################################################# DESCRIPTION:Prints the Usage Menu to STDOUT# PARAMETERS:None# RETURN:Help text to STDOUT# NOTES:################################################################################sub Usage(){  print <<USAGE;$0 -chV   -cUse this config file (default: /etc/config/getcrr.conf)  -hPrints out this help menu  -VPrints out version informationUSAGEexit(0);}################################################################################# DESCRIPTION:Prints the Version to STDOUT# PARAMETERS:None# RETURN:Version text to STDOUT# NOTES:################################################################################sub Version(){  my $VERSION = do { my @r = (q$Revision: 1.6 $ =~ /\d+/g); sprintf "%d."."%03d" x $#r, @r };  print <<VERSION;Get Concurrent Relay Recipients v$VERSIONVERSIONexit(0);}################################################################################# DESCRIPTION:Write the NETWORKS file# PARAMETERS:Location of MyNetworks map# RETURN:Nothing# NOTES:################################################################################sub Write_Networks($){  my $NETWORKS = shift;  open NETWORKS, ">$NETWORKS" or    Die_Clean("Error Opening $NETWORKS: $!", "Error Opening $NETWORKS: $!");  # Lock the file  flock NETWORKS, LOCK_EX;  print NETWORKS $HEAD;  print NETWORKS @mynetworks;  flock NETWORKS, LOCK_UN;  close NETWORKS;  $LOG->info("Wrote $NETWORKS");  return;}################################################################################# DESCRIPTION:Write the Relay_Domains file# PARAMETERS:Location of the RelayDomains map# RETURN:Nothing# NOTES:################################################################################sub Write_Relay_Domains($){  my $DOMAINS = shift;  my (@exclude_domains);  # Begin iterating over the domain files in the directory  $LOG->debug("Creating $DOMAINS file");    # Only write the file once all the queries are successful  open DOMAINS, ">$DOMAINS" or    Die_Clean("Cannot Open $DOMAINS: $!", "Cannot Open $DOMAINS: $!");    # Lock the file  flock DOMAINS, LOCK_EX;    print DOMAINS $HEAD;    foreach my $sid (@Server) {    my $host = $config->block($sid);    @exclude_domains = $host->get("ExcludeDomain");    next if $host->get("Active") == -1;    $LOG->debug("Processing ". $host->get("Host") ."_domain file");    open DC_DOMAIN, $config->get("Libdir") ."/". $host->get("Host") ."_domain"      or do {        $LOG->warn("Error opening file: ". $config->get("Libdir") ."/". $host->get("Host") ."_domain");        next;        };    while (my $line = <DC_DOMAIN>) {      next unless $line =~ /^\/.*$/;      my $domain = $1 if ($line =~ /^\/\.?(.*)\$\/.*$/);      print DOMAINS $line        unless (grep { m/$domain/ } @exclude_domains );    }    close DC_DOMAIN;  }    flock DOMAINS,LOCK_UN;  close DOMAINS;    $LOG->info("Wrote $DOMAINS");  return;}################################################################################# DESCRIPTION:Write the Relay_Recipients file# PARAMETERS:None# RETURN:Nothing# NOTES:################################################################################sub Write_Relay_Recipients($){  my $RECIP = shift;  my (@exclude_domains);  $LOG->debug("Creating $RECIP file");    # Only write the file once all the queries are successful  open RECIP, ">$RECIP" or    Die_Clean("Cannot Open $RECIP: $!", "Cannot Open $RECIP: $!");    # Lock the file  flock RECIP, LOCK_EX;    print RECIP $HEAD;  foreach my $sid (@Server) {    my $host = $config->block($sid);    @exclude_domains = $host->get("ExcludeDomain");    next if $host->get("Active") == -1;    $LOG->debug("Processing ". $host->get("Host") ."_recipients file");    open DC_RECIP, $config->get("Libdir") ."/". $host->get("Host") ."_recipients"      or do {        $LOG->warn("Error opening file: ". $config->get("Libdir") ."/". $host->get("Host") ."_recipients");        next;        };    while (my $line = <DC_RECIP>) {      next unless $line =~ /^\/.*$/;      my ($user,$domain) = ($1,$2) if ($line =~ /^\/\^(.*?)\@(.*?)\$\/.*OK$/);      do {        print RECIP $line;        $domains->{$domain} = 1;      } unless (grep { m/$domain/ } @exclude_domains );    }    close DC_RECIP;  }    print RECIP "\n\n".      "# REJECT all other emails not destined for a user in our domains.\n".      "\n";  foreach my $dom ( keys %{$domains} ) {    $dom =~ s/OK/REJECT/;    print RECIP "/^.*\@$dom\$/REJECT\n";  }  flock RECIP, LOCK_UN;  close RECIP;    $LOG->info("Wrote $RECIP");    return;}################################################################################# DESCRIPTION:Prints the SPAM recipients to the SPAM hash file# PARAMETERS:Hash of domains to be added# RETURN:Nothing# NOTES:################################################################################sub Write_SenderScores($){  my $SCORES = shift;  $LOG->debug("Creating $SCORES file");    # Only write the file once all the queries are successful  open SCORES, ">$SCORES" or    Die_Clean("Cannot Open $SCORES: $!", "Cannot Open $SCORES: $!");    # Lock the file  flock SCORES, LOCK_EX;    print SCORES $HEAD;  foreach my $sid (@Server) {    my $host = $config->block($sid);    next if $host->get("Active") == -1;    $LOG->debug("Processing ". $host->get("Host") ."_recipients file");    open DC_SCORES, $config->get("Libdir") ."/". $host->get("Host") ."_recipients"      or do {        $LOG->warn("Error opening file: ". $config->get("Libdir") ."/". $host->get("Host") ."_recipients");        next;        };    while (my $line = <DC_SCORES>) {      next unless $line =~ /^\/.*$/;      my ($user,$domain) = ($1,$2) if ($line =~ /^\/\^(.*?)\@(.*?)\$\/.*OK$/);      # The format of the SPAM_SITES file      # .example.com-4.0      print SCORES "$user\@$domain". $config->get("WLSenderScore") ."\n";      $domains->{$domain} = 1;    }    close DC_SCORES;  }  # Add the whitelist and blacklist sender specified in the config file  my (@wl) = $config->get("WLSenders");  my (@bl) = $config->get("BLSenders");  do {    print SCORES "\n\n".  "# Additional Whitelist senders\n";    foreach my $sender (@wl) {      print SCORES "$sender". $config->get("WLSenderScore") ."\n";    }   } if ($config->get("WLSenderScore"));  do {    print SCORES "\n\n".    "# Additional Blacklist senders\n";    foreach my $sender (@bl) {      print SCORES "$sender". $config->get("BLSenderScore") ."\n";    }  } if ($config->get("BLSenderScore"));    print SCORES "\n\n".      "# SCORES all other emails seemingly from a user in one of our domains.\n".      "\n";  foreach my $dom ( keys %{$domains} ) {    print SCORES ".$dom". $config->get("BLLocalSenderScore") ."\n"    unless ($dom =~ /\$\//);  }  flock SCORES, LOCK_UN;  close SCORES;    $LOG->info("Wrote $SCORES");    return;}################################################################################# DESCRIPTION:Write the TRANSPORT file# PARAMETERS:Location of the Transport map# RETURN:Nothing# NOTES:################################################################################sub Write_Transport($){  my $TRANSPORT = shift;  my (@exclude_domains);  $LOG->debug("Creating $TRANSPORT file");    # Only write the file once all the queries are successful  open TRANSPORT, ">$TRANSPORT" or    Die_Clean("Cannot Open $TRANSPORT: $!", "Cannot Open $TRANSPORT: $!");    # Lock the file  flock TRANSPORT, LOCK_EX;    print TRANSPORT $HEAD;  foreach my $sid (@Server) {    my $host = $config->block($sid);    @exclude_domains = $host->get("ExcludeDomain");    next if $host->get("Active") == -1;    $LOG->debug("Processing ". $host->get("Host") ."_transport file");    open DC_TRANSPORT, $config->get("Libdir") ."/". $host->get("Host") ."_transport"      or do {        $LOG->warn("Error opening file: ". $config->get("Libdir") ."/". $host->get("Host") ."_transport");        next;        };    while (my $line = <DC_TRANSPORT>) {      next unless $line =~ /^\/.*$/;      my $domain = $1 if ($line =~ /^\/\.?(.*)\$\/.*$/);      print TRANSPORT $line        unless (grep { m/$domain/ } @exclude_domains );    }    close DC_TRANSPORT;  }  my (@bmx) = $config->get("BackupMX");  do {    print TRANSPORT "\n\n".       "# Secondary MX Records\n\n";    foreach my $server (@bmx) {      print TRANSPORT "/^.*\$/relay:[$server]\n";    }   } if ($config->get("BackupMX"));    flock TRANSPORT, LOCK_UN;  close TRANSPORT;    $LOG->info("Wrote $TRANSPORT");    return;}1;</pre>
</article>
<article>
<h1>Job schedule task inventory (shonorio)</h1>
<pre class="block_code">################################################################################# Program     : Job Iventory# Description : Do a job inventory on all computers passed by command line, and#               output theses job information as tab formated.# Author      : Solli M. Honorio shonorio[at]perl[dot]org[dot]br# License     : under the GPL (GNU Public License)################################################################################use Win32::TaskScheduler;use strict;######################################################################################################## G L O B A L  V A R I A B L E S ########################my %status_code = ( '267008' => 'Ready',                    '267009' => 'Running',                    '267010' => 'Disabled',                    '267011' => 'Has not run',                    '267012' => 'No more runs scheduled',                    '267013' => 'Not scheduled',                    '267014' => 'Terminated by User',                    '267015' => 'No valid triggers',                    '267016' => 'Event triggers dont have set run times',                    '267017' => 'Trigger not found',                    '267018' => 'Properties not all set',                    '267019' => 'No running task to terminate',                    '267020' => 'Task scheduler not installed',                    '267021' => 'Can not open task',                    '267022' => 'Invalid task',                    '267023' => 'No account information defined',                    '267024' => 'Acount name not found',                    '267025' => 'Account DB corrupt',                    '267026' => 'Security services only on NT',                    '267027' => 'Unknown object version' );my %trigger_type = ( 0 => 'Once',                     1 => 'Daily',                     2 => 'Weekly',                     3 => 'Monthly Date',                     4 => 'Monthly Dow',                     5 => 'On idle',                     6 => 'At SystemStart',                     7 => 'At Logon');my %days_of_week = ( '01' => 'Sunday',                     '02' => 'Monday',                     '04' => 'Tuesday',                     '08' => 'Wednesday',                     '16' => 'Thursday',                     '32' => 'Friday',                     '64' => 'Saturday');my %months       = ( '0001' => 'January',                     '0002' => 'February',                     '0004' => 'March',                     '0008' => 'April',                     '0016' => 'May',                     '0032' => 'June',                     '0064' => 'July',                     '0128' => 'August',                     '0256' => 'September',                     '0512' => 'October',                     '1024' => 'November',                     '2048' => 'December');my %which_week = (  1 => 'Fist week',                    2 => 'Second week',                    3 => 'Third week',                    4 => 'Fourth week',                    5 => 'Last week' );######################## G L O B A L  V A R I A B L E S ############################################################################################################################################################################################################### D O   J O B   I N V E N T O R Y ########################my %jobs_processed;for ( @ARGV ) {    if ( my @array = get_job_info ($_) ) {        @{$jobs_processed{$_}} = @array;    }}####################### D O   J O B   I N V E N T O R Y ############################################################################################################################################################################################################## O U T P U T   I N F O R M A T I O N #####################print "Computer\t";print "Job_Name\t";print "Application_Name\t";print "Parameters\t";print "WorkDirectory\t";print "Comment\t";print "MostRecentRunTime\t";print "NextRunTime\t";print "MaxRunTime\t";print "Priority\t";print "Status\t";print "User\t";print "Creator\t";print "Error\t";print "Flag_Delete when done\t";print "Flag_Disabled}\t";print "Flag_Dont start if on batteries\t";print "Flag_Hidden\t";print "Flag_Interactive\t";print "Flag_Kill if going on batteries\t";print "Flag_Kill on idle end\t";print "Flag_Restart on idle resume\t";print "Flag_Run if connected to internet\t";print "Flag_Run only if docked\t";print "Flag_Start only if idle\t";print "Flag_System required\t";print "Trigger_String\t";print "Trigger_Type\t";print "Trigger_StartDay\t";print "Trigger_EndDay\t";print "Trigger_StartTime\t";print "Trigger_Duration\t";print "Trigger_Interval\t";print "Trigger_Schedule_DaysInterval\t";print "Trigger_Schedule_WeeksInterval\t";print "Trigger_Schedule_WeeksDays\t";print "Trigger_Schedule_Days\t";print "Trigger_Schedule_WhichWeek\t";print "Trigger_Schedule_Months\n";foreach my $cp ( sort keys %jobs_processed ) {    foreach my $job ( @{$jobs_processed{$cp}} ) {        foreach my $idx ( sort keys %{$job->{Trigger}} ) {            print "$cp\t";            print "$job->{Name}\t";            print "$job->{AppName}\t";            print "$job->{Parameters}\t";            print "$job->{WorkDirectory}\t";            print "$job->{Comment}\t";            print "$job->{MostRecentRunTime}\t";            print "$job->{NextRunTime}\t";            print "$job->{MaxRunTime}\t";            print "$job->{Priority}\t";            print "$job->{Status}\t";            print "$job->{User}\t";            print "$job->{Creator}\t";            print "$job->{Error}\t";            print "$job->{Flag}->{'Delete when done'}\t";            print "$job->{Flag}->{Disabled}\t";            print "$job->{Flag}->{'Dont start if on batteries'}\t";            print "$job->{Flag}->{Hidden}\t";            print "$job->{Flag}->{Interactive}\t";            print "$job->{Flag}->{'Kill if going on batteries'}\t";            print "$job->{Flag}->{'Kill on idle end'}\t";            print "$job->{Flag}->{'Restart on idle resume'}\t";            print "$job->{Flag}->{'Run if connected to internet'}\t";            print "$job->{Flag}->{'Run only if docked'}\t";            print "$job->{Flag}->{'Start only if idle'}\t";            print "$job->{Flag}->{'System required'}\t";            print "$job->{Trigger}{$idx}{String}\t";            print "$job->{Trigger}{$idx}{Type}\t";            print "$job->{Trigger}{$idx}{StartDay}\t";            print "$job->{Trigger}{$idx}{EndDay}\t";            print "$job->{Trigger}{$idx}{StartTime}\t";            print "$job->{Trigger}{$idx}{Duration}\t";            print "$job->{Trigger}{$idx}{Interval}\t";            print "$job->{Trigger}{$idx}{Schedule}{DaysInterval}\t";            print "$job->{Trigger}{$idx}{Schedule}{WeeksInterval}\t";            print "$job->{Trigger}{$idx}{Schedule}{WeeksDays}\t";            print "$job->{Trigger}{$idx}{Schedule}{Days}\t";            print "$job->{Trigger}{$idx}{Schedule}{WhichWeek}\t";            print "$job->{Trigger}{$idx}{Schedule}{Months}\n";        }    }}###################### O U T P U T   I N F O R M A T I O N #####################################################################################################sub get_job_info {    my $computer_name = shift;    my $scheduler     = Win32::TaskScheduler->New();    my @jobs;        if ( $scheduler->SetTargetComputer("\\\\$computer_name") ) {        foreach my $job_name ( $scheduler->Enum() ) {            my %job;            $job_name  =~ s/\.job$//i;            $job{Name} = $job_name;                    if ( $scheduler->Activate($job{Name}) ) {                my ( $pri, $status, $error, $flags, $time_milli_seconds );                $scheduler->GetPriority($pri);                $scheduler->GetStatus($status);                $scheduler->GetExitCode($error);                $flags = $scheduler->GetFlags();                $job{Flag}{'Interactive'}                  = ( $flags & $scheduler->TASK_FLAG_INTERACTIVE ) ? 1 : 0;                $job{Flag}{'Delete when done'}             = ( $flags & $scheduler->TASK_FLAG_DELETE_WHEN_DONE ) ? 1 : 0;                $job{Flag}{'Disabled'}                     = ( $flags & $scheduler->TASK_FLAG_DISABLED ) ? 1 : 0;                $job{Flag}{'Start only if idle'}           = ( $flags & $scheduler->TASK_FLAG_START_ONLY_IF_IDLE ) ? 1 : 0;                $job{Flag}{'Kill on idle end'}             = ( $flags & $scheduler->TASK_FLAG_KILL_ON_IDLE_END ) ? 1 : 0;                $job{Flag}{'Dont start if on batteries'}   = ( $flags & $scheduler->TASK_FLAG_DONT_START_IF_ON_BATTERIES ) ? 1 : 0;                $job{Flag}{'Kill if going on batteries'}   = ( $flags & $scheduler->TASK_FLAG_KILL_IF_GOING_ON_BATTERIES ) ? 1 : 0;                $job{Flag}{'Run only if docked'}           = ( $flags & $scheduler->TASK_FLAG_RUN_ONLY_IF_DOCKED ) ? 1 : 0;                $job{Flag}{'Hidden'}                       = ( $flags & $scheduler->TASK_FLAG_HIDDEN ) ? 1 : 0;                $job{Flag}{'Run if connected to internet'} = ( $flags & $scheduler->TASK_FLAG_RUN_IF_CONNECTED_TO_INTERNET ) ? 1 : 0;                $job{Flag}{'Restart on idle resume'}       = ( $flags & $scheduler->TASK_FLAG_RESTART_ON_IDLE_RESUME ) ? 1 : 0;                $job{Flag}{'System required'}              = ( $flags & $scheduler->TASK_FLAG_SYSTEM_REQUIRED ) ? 1 : 0;                if ( $pri eq $scheduler->REALTIME_PRIORITY_CLASS ) {                    $job{Priority} = 'Real time';                } elsif ( $pri eq $scheduler->HIGH_PRIORITY_CLASS ) {                    $job{Priority} = 'High';                } elsif ( $pri eq $scheduler->NORMAL_PRIORITY_CLASS ) {                    $job{Priority} = 'Normal';                } elsif ( $pri eq $scheduler->IDLE_PRIORITY_CLASS ) {                    $job{Priority} = 'Idle';                } else {                    $job{Priority} = 'Unknown';                }                            $job{User}              = $scheduler->GetAccountInformation();                $job{AppName}           = $scheduler->GetApplicationName();                $job{Parameters}        = $scheduler->GetParameters();                $job{WorkDirectory}     = $scheduler->GetWorkingDirectory();                $job{Status}            = $status_code{$status};                $job{Error}             = $error;                $job{Comment}           = $scheduler->GetComment();                $job{Creator}           = $scheduler->GetCreator();                $job{NextRunTime}       = format_hour($scheduler->GetNextRunTime());                $job{MostRecentRunTime} = format_hour($scheduler->GetMostRecentRunTime());                if ( ( $time_milli_seconds = $scheduler->GetMaxRunTime() ) > -1 ) {                    my ($hours, $minutes, $secounds);                    $secounds = $time_milli_seconds / 1000;                    $hours    = int ( $secounds / 3600 );                    $minutes  = int ( ( $secounds - ( $hours * 3600 ) ) / 60 );                    $secounds = int ( ( $secounds - ( ( $hours * 3600 ) + ( $minutes * 60 ) ) ) );                    $job{MaxRunTime} = sprintf "%d:%02d:%02d",$hours,$minutes,$secounds;                }                for ( my $idx = 0; $idx < $scheduler->GetTriggerCount(); $idx++ ) {                    my ( %trigger );                    $scheduler->GetTrigger( $idx, \%trigger );                    $job{Trigger}{$idx}{String}    = $scheduler->GetTriggerString($idx);                    $job{Trigger}{$idx}{Type}      = $trigger_type{$trigger{"TriggerType"}};                    $job{Trigger}{$idx}{StartDay}  = sprintf "%04d-%02d-%02d", $trigger{BeginYear}, $trigger{BeginMonth}, $trigger{BeginDay};                    $job{Trigger}{$idx}{EndDay}    = sprintf "%04d-%02d-%02d", $trigger{EndYear}, $trigger{EndMonth}, $trigger{EndDay};                    $job{Trigger}{$idx}{StartTime} = sprintf "%02d:%02d", $trigger{StartHour}, $trigger{StartMinute};                    $job{Trigger}{$idx}{Duration}  = sprintf "%02d:%02d", ( int $trigger{MinutesDuration} / 60 ),                                                                          ( $trigger{MinutesDuration} - ( ( int $trigger{MinutesDuration} / 60 ) ) * 60 );                    $job{Trigger}{$idx}{Interval}  = sprintf "%02d:%02d", ( int $trigger{MinutesInterval} / 60 ),                                                                          ( $trigger{MinutesInterval} - ( ( int $trigger{MinutesInterval} / 60 ) ) * 60 );                    if ( $trigger{"Type"} ) {                        # build a schedule structure                        if ( $trigger{'TriggerType'} == $scheduler->TASK_TIME_TRIGGER_DAILY ) {                            $job{Trigger}{$idx}{Schedule}{DaysInterval} = $trigger{'Type'}{DaysInterval};                        } elsif ( $trigger{'TriggerType'} == $scheduler->TASK_TIME_TRIGGER_WEEKLY ) {                            $job{Trigger}{$idx}{Schedule}{WeeksInterval} = $trigger{'Type'}{WeeksInterval};                            # do a loop and return the list of week days                            $job{Trigger}{$idx}{Schedule}{WeeksDays}     = join ',', map { ( $_ & $trigger{'Type'}{DaysOfTheWeek} ) ? $days_of_week{$_} : () } sort keys %days_of_week;                        } elsif ( $trigger{"TriggerType"} == $scheduler->TASK_TIME_TRIGGER_MONTHLYDATE ) {                            $job{Trigger}{$idx}{Schedule}{Days}   = $trigger{'Type'}{Days};                            # do a loop and return the list of months                            $job{Trigger}{$idx}{Schedule}{Months} = join ',', map { ( $_ & $trigger{'Type'}{Months} ) ? $months{$_} : () } sort keys %months;                        } elsif ( $trigger{"TriggerType"} == $scheduler->TASK_TIME_TRIGGER_MONTHLYDOW ) {                            $job{Trigger}{$idx}{Schedule}{WhichWeek} = $which_week{$trigger{'Type'}{WhichWeek}};                             $job{Trigger}{$idx}{Schedule}{WeeksDays} = $days_of_week{$trigger{'Type'}{DaysOfTheWeek}};                            # do a loop and return the list of months                            $job{Trigger}{$idx}{Schedule}{Months} = join ',', map { ( $_ & $trigger{'Type'}{Months} ) ? $months{$_} : () } sort keys %months;                        }                    }                }                push @jobs, \%job;            } else {                print STDERR "Could not activate the job $job{Name} at computer $computer_name\n";            }        }        $scheduler->End();        return @jobs;    } else {        print STDERR "Could not connect the computer $computer_name\n";        return ();    }}sub format_hour {    my ($ms, $sec, $min, $hour, $day, $dayofweek, $month, $year) = @_;    return sprintf "%04d-%02d-%02d %02d:%02d:%02d",$year,$month,$day,$hour,$min,$sec;}</pre>
</article>
<article>
<h1>Another Server Info Snooper (AsIs) ;) (Alexander)</h1>
<pre class="block_code">#!/usr/bin/perl -w# bourne.pl "monkified" v1.0# bart lines 5 & 29, and theorbtwo for ! delimiters line 36use strict;############## note: six assumptions are made here...## 1) $USER legal characters are alphanumeric, "_", or "-"## 2) $USER is between 3 and 16 characters in length## 3) your default shell is a bourne-like shell (like bash)## 4) you know enough bourne shell to not get in trouble## 5) your $HOME directory is /home/$USER## 6) you accept that you are using this at your own riskmy @cmds = split /\n/, <<'--CMDs--';##############  editwhoamipwdidecho \$PATH=$PATHecho \$PERL5LIB=$PERL5LIBperl -V############## no edit--CMDs--my $i=4;my $size=@cmds;my $me=`whoami`;my $dir=`pwd`;$me=~s/\n//;$dir=~s/\n//;$dir=~s!\/home\/[\w-]{3,16}\/!\/!;my $prompt="$me\@~$dir>";print "Content-type: text/plain\n\n";while ($i <= $size - 4) { my $cmd=$cmds[$i]; print $prompt,"$cmd\n",`$cmd`,"\n"; $i++; }</pre>
</article>
<article>
<h1>Massage the driving directions (in USA) (parv)</h1>
<pre class="block_code">#!perl#  This program massages the driving directions (in USA) for plain text#  printing (preferably in monospace font, w/ a blank line between each non#  empty line), with these prioririties (in no particular order) ...#   - up-case road names, exit numbers, places#   - low-case everything else#   - expand n, w, e, s to north, west, east, south#   - shorten road type (like mailing address), e.g. 'road' to 'rd', 'lane' to#     'ln', etc.#   - removes the annoying 'go' from 'go <this much>'use warnings; use strict;my ( $geo_pos , $roads ) = ( get_geo_pos() , get_road() );my @relative_pos = map uc( $_ ) , qw(left middle center right) ;#  Got a better name for this variable?my $less_important_than_roads_places =  qr{ \b      ( bear | stay | head | continue | follow | go | take | turn       | entry | ramp | (?: to | fore? )w[oa]rds?       | on.?to | on | to | for | at | off?  | then | t?here | from       | an?d?       | (?: h(?:ou)?r | min(?:ute)? | second | moment )s?       | ph(?:one)? | fax | e.?mail | home | office | work | cell | mobile      )      \b    }xi;my $misc_edits =  {    'and' => '&'  , 'hour' => 'hr'  , 'minutes?' => 'min'  , 'seconds' => 'second'  , 'phone' => 'ph'  , 'fore?w[oa]rd' => 'forward'  , 'toword' => 'toward'  } ;{  local $^I = '' ;  while ( <> )  {    s{ \s+ the \s+ }/ /xig;    s{ \b go (?: \s+ for )? \s+ (\d) }/ $1/xige;    $_ = uc $_;    s{ (\d) \W* ( mi(?:le)? | ft) \b }/"$1~" . lc $2/xige;    s{ $less_important_than_roads_places }/lc $1/xige;    for my $map ( $roads , $geo_pos , $misc_edits )    {      while ( my ( $k , $v ) = each %$map )      {        s[ \b $k \b ]/$v/xig;      }    }    for my $r ( values %$roads )    {      s/\b $r \./$r/xig;    }    s/^[ \t]+//g;    s/[ \t]+$//g;    s/[ \t]+/ /g;    print;  }}sub get_geo_pos{  my @points =    qw(        east west north south        north-east north-west south-east south-west        east-north east-south west-north west-south      ) ;  my %points ;  foreach ( @points )  {    m{^ ([a-z])[a-z]+ (?: \W+ ( [a-z])[a-z]+ )? $}xi;    $points{ $2 ? "$1$2" : $1 } = uc $_ ;  }  return { %points };}sub get_road{  my %roads =    (      'avenue' => 'ave'    , 'av' => 'ave'    , 'circle' => 'crl'    , 'court' => 'ct'    , 'crt' => 'ct'    , 'drive' => 'dr'    , 'lane' => 'ln'    , 'pk' => 'pike'    , 'parkway' => 'pkwy'    , 'pky' => 'pkwy'    , 'road' => 'rd'    , 'route' => 'rt'    , 'street' => 'st'    , 'tpk' => 'turnpike'    , 'turn.?pk' => 'turnpike'    );  $_ = uc $_ for values %roads;  return { %roads };}</pre>
</article>
<article>
<h1>perltoxmi (g0n)</h1>
<pre class="block_code">#!/usr/bin/perluse strict;use warnings;################################################################################################################ perltoxmi - extract class definitions from oo perl code, and write out xmi for import into CASE tools# Charles Colbourn June 2006################################################################################################################# HISTORY## 0.01CColbourn20060616Rough first version################################################################################################################# TO DO## Error checking# Write to file instead of STDOUT# Clean up, abstract and make readable# detect require as well as use# detect double quoted attrib names just in case################################################################################################################# Usage# perltoxmi MyClass.pm MyOtherClass.pm > classes.xmi# OR# cat *.pm |perltoxmi >classes.xmi################################################################################################################# Notes## The XMI output is cut and pasted from ArgoUML output. Pretty it isn't, but it seems to work# Export your classes into xmi, then import xmi into Argo (works with v0.20 definitely). Can use 'add namespace# to class diagram', and 'layout' to do an initial layout.# It exports any classes included with 'use' but outside the files it's been passed as interfaces (which aren't# automatically added into class diagrams, handily - otherwise there would be hundreds of lines to 'strict')## It's a dirty, dirty hack, but it does what I need :-)################################################################################################################## 16 hex digits in countermy ($header,$classtemplate,$attribtemplate,$methodtemplate,$generalisetemplate,$footer,$interfacetemplate,$associationtemplate);{local $/ = '%%ENDOFTEMPLATE%%';$header = <DATA>;$classtemplate = <DATA>;$interfacetemplate = <DATA>;$attribtemplate = <DATA>;$methodtemplate = <DATA>;$generalisetemplate = <DATA>;$associationtemplate = <DATA>;$footer = <DATA>;}my $counter = 2000;my $package;my %obj;while (<>){if ($_ =~/package ([\w:]+);/){$package = $1;$obj{$1} = {};}if ($_=~/use\s+([\w\:]+);/){$obj{$package}{uses}{$1}++;}if ($_ =~/use base\s+(?:qw\(|\'|\")([\w\:\s]+)/){my (@parents) = $1=~/([\w\:]+)/g;for (@parents){$obj{$package}{parents}{$_}++}}if ($_ =~/sub\s+(\w+)/){#print $package."::".$1."\n";$obj{$package}{methods}{$1}++;}if ($_ =~/\$self->\{[\']*([\w\s]*)\}/){#print $package."->$1\n"$obj{$package}{attribs}{$1}++;}}my %classnametocounter;my %generalisations;my %associations;my $interfacexml;my %interfaces;my $xml = "";for $package (keys %obj){my $classprintcounter = sprintf("%016X",++$counter);my $class = $classtemplate;$class=~s/%%CLASSNAME%%/$package/g;$class=~s/%%COUNTER%%/$classprintcounter/g;my $attribsxml = "";for (keys %{$obj{$package}{attribs}}){my $attrib = $attribtemplate;$attrib=~s/%%ATTRIBNAME%%/$_/;my $printcounter = sprintf("%016X",++$counter);$attrib =~s/%%COUNTER%%/$printcounter/;my $visibility = "public";if ($_=~/^\_/){$visibility = "private"}$attrib =~s/%%VISIBILITY%%/$visibility/g;$attribsxml .= $attrib;}my $methodsxml = "";for (keys %{$obj{$package}{methods}}){my $method = $methodtemplate;$method=~s/%%METHODNAME%%/$_/;my $printcounter = sprintf("%016X",++$counter);$method =~s/%%COUNTER%%/$printcounter/;my $visibility = "public";if ($_=~/^\_/){$visibility = "private"}$method =~s/%%VISIBILITY%%/$visibility/g;$methodsxml .= $method;}$classnametocounter{$package} = $classprintcounter;for (keys %{$obj{$package}{parents}}){$generalisations{$package} = $_;}for (keys %{$obj{$package}{uses}}){$interfaces{$_}++;$associations{$package}{$_}++;}$class =~s/%%ATTRIBXML%%/$attribsxml/;$class =~s/%%METHODXML%%/$methodsxml/;$xml .= $class;}for my $intname (keys %interfaces){if ($obj{$intname}){next} # don't create an interface if the class is in read scopemy $printcounter = sprintf("%016X",++$counter);my $interface = $interfacetemplate;$interface=~s/%%INTERFACENAME%%/$intname/g;$interface=~s/%%COUNTER%%/$printcounter/g;$classnametocounter{$intname} = $printcounter;$xml .= $interface;}for (keys %generalisations){my $generalisation = $generalisetemplate;my $childcounter = $classnametocounter{$_};my $parentcounter = $classnametocounter{$generalisations{$_}};$generalisation =~s/%%CHILDCOUNTER%%/$childcounter/;$generalisation =~s/%%PARENTCOUNTER%%/$parentcounter/;my $printcounter = sprintf("%016X",++$counter);$generalisation =~s/%%COUNTER%%/$printcounter/;#take out the association - we don't want both a vanilla association and a generalisationif ($associations{$_}{$generalisations{$_}}){delete $associations{$_}{$generalisations{$_}}}$xml .= $generalisation;}for my $package(keys %associations){for my $association (keys %{$associations{$package}}){my $associationxml = $associationtemplate;my $usingclasscounter = $classnametocounter{$package};my $usedclasscounter = $classnametocounter{$association};$associationxml =~s/%%USINGCLASS%%/$usingclasscounter/;$associationxml =~s/%%USEDCLASS%%/$usedclasscounter/;my $printcounter = sprintf("%016X",++$counter);$associationxml =~s/%%COUNTER%%/$printcounter/;my $usedclassendcounter = sprintf("%016X",++$counter);$associationxml =~s/%%USEDENDCOUNTER%%/$usedclassendcounter/;my $usingclassendcounter = sprintf("%016X",++$counter);$associationxml =~s/%%USINGENDCOUNTER%%/$usingclassendcounter/;$xml .= $associationxml;}}# get rid of the template markers$xml=~s/%%ENDOFTEMPLATE%%//sg;$header =~s/%%ENDOFTEMPLATE%%//sg;$footer=~s/%%ENDOFTEMPLATE%%//sg;print $header."\n";print $xml;print $footer."\n";__DATA__<?xml version = '1.0' encoding = 'UTF-8' ?><XMI xmi.version = '1.2' xmlns:UML = 'org.omg.xmi.namespace.UML' timestamp = 'Thu Jun 15 12:59:02 BST 2006'>  <XMI.header>  <XMI.header>    <XMI.documentation>      <XMI.exporter>ArgoUML (using Netbeans XMI Writer version 1.0)</XMI.exporter>      <XMI.exporterVersion>0.20.x</XMI.exporterVersion>    </XMI.documentation>    <XMI.metamodel xmi.name="UML" xmi.version="1.4"/>  </XMI.header></XMI.header>  <XMI.content>    <UML:Model xmi.id = '.:0000000000000001' name = 'UNNAMED' isSpecification = 'false'      isRoot = 'false' isLeaf = 'false' isAbstract = 'false'>%%ENDOFTEMPLATE%%      <UML:Namespace.ownedElement>        <UML:Class xmi.id = '.:%%COUNTER%%' name = '%%CLASSNAME%%' visibility = 'public'          isSpecification = 'false' isRoot = 'false' isLeaf = 'false' isAbstract = 'false'          isActive = 'false'>          <UML:Classifier.feature>%%ATTRIBXML%%%%METHODXML%%                      </UML:Classifier.feature>        </UML:Class>   </UML:Namespace.ownedElement>%%ENDOFTEMPLATE%%      <UML:Namespace.ownedElement>        <UML:Interface xmi.id = '.:%%COUNTER%%' name = '%%INTERFACENAME%%' visibility = 'public'          isSpecification = 'false' isRoot = 'false' isLeaf = 'false' isAbstract = 'false'          isActive = 'false'/></UML:Namespace.ownedElement>%%ENDOFTEMPLATE%%            <UML:Attribute xmi.id = '.:%%COUNTER%%' name = '%%ATTRIBNAME%%' visibility = '%%VISIBILITY%%'              isSpecification = 'false' ownerScope = 'instance' changeability = 'changeable'              targetScope = 'instance'>            </UML:Attribute>%%ENDOFTEMPLATE%%            <UML:Operation xmi.id = '.:%%COUNTER%%' name = '%%METHODNAME%%' visibility = '%%VISIBILITY%%'              isSpecification = 'false' ownerScope = 'instance' isQuery = 'false' concurrency = 'sequential'              isRoot = 'false' isLeaf = 'false' isAbstract = 'false'>            </UML:Operation>%%ENDOFTEMPLATE%%<UML:Namespace.ownedElement>        <UML:Generalization xmi.id = '.:%%COUNTER%%' isSpecification = 'false'>          <UML:Generalization.child>            <UML:Class xmi.idref = '.:%%CHILDCOUNTER%%'/>          </UML:Generalization.child>          <UML:Generalization.parent>            <UML:Class xmi.idref = '.:%%PARENTCOUNTER%%'/>          </UML:Generalization.parent>        </UML:Generalization></UML:Namespace.ownedElement>%%ENDOFTEMPLATE%%<UML:Namespace.ownedElement>        <UML:Association xmi.id = '.:%%COUNTER%%' name = 'uses' isSpecification = 'false'          isRoot = 'false' isLeaf = 'false' isAbstract = 'false'>          <UML:Association.connection>            <UML:AssociationEnd xmi.id = '.:%%USINGENDCOUNTER%%' visibility = 'public'              isSpecification = 'false' isNavigable = 'false' ordering = 'unordered' aggregation = 'none'              targetScope = 'instance' changeability = 'changeable'>              <UML:AssociationEnd.participant>                <UML:Class xmi.idref = '.:%%USINGCLASS%%'/>              </UML:AssociationEnd.participant>            </UML:AssociationEnd>            <UML:AssociationEnd xmi.id = '.:%%USEDENDCOUNTER%%' visibility = 'public'              isSpecification = 'false' isNavigable = 'true' ordering = 'unordered' aggregation = 'none'              targetScope = 'instance' changeability = 'changeable'>              <UML:AssociationEnd.participant>                <UML:Interface xmi.idref = '.:%%USEDCLASS%%'/>              </UML:AssociationEnd.participant>            </UML:AssociationEnd>          </UML:Association.connection>        </UML:Association></UML:Namespace.ownedElement>%%ENDOFTEMPLATE%%    </UML:Model>  </XMI.content></XMI>%%ENDOFTEMPLATE%%</pre>
</article>
<article>
<h1>MoveCeiling (bpoag)</h1>
<pre class="block_code">#!/usr/bin/perl## MoveCeiling v0.2 written 061206:1122 by BJP## MoveCeiling will watch and automatically increase the size of an AIX filesystem# given user-specified parameters.## Usage: moveceiling <ceiling in MB> <filesystem> <increment size> <sleep time> <space to preserve> <notify counter> <email address># Example: moveceiling 500 /tmp 64 3200 5 foo@bar.com# English: Keep 500MB free in /tmp. If you have to add space, add it in 64MB chunks. Preserve 3200MB in the volume group.#          Remind me every 5 times you have to increase space, and send that reminder to foo@bar.com#use Mail::Sendmail;$ceilingSize=$ARGV[0];$targetFS=$ARGV[1];$incrementSize=$ARGV[2];$sleepTime=$ARGV[3];$preserveAmount=$ARGV[4];$notifyCounter=$ARGV[5];$mailRecipient=$ARGV[6];$mailSender=$ENV{"USER"}."\@"."localhost";if ($#ARGV!=6){ showUsage(); exit();}spinUpRoutine();mainRoutine();spinDownRoutine();sub showUsage(){ print "\n MoveCeiling's job is to watch a filesystem, and increase it's size if the\n"; print " amount of free space in that filesystem falls below threshold. MoveCeiling\n"; print " is much smarter than it used to be, but you should still use it with caution. \n"; print "\n"; print "      Usage: moveceiling <ceiling in MB> <filesystem> <increment size> <sleep time> <space to preserve> <notify counter> <email address>\n"; print "    Example: moveceiling 500 /tmp 64 30 5 foo\@bar.com\n"; print " In English: Every 30 seconds, check to see if /tmp has at least 500MB free. \n"; print "             If it sinks below 500MB, add another 64MB. For every 5 times I \n"; print "             add more space, i'll send a status message to foo\@bar.com.\n"; print "\n\n"; exit();}sub spinUpRoutine(){ print "\nMoveCeiling: I will make sure $targetFS has at least $ceilingSize MB free."; print "\nMoveCeiling: If I have to increase it's size, I will do so in $incrementSize MB increments."; print "\nMoveCeiling: Every $notifyCounter times I do so, i'll drop a note to $mailRecipient."; print "\nMoveCeiling: I'll stop adding storage if the volume group has less than $preserveAmount MB remaining."; print "\nMoveCeiling: Starting up..\n"; ## Check to see if the filesystem actually exists... @dfContents=split(/\s+/,`df -m | grep " $targetFS\$"`); if(length($targetFS)==length($dfContents[6])) {  print "MoveCeiling: Examining $dfContents[6]..\n"; } else {  print "MoveCeiling: Uh-oh.. Can't find the filesystem you specified ($targetFS)..!  Exiting.\n\n";  exit(); } ## So far so good. Pull up the VG info for this filesystem.. $dfContents[0]=~/\/dev\//; $targetLV=$'; @lslvContents=split(/\s+/,`lslv $targetLV|head -n1` ); $targetVG=$lslvContents[5]; print "MoveCeiling: $targetFS belongs to logical volume $targetLV inside $targetVG.\n"; @lsvgDump=split(/\s+/,`lsvg -L $targetVG | head -n4 | tail -n1`); $lsvgDump[6]=~/\(/; $targetVGSpaceRemaining=$'; print "MoveCeiling: $targetVG has $targetVGSpaceRemaining MB remaining, of which $preserveAmount MB will be preserved.\n\n";}sub mainRoutine(){ while(true) {  @dfContents=split(/\s+/,`df -m | grep " $targetFS\$"`);  chomp($dateString=`date`);  print "MoveCeiling: $dfContents[2] MB remaining in $targetFS as of $dateString.\n";         @lsvgDump=split(/\s+/,`lsvg -L $targetVG | head -n4 | tail -n1`);          $lsvgDump[6]=~/\(/;         $targetVGSpaceRemaining=$';  if($dfContents[2] < $ceilingSize) # Tricky logic time..  {   if($targetVGSpaceRemaining >= ($preserveAmount+$incrementSize))   {    print "MoveCeiling: Less than $ceilingSize MB remaining! Adding $incrementSize MB to $targetFS..\n";    system("echo `date` -- MoveCeiling: Less than $ceilingSize MB remaining! Adding $incrementSize MB to $targetFS.. >>/tmp/moveceiling.log");    `chfs -a size=+"$incrementSize"M $targetFS`;    $incrementCounter++;    if($incrementCounter==$notifyCounter)    {     sendNotification();     $incrementCounter=0;    }   }   else   {    system("echo `date` -- MoveCeiling: Preserve limit reached. Committing suicide. $targetFS last seen with $dfContents[2] MB free, $targetVGSpaceRemaining MB remaining in $targetG.  >>/tmp/moveceiling.log");    print "MoveCeiling: Increasing $targetFS by $incrementSize MB would eat into the preserved area! \n";    print "MoveCeiling: Preparing suicide note to $mailRecipient..\n";    sendSuicideNote();    print "MoveCeiling: My hands are tied! I'm sorry!\n";    spinDownRoutine();    exit();   }  }  else  {   print "MoveCeiling: More than $ceilingSize MB remaining..No increase needed.\n";  }  print "MoveCeiling: $targetVGSpaceRemaining MB remaining in $targetVG. Sleeping for $sleepTime seconds..\n\n";  sleep($sleepTime); }} sub sendSuicideNote(){        %mail=( To => $mailRecipient,                From => $mailSender,                Subject => "MoveCeiling Suicide Notice",                Message => "Preserve limit reached -- Data loss may be imminent. $targetFS last seen with $dfContents[2] MB free, $targetVGSpaceRemaining MB remaining in $targetVG. );                sendmail(%mail); print "MoveCeiling: Suicide note sent.\n";}sub sendNotification(){ print "MoveCeiling: Sending a friendly reminder to $mailRecipient..\n"; %mail=( To => $mailRecipient,  From => $mailSender,  Subject => "MoveCeiling Update",  Message => "$targetFS still growing. Now at $dfContents[2] MB in size with $targetVGSpaceRemaining MB remaining in $targetVG." );  sendmail(%mail); print "MoveCeiling: Mail sent.\n";}sub spinDownRoutine(){ print "MoveCeiling: Spinning down..\n\n";}</pre>
</article>
<article>
<h1>MoveCeiling (bpoag)</h1>
<pre class="block_code">#!/usr/bin/perl## MoveCeiling v0.2 written 061206:1122 by BJP## MoveCeiling will watch and automatically increase the size of an AIX filesystem# given user-specified parameters.## Usage: moveceiling <ceiling in MB> <filesystem> <increment size> <sleep time> <space to preserve> <notify counter> <email address># Example: moveceiling 500 /tmp 64 3200 5 foo@bar.com# English: Keep 500MB free in /tmp. If you have to add space, add it in 64MB chunks. Preserve 3200MB in the volume group.#          Remind me every 5 times you have to increase space, and send that reminder to foo@bar.com#use Mail::Sendmail;$ceilingSize=$ARGV[0];$targetFS=$ARGV[1];$incrementSize=$ARGV[2];$sleepTime=$ARGV[3];$preserveAmount=$ARGV[4];$notifyCounter=$ARGV[5];$mailRecipient=$ARGV[6];$mailSender=$ENV{"USER"}."\@"."localhost";if ($#ARGV!=6){        showUsage();        exit();}spinUpRoutine();mainRoutine();spinDownRoutine();sub showUsage(){        print "\n MoveCeiling's job is to watch a filesystem, and increase it's size if the\n";        print " amount of free space in that filesystem falls below threshold. MoveCeiling\n";        print " is much smarter than it used to be, but you should still use it with caution. \n";        print "\n";        print "      Usage: moveceiling <ceiling in MB> <filesystem> <increment size> <sleep time> <space to preserve> <notify counter> <email address>\n";        print "    Example: moveceiling 500 /tmp 64 30 5 foo\@bar.com\n";        print " In English: Every 30 seconds, check to see if /tmp has at least 500MB free. \n";        print "             If it sinks below 500MB, add another 64MB. For every 5 times I \n";        print "             add more space, i'll send a status message to foo\@bar.com.\n";        print "\n\n";        exit();}sub spinUpRoutine(){        print "\nMoveCeiling: I will make sure $targetFS has at least $ceilingSize MB free.";        print "\nMoveCeiling: If I have to increase it's size, I will do so in $incrementSize MB increments.";        print "\nMoveCeiling: Every $notifyCounter times I do so, i'll drop a note to $mailRecipient.";        print "\nMoveCeiling: I'll stop adding storage if the volume group has less than $preserveAmount MB remaining.";        print "\nMoveCeiling: Starting up..\n";        ## Check to see if the filesystem actually exists...        @dfContents=split(/\s+/,`df -m | grep " $targetFS\$"`);        if(length($targetFS)==length($dfContents[6]))        {                print "MoveCeiling: Examining $dfContents[6]..\n";        }        else        {                print "MoveCeiling: Uh-oh.. Can't find the filesystem you specified ($targetFS)..!  Exiting.\n\n";                exit();        }        ## So far so good. Pull up the VG info for this filesystem..        $dfContents[0]=~/\/dev\//;        $targetLV=$';        @lslvContents=split(/\s+/,`lslv $targetLV|head -n1` );        $targetVG=$lslvContents[5];        print "MoveCeiling: $targetFS belongs to logical volume $targetLV inside $targetVG.\n";        @lsvgDump=split(/\s+/,`lsvg -L $targetVG | head -n4 | tail -n1`);        $lsvgDump[6]=~/\(/;        $targetVGSpaceRemaining=$';        print "MoveCeiling: $targetVG has $targetVGSpaceRemaining MB remaining, of which $preserveAmount MB will be preserved.\n\n";}sub mainRoutine(){        while(true)        {                @dfContents=split(/\s+/,`df -m | grep " $targetFS\$"`);                chomp($dateString=`date`);                print "MoveCeiling: $dfContents[2] MB remaining in $targetFS as of $dateString.\n";                @lsvgDump=split(/\s+/,`lsvg -L $targetVG | head -n4 | tail -n1`);                $lsvgDump[6]=~/\(/;                $targetVGSpaceRemaining=$';                if($dfContents[2] < $ceilingSize) # Tricky logic time..                {                        if($targetVGSpaceRemaining >= ($preserveAmount+$incrementSize))                        {                                print "MoveCeiling: Less than $ceilingSize MB remaining! Adding $incrementSize MB to $targetFS..\n";                                system("echo `date` -- MoveCeiling: Less than $ceilingSize MB remaining! Adding $incrementSize MB to $targetFS.. >>/tmp/moveceiling.log");                                `chfs -a size=+"$incrementSize"M $targetFS`;                                $incrementCounter++;                                if($incrementCounter==$notifyCounter)                                {                                        sendNotification();                                        $incrementCounter=0;                                }                        }                        else                        {                                system("echo `date` -- MoveCeiling: Preserve limit reached. Committing suicide. $targetFS last seen with $dfContents[2] MB free, $targetVGSpaceRemaiing MB remaining in $targetVG.  >>/tmp/moveceiling.log");                                print "MoveCeiling: Increasing $targetFS by $incrementSize MB would eat into the preserved area! \n";                                print "MoveCeiling: Preparing suicide note to $mailRecipient..\n";                                sendSuicideNote();                                print "MoveCeiling: My hands are tied! I'm sorry!\n";                                spinDownRoutine();                                exit();                        }                }                else                {                        print "MoveCeiling: More than $ceilingSize MB remaining..No increase needed.\n";                }                print "MoveCeiling: $targetVGSpaceRemaining MB remaining in $targetVG. Sleeping for $sleepTime seconds..\n\n";                sleep($sleepTime);        }}sub sendSuicideNote(){        %mail=( To => $mailRecipient,                From => $mailSender,                Subject => "MoveCeiling Suicide Notice",                Message => "Preserve limit reached -- Data loss may be imminent. $targetFS last seen with $dfContents[2] MB free, $targetVGSpaceRemaining MB remaining in $targetVG. );                sendmail(%mail);        print "MoveCeiling: Suicide note sent.\n";}sub sendNotification(){        print "MoveCeiling: Sending a friendly reminder to $mailRecipient..\n";        %mail=( To => $mailRecipient,                From => $mailSender,                Subject => "MoveCeiling Update",                Message => "$targetFS still growing. Now at $dfContents[2] MB in size with $targetVGSpaceRemaining MB remaining in $targetVG." );                sendmail(%mail);        print "MoveCeiling: Mail sent.\n";}sub spinDownRoutine(){        print "MoveCeiling: Spinning down..\n\n";}</pre>
</article>
<article>
<h1>(Anonymous Monk)</h1>
<pre class="block_code">Ook. Ook. Ook.. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook! Ook? Ook. Ook? Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook! Ook. Ook! Ook! Ook! Ook! Ook! Ook! Ook! Ook! Ook! Ook! Ook! Ook! Ook! Ook!  Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook? Ook. Ook.. Ook?. Ook. Ook. Ook. Ook! Ook. Ook? Ook. Ook? Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook! Ook! Ook! Ook! Ook! Ook! Ook! Ook! Ook! Ook! Ook! Ook! Ook! Ook! Ook! Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook! Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook! Ook. Ook! Ook! Ook! Ook! Ook! O Ook. Ook? Ook. Ook! Ook! Ook? Ook! Ook. Ook? Ook. Ook. Ook. Ook. Ook! Ook Ook. Ook. Ook.. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook! Ook. Ook. Ook? Ook! Ook! Ook! Ook! Ook! Ook! Ook Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook? Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook? Ook. Ook. Ook? Ook. Ook? Ook. Ook. Ook? Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook! Ooj! Ook! Ook! Ook! Ook. Ook! Ook. Ook. Ook. Ook. Ook. Ook. Ook. Ook! Ook. Ook. Ook? Ook Ook! Ook! Ook! Ook! Ook! Ook! Ook! Ook! Ook! Ook! Ook! Ook! Ook! Ook! Ook! Ook! Ook! Ook! Ook! Ook! Ook! Ook! Ook! Ook! Ook. Ook. Ook? Ook. Ook. Ook! Ook. Ook. Ook? Ook! Ook.</pre>
</article>
<article>
<h1>Format POD as XHTML with embedded stylesheet (TGI)</h1>
<p>Perl source:</p><pre class="block_code">use warnings;use strict;use Pod::Xhtml;use File::Basename;my $stylesheet = '';if ( open( STYLE, '<', 'podder.css' ) ) {    $stylesheet = join '', <STYLE>;} elsif ( defined $PerlApp::VERSION ) {    $stylesheet = PerlApp::get_bound_file('podder.css');}my $style = <<"END_XHTML";<style>$stylesheet</style>END_XHTMLforeach my $file ( @ARGV ) {    my $base = basename( $file, '.pod', '.pm', '.pl');    my $p = Pod::Xhtml->new;    $p->addHeadText( $style );    $p->parse_from_file( $file, "$base.xhtml" );}</pre><p>Here's the perlapp prject file to generate an executable:</p><pre class="block_code">PAP-Version: 1.0Packer: C:\Program Files\ActiveState Perl Dev Kit 6.0 Deployment\bin\perlapp.exeBind: podder.css[file=podder.css,text,mode=666]Clean: Exe: podder.exeScript: podder.plShared: none</pre>
</article>
<article>
<h1>Simple Hit Counter (Anonymous Monk)</h1>
<pre class="block_code">#!/usr/bin/perl -w#Simple hit counter#To include in a webpage (HTML), put <!--#exec cmd="PATHTOCGISCRIPT.cgi"--> in the document#Replacing PATHTOCGISCRIPT with the url to the CGI script (this script).#For PHP, within the <?php and ?> tags, include "virtual("PATHTOCGISCRIPT.cgi");"#without the quotes.  Also, you need to create#a file named hits.txt for the script to access.  It can#be blank#Script copyright 2006 GreyFox of hacktek.net #VARIABLES$file = "hits.txt";#READINGopen (COUNT,"<$file") or die "Counter error 1";$hits = <COUNT>;close COUNT;#INCREMENTING$hits++;#CONTENTprint "Hits: $hits";#SAVINGopen (COUNT,">$file") or die "Counter error 2";print COUNT $hits;close COUNT;</pre>
</article>
<article>
<h1>MakeDVDArchive (HuckinFappy)</h1>
<pre class="block_code">#!/usr/bin/perl=head1 NAMEMakeDVDArchives - A script to create DVD archives and the associated kover files=head1 SYNOPSIS MakeDVDArchives [ -bgcolor <hex color> ] [ -config < filename > ] [ -man ]                 [ -coverdir <directory> ] [ -help ] [ -media <type> ]                 [ -outdir <directory> ] [ -outfile <filename> ]                 [ -srcdir <directory> ] [ -title <line 1> -title <line2> ]   MakeDVDArchives -srcdir /music/dead/shn_1981_project -outfile 81.data \                   -title 'Grateful Dead' -title '1981 Archive'=head1 OPTIONS=over=item B<-bgcolor>The hex color code you want the background of your covers to appear as.  The default is #ffffff (white)=item B<-config>If you want to use a config file other than ~/.dvdarchiverc, you can provide the name here=item B<-coverdir>The directory to write the kover files out to.  Defaults to ~/DVDCovers=item B<-help>A brief help message=item B<-man>Complete documentation=item B<-media>One of:  'dvd+r', 'dvd-r', 'dvd+r+dl', 'dvd-r+dl', depending on what sort of media you are burning to=item B<-outdir>Directory where you want the data about your DVDs written.Defaults to the current working directory=item B<-outfile>The name of the file to store the data to.  Defaults to 'dvdarchive.data'=item B<-srcdir>The directory to archive.Defaults to the current working directory=item B<-title>This flag should be used if it is used at all.  The two values are used to define both the kover filenames, as well as the actual titles printed on the kovers.  For example, the default is the equivalent of:   -title DVD -title ArchiveThis would result in filenames like:   DVD_Archive_DVD_1_and_2.koverAnd the title of that cover would read:        DVD      Archive     Disc 1 & 2=back=head1 DESCRIPTIONB<MakeDVDArchives> will read the contents of a large directory, and divide itup into appropriate sized chunks for assorted sizes of DVD media.  It willthen:  1.  Create a datafile describing what is on each DVD  2.  Divide the DVDs into sets of two, for storage in dual jewel cases  3.  Create XML files for each set, for use with the program 'kover'      for printing the covers for each set.  The default covers are only      the back insert, including spine text, so no insert for the      front is printed.   4.  Burn the DVDs, prompting you to insert blanks as appropriateThe configuration can be controlled either via the command line, or the~/.dvdarchiverc file.  This is a completely linux-centric program.  It uses growisofs to writethe DVDs, and the files for the covers it creates are for printing via the'kover' program, part of the KDE suite.=head1 DEPENDENCIESThis script requires the following modules which may not be installedin your perl installation:  - Config::Std  - IO::Handle  - IO::Prompt  - Object::InsideOut  - Params::Validate  - Pod::Usage  - Switch  - XML::Simple=head1 CONFIGURATION FILEA lot of the configuration options have to do with controlling the outputto the covers for Kover to print.  I don't know much about that....I'vewritten out files that work, but some of the config options are a mystery to me.Hopefully everything works fine without this configuration file even existing.But you can cut & paste the following into ~/.dvdarchiverc [Program Defaults] coverdir       = /home/stampes/personalDocuments/DVDCovers #mediatype      = dvd+r outputdir      = /home/stampes/personalDocuments/ArchiveData #outputfile     = dvdarchive.data #sourcedir      = '.' #title          = DVD #title          = Archive [Kover Content] color        = #000000 font         = Monospace fontsettings = Monospace,9,-1,5,50,0,0,0,0,0 italic       = 0 size         = 9 weight       = 50 [Kover General] bgcolor = #ffffff [Kover Inlet] font         = Helvetica fontsettings = helvetica,10,-1,5,50,0,0,0,0,0 italic       = 0 size         = 10 spinetext    = 0 weight       = 75 [Kover Title] color        = #000000 display      = 0 font         = DejaVu Serif fontsettings = DejaVu Serif,20,-1,5,75,0,0,0,0,0 italic       = 0 size         = 20 weight       = 75 [Burn] command      = /usr/bin/growisofs flags        = -dvd-compat -speed=16 -R -J -pad -Z device       = /dev/hdi flagsuffix   = -graft-points=cutMAIN: {   #+-------------------------------------------------------------------------   # Load programming pragmas to keep us honest   #+-------------------------------------------------------------------------   use strict;   use warnings;   #+-------------------------------------------------------------------------   # Define constants   #+-------------------------------------------------------------------------   use constant {      #+---------------------------------------------------------------------      # Defaults for various default values      #+---------------------------------------------------------------------      DEFAULT_CONFIG      => "$ENV{HOME}/.dvdarchiverc",      DEFAULT_COVER_DIR   => "$ENV{HOME}/DVDCovers",      DEFAULT_MEDIA_TYPE  => 'dvd+r',      DEFAULT_OUTPUT_FILE => 'dvdarchive.data',      DEFAULT_OUTPUT_DIR  => '.',      DEFAULT_SRC_DIR     => '.',      DEFAULT_TITLE       => [ 'DVD', 'Archive' ],      #+---------------------------------------------------------------------      # Constants for media data.  For each type of data define a       # command line string to describe if, and the size of it.  If      # new sizes/names of media are introduced, the switch statement      # which determines capacity based on media type will need an      # addition as well.      #+---------------------------------------------------------------------      DVD_PLUS_R          => 'dvd+r',      DVD_MINUS_R         => 'dvd-r',      DVD_PLUS_R_DL       => 'dvd+r+dl',      DVD_MINUS_R_DL      => 'dvd-r+dl',      DVD_PLUS_R_SIZE     => 4700372992,      DVD_PLUS_R_DL_SIZE  => 8543692390,      # I don't use these so I didn't bother looking it up      DVD_MINUS_R_SIZE    => 0,      DVD_MINUS_R_DL_SIZE => 0,   };   #+-------------------------------------------------------------------------   # Load needed Modules     #+-------------------------------------------------------------------------   use Config::Std;   use File::Basename;   use Getopt::Long;   use IO::Handle;   use IO::Prompt;   use Pod::Usage;   use Switch 'Perl6';   #+-------------------------------------------------------------------------   # For an application such as this, prefer autoflushed buffers   #+-------------------------------------------------------------------------   *STDOUT->autoflush();   *STDERR->autoflush();   #+-------------------------------------------------------------------------   # Non-Command line globals   #+-------------------------------------------------------------------------   my $capacity;   my %argv;   #+-------------------------------------------------------------------------   # Command line globals   #+-------------------------------------------------------------------------   my $bgcolor;   my $configFile = DEFAULT_CONFIG;   my $coverDir;   my $debug = 0;   my $justburn;   my $man;   my $mediaType;   my $help;   my $outputDir;   my $outputFile;   my $srcDir;   my @title;   #+-------------------------------------------------------------------------   # React if no command line options were provided   #+-------------------------------------------------------------------------   pod2usage("$0: No files given.")  if (@ARGV == 0);   #+-------------------------------------------------------------------------   # @ARGV gets munged by Getopt::Long, and we want to be able to look later   # to see what options we got on the command line, so build a hash for    # lookup   #+-------------------------------------------------------------------------   for ( @ARGV ) {      if ( $_ =~ /^-/ ) {         $argv{ $_ } = 1;      }   }   #+-------------------------------------------------------------------------   # Parse the command line and print a usage message if needed   #+-------------------------------------------------------------------------   GetOptions( 'bgcolor=s'   => \$bgcolor,               'config=s'    => \$configFile,               'coverdir=s'  => \$coverDir,               'debug'       => \$debug,               'help'        => \$help,               'justburn'    => \$justburn,               'man'         => \$man,               'media=s'     => \$mediaType,               'outdir=s'    => \$outputDir,               'outfile=s'   => \$outputFile,               'srcdir=s'    => \$srcDir,               'title=s@'    => \@title, )      or pod2usage( { -message => 'Invalid command line argument.' } );   if ( $help ) {      pod2usage( -message => 'Printing Help Message.',                 -exitval => 1, );   }   if ( $man ) {      pod2usage( -message => 'Printing documentation.',                 -exitval => 1,                 -verbose => 2 );   }   #+-------------------------------------------------------------------------   # Load the config file.  Then try to resolve values.  The precedence is:   # - Use the command line value if provided   # - Otherwise the the config file value if provided   # - Otherwise use the default value   #+-------------------------------------------------------------------------   my $rh_config = LoadConfig( { configfile => $configFile } );   if ( not $argv{ -media } ) {      if ( my $configType = $rh_config->{'Program Defaults'}->{ mediatype } ) {         $mediaType = $configType;      } else {         $mediaType = DEFAULT_MEDIA_TYPE;      }   }   if ( not $argv{ -coverdir } ) {      if ( my $configCoverDir =               $rh_config->{'Program Defaults'}->{ coverdir } ) {         $coverDir = $configCoverDir;      } else {         $coverDir = DEFAULT_COVER_DIR;      }   }   if ( not $argv{ -outdir } ) {      if ( my $configSaveDir =               $rh_config->{'Program Defaults'}->{ outputdir } ) {         $outputDir = $configSaveDir;      } else {         $outputDir = DEFAULT_OUTPUT_DIR;      }   }   if ( not $argv{ -outfile } ) {      if ( my $configSaveFile =               $rh_config->{'Program Defaults'}->{ outputfile } ) {         $outputFile = $configSaveFile;      } else {         $outputFile = DEFAULT_OUTPUT_FILE;      }   }   if ( not $argv{ -srcdir } ) {      if (my $configSrcDir = $rh_config->{'Program Defaults'}->{ sourcedir }) {         $srcDir = $configSrcDir;      } else {         $srcDir = DEFAULT_SRC_DIR;      }   }   if ( not $argv{ -title } ) {      if ( my $configTitle = $rh_config->{'Program Defaults'}->{ title } ) {         @title = @{ $configTitle }      } else {         @title = @{ DEFAULT_TITLE() };      }   }   #+-------------------------------------------------------------------------   # If options impacting the kover data were given, simply modify the   # existing config with the new data for later use   #+-------------------------------------------------------------------------   if ( $bgcolor ) {      $rh_config->{'Kover General'}->{ 'bgcolor' } = $bgcolor;   }   #+-------------------------------------------------------------------------   # Determine the media capacity for the media to be used   #+-------------------------------------------------------------------------   given ( $mediaType ) {      when ( DVD_PLUS_R )     { $capacity = DVD_PLUS_R_SIZE;     }      when ( DVD_MINUS_R )    { $capacity = DVD_MINUS_R_SIZE;    }      when ( DVD_PLUS_R_DL )  { $capacity = DVD_PLUS_R_DL_SIZE;  }      when ( DVD_MINUS_R_DL ) { $capacity = DVD_MINUS_R_DL_SIZE; }   }   #+-------------------------------------------------------------------------   # Print a message explaining to the user what is about to happen and   # make sure that's OK with them   #+-------------------------------------------------------------------------   my $printCapacity = sprintf '%2.2f', $capacity / 1024 / 1024 / 1024;   my $saveAs = "$outputDir/$outputFile";   my $userMessage = <<"   END_USER_MESSAGE";   |   |   Here's what is going to happen now:   |      Directory to archive = $srcDir   |      Media Type           = $mediaType   |      Media Capacity       = $printCapacity GB   END_USER_MESSAGE   unless ( $justburn ) {      $userMessage .= <<"      END_USER_MESSAGE";      |      Save list of DVDs as = $saveAs      |      Write Cover data to  = $coverDir      |      Title Data is        = $title[0]      |                             $title[1]      |      END_USER_MESSAGE   }   $userMessage =~ s{^.+?\|}{}sgmx;   print $userMessage;   my $prompt = "Continue? ( [Y]es/[N]o ): ";   my $response =       prompt(          $prompt,             '-require' => {                "Invalid Selection.\n$prompt" => qr/^[yn]$/i             },            '-one_char' );   print "\n";   if ( $response =~ /^[Nn]$/ ) { exit; }   #+-------------------------------------------------------------------------   # Get the list of contents of the directory.  This should be made more    # platform-neutral, but I'm too lazy to look up the perl replacement for    # this right now.  Once the list of raw data is aquired, create a set   # of objects representing the entries   #+-------------------------------------------------------------------------   my @read          = `du -sb $srcDir/*/.`;   my @directories   = map { s{/.$}{} } @read;   my $ra_dvdEntries = CreateDVDEntries( { contents => \@directories } );   #+-------------------------------------------------------------------------   # Divide up the data into appropriately sized chunks and create a set of    # DVD objects representing those chunks   #+-------------------------------------------------------------------------   my $ra_DVDs       = CreateDVDs( { contents => $ra_dvdEntries,                                      capacity => $capacity,                                     title    => \@title } );   unless ( $justburn ) {      #+----------------------------------------------------------------------      # TOFIX:  This is a part that could be more generic.  A 'Set' in this      # context is defined as a set of two DVDs.  That's because I use dual      # cases and want to print appropriate covers for them.  A 'Set' should      # become a more generic concept with the user defining the size of the       # set defined by the user      #+----------------------------------------------------------------------      my $ra_Sets       = CreateSets( { dvds => $ra_DVDs } );      #+----------------------------------------------------------------------      # Write the output file.  This is currently a flat text file, but I have      # hopes it will become a SQLite database or somesuch      #+----------------------------------------------------------------------      WriteData( { dvds   => $ra_DVDs,                    output => $saveAs });      #+----------------------------------------------------------------------      # Create the kovers for the KDE program 'Kover' to print      #+----------------------------------------------------------------------      CreateKovers( { sets     => $ra_Sets,                       title    => \@title,                       coverdir => $coverDir,                      config   => $rh_config } );   }   #+-------------------------------------------------------------------------   # Finally, burn all the DVDs   #+-------------------------------------------------------------------------   BurnDVDs( { dvds   => $ra_DVDs,               config => $rh_config->{ Burn },               debug  => $debug} );}=head1 DEVELOPER DOCUMENTATION OF SUBROUTINESThe following is the documentation for all subroutines in the script=cut#+----------------------------------------------------------------------------# This guarantees a different scope for the main code and the subroutines, # ensuring all variables are properly scoped#+----------------------------------------------------------------------------SUBS:{   #+-------------------------------------------------------------------------   # Default command for burning the DVD   #+-------------------------------------------------------------------------   use constant {      DEFAULT_COMMAND => '/usr/bin/growisofs',      DEFAULT_DEVICE  => '/dev/dvd',      DEFAULT_FLAGS   => '-dvd-compat -speed=16 -R -J -pad -Z',      DEFAULT_SUFFIX  => '-graft-points',   };   use strict;   use warnings;   use Params::Validate qw( :all );#---------------------------------------------------------------------------#  Documentation for CreateDVDEntries()#---------------------------------------------------------------------------=head1 B<CreateDVDEntries( )>=over=item I<Parameters>=over=item B<contents>An array that's the output from du -b=back=item I<Return values>=over=item B<array ref>a reference to an array of DVD::Entry objects=back=item I<Description>Takes an array ref containing the contents of the directory and the sizeof each item, and creates an array of DVD::Entry objects representing thosecontents=back=cut#---------------------------------------------------------------------------#  End of Documentation for CreateDVDEntries()#---------------------------------------------------------------------------   sub CreateDVDEntries {      validate( @_, { contents =>                        { optional  => 0,                         type      => ARRAYREF },                    } );      my $rh_args = $_[0];      my $ra_data = $rh_args->{ contents };      my @dvdEntries;      for my $entry ( @{ $ra_data } ) {         chomp $entry;         next unless ( $entry );         my ( $size, $source ) = split /\s+/, $entry;         my $name = basename $source;         push @dvdEntries, DVD::Entry->new( name   => $name,                                            size   => $size,                                            source => $source );      }      return \@dvdEntries;   }#---------------------------------------------------------------------------#  Documentation for CreateDVDs()#---------------------------------------------------------------------------=head1 B<CreateDVDs( )>=over=item I<Parameters>=over=item B<contents>A ref to an array of DVD::Entry objects=item B<capacity>The size of the media being used, in bytes=item B<title>A ref to a 2-element array representing the title for the DVDs=back=item I<Return values>=over=item B<array ref>a reference to an array of DVD objects=back=item I<Description>Given a set of DVD::Entry objects and the known capacity of the media,creates a set of DVD objects representing what will be stored on eachDVD and the title of it=back=cut#---------------------------------------------------------------------------#  End of Documentation for CreateDVDs()#---------------------------------------------------------------------------   sub CreateDVDs {      validate( @_, { contents =>                        { optional  => 0,                         type      => ARRAYREF,                         { 'Contains DVD::Entry objects' =>                              sub {                                  for ( @{ $_[0] } ) {                                    unless ( $_->isa( 'DVD::Entry' ) ) {                                       return 0;                                    }                                 }                                 return 1;                              },                         }                      },                      capacity =>                        { optional => 0 },                      title    =>                       { optional => 0,                         type     => ARRAYREF },                    } );      my $rh_args      = $_[0];      my $ra_contents  = $rh_args->{ contents };      my $capacity     = $rh_args->{ capacity };      my $ra_TitleText = $rh_args->{ title };      my $ContentsMax = $#{ $ra_contents };      my @DVDs;      my $id = 1;      my $index = 0;      my $currentDVD;      my $track = 1;      while ( $index <= $ContentsMax ) {         my $dir      = $ra_contents->[ $index ];         my $dirSize  = $dir->GetSize();         my $dvdSize  = $currentDVD ? $currentDVD->GetSize() : 0;         if ( $dvdSize + $dirSize < $capacity ) {            $dir->SetNumber( $track++ );            unless ( $currentDVD ) {               my $currentTitle = join ' ', @{ $ra_TitleText }, "DVD #$id";               $currentDVD = DVD->new( id    => $id++,                                       title => $currentTitle );            }            $currentDVD->AddContent( $dir );            $index++;            next;         } else {            push @DVDs, $currentDVD;            $currentDVD = undef;            $track = 1;         }      }      if ( $currentDVD ) {           push @DVDs, $currentDVD;      }      return \@DVDs;   }#---------------------------------------------------------------------------#  Documentation for CreateSets()#---------------------------------------------------------------------------=head1 B<CreateSets( )>=over=item I<Parameters>=over=item B<dvds>A ref to an array of DVD objects=back=item I<Return values>=over=item B<array ref>a reference to an array of DVD::Set objects=back=item I<Description>Given a set of DVD objects, creates a set of DVD::Set objects representingthe two DVDs going into a set, for packaging in dual jewel cases=back=cut#---------------------------------------------------------------------------#  End of Documentation for CreateSets()#---------------------------------------------------------------------------   sub CreateSets {      validate( @_, { dvds =>                        { optional  => 0,                         type      => ARRAYREF,                         callbacks =>                           { 'Contains DVD objects' =>                              sub {                                  for ( @{ $_[0] } ) {                                    unless ( $_->isa( 'DVD' ) ) {                                       return 0;                                    }                                 }                                 return 1;                              },                         }                       }                    } );      my $rh_args  = $_[0];      my $ra_DVDs  = $rh_args->{ dvds };      my @sets;      my ( $start, $end ) = ( 0, 1 );      while ( $start <= $#{ $ra_DVDs } ) {         my $dvd1 = $ra_DVDs->[ $start ];         my $dvd2 = $ra_DVDs->[ $end ] || undef;         $start += 2;         $end   += 2;         my $contents = $dvd2 ? [ $dvd1, $dvd2 ] : [ $dvd1 ];         my $set = DVD::Set->new( dvds  => $contents );         push @sets, $set;         if ( not $dvd2 ) {            last;         }      }      return \@sets;   }#---------------------------------------------------------------------------#  Documentation for LoadConfig()#---------------------------------------------------------------------------=head1 B<LoadConfig( )>=over=item I<Parameters>=over=item B<configfile>Absolute path of the config file to load=back=item I<Return values>=over=item B<hash ref>a reference to a hash representing the config=back=item I<Description>Load the config file=back=cut#---------------------------------------------------------------------------#  End of Documentation for LoadConfig()#---------------------------------------------------------------------------   sub LoadConfig {      my ( $rh_args ) = ( @_ );      my  $configFile = $rh_args->{ configfile };      my $error = 0;      if ( not -e $configFile ) {         warn "$configFile does not exist.\n";         $error = 1;      } elsif ( not -r $configFile ) {         warn "$configFile not readable.\n";         $error = 1;      }      my %config;      eval {          read_config $configFile => %config;      };      if ( $@ ) {         warn "Exception occured reading $configFile: $@\n";         $error = 1;      }      if ( $error ) {         my $prompt = "Continue with default values? ( [Y]es/[N]o ): ";         my $response =             prompt(                $prompt,                   '-require' => {                      "Invalid Selection.\n$prompt" => qr/^[yn]$/i                   },                  '-one_char' );         print "\n";         if ( $response =~ /^[Nn]$/ ) { exit; }         %config = ();      }      return \%config;   }#---------------------------------------------------------------------------#  Documentation for WriteData()#---------------------------------------------------------------------------=head1 B<WriteData( )>=over=item I<Parameters>=over=item B<dvds>Reference to an array of DVD objects=item B<output>File to write the data to=back=item I<Description>Writes out a simple text file of what is on each DVD=back=cut#---------------------------------------------------------------------------#  End of Documentation for WriteData()#---------------------------------------------------------------------------   sub WriteData {      validate( @_, { dvds =>                        { optional  => 0,                         type      => ARRAYREF,                         callbacks =>                           { 'Contains DVD objects' =>                              sub {                                  for ( @{ $_[0] } ) {                                    unless ( $_->isa( 'DVD' ) ) {                                       return 0;                                    }                                 }                                 return 1;                              },                         }                       },                      output => { optional => 0 },                     } );      my ( $rh_args ) = ( @_ );      my $ra_DVDs = $rh_args->{ dvds };      my $outfile = $rh_args->{ output };      open OUT, '>', $outfile or die $!;      for my $dvd ( @{ $ra_DVDs } ) {         my $size = $dvd->GetSize();         $size = $size / 1024 / 1024 / 1024;         printf OUT "\nDVD ID: %2d\n", $dvd->GetID();         printf OUT "DVD Size: %4.2f GB\n", $size;         print OUT "================\n";         for my $dir ( @{ $dvd->GetContents() } ) {            my $dirSize = $dir->GetSize() / 1024 / 1024;            my $sizeTemplate = '%4d';            my $unit = 'MB';            if ( $dirSize > 1024 ) {               $dirSize = $dirSize / 1024;               $unit = 'GB';               $sizeTemplate = '%2.2f';            }            printf OUT "\t%2d. %-60s => $sizeTemplate %2s\n",                        $dir->GetNumber(), $dir->GetName(), $dirSize, $unit;         }      }   }#---------------------------------------------------------------------------#  Documentation for BurnDVDs()#---------------------------------------------------------------------------=head1 B<BurnDVDs( )>=over=item I<Parameters>=over=item B<dvds>Reference to an array of DVD objects=item B<config>Reference to a hash representing the config=item B<debug>Optional flag to get some debug output=back=item I<Description>Using the commands in the config, burn the DVDs and prompt for user to insert blank media between them=back=cut#---------------------------------------------------------------------------#  End of Documentation for BurnDVDs()#---------------------------------------------------------------------------   sub BurnDVDs {      validate( @_, { dvds =>                        { optional  => 0,                         type      => ARRAYREF,                         callbacks =>                           { 'Contains DVD objects' =>                              sub {                                  for ( @{ $_[0] } ) {                                    unless ( $_->isa( 'DVD' ) ) {                                       return 0;                                    }                                 }                                 return 1;                              },                         }                       },                      config => { optional => 0 },                       debug  => { optional => 1 },                     } );      my ( $rh_args ) = ( @_ );      my $ra_DVDs = $rh_args->{ dvds };      my $config  = $rh_args->{ config };      my $debug   = $rh_args->{ debug };      my $command        = $config->{ command }    || DEFAULT_COMMAND;      my $dvdDevice      = $config->{ device }     || DEFAULT_DEVICE;      my $flags          = $config->{ flags }      || DEFAULT_FLAGS;      my $suffix         = $config->{ flagsuffix } || DEFAULT_SUFFIX;      for my $dvd ( @{ $ra_DVDs } ) {         my $fullcommand = "$command $flags $dvdDevice $suffix ";         my $title = $dvd->GetTitle();         my $id    = $dvd->GetID();         for my $entry ( @{ $dvd->GetContents() } ) {            my $name = $entry->GetName();            my $src  = $entry->GetSource();            $fullcommand .= qq{"/$name=$src" };         }         print "Ready to burn $title\n";         my $prompt = "Select one of the following: [s]kip, [b]urn, [q]uit: ";         my $response =             prompt(                $prompt,                   '-require' => {                      "Invalid Selection.\n$prompt" => qr/^[sbq]$/                   },                  '-one_char' );         print "\n";         if ( $response eq 'q' ) { exit; }         if ( $response eq 's' ) { next; }         prompt( "Insert blank DVD for $title and press <RETURN>: " );         print "Preparing to burn DVD...please wait...\n";         open BURN, "$fullcommand 2>&1 |" or die $!;         while ( <BURN> ) {            chomp;            if ( $debug ) {               print "$_\n";            } elsif ( /estimate finish/ ) {               print;               print "\cH" x length $_;               next;            } elsif ( /flushing cache/ ) {               print "\nFlushing Cache and Closing DVD...please wait...";            } elsif ( /^:.+(?:error|failed)/ ) {               print "$_\n";            }         }         close BURN;         print "\nCompleted Burning $title\n";         system "eject $dvdDevice";      }   }#---------------------------------------------------------------------------#  Documentation for CreateKovers()#---------------------------------------------------------------------------=head1 B<CreateKovers( )>=over=item I<Parameters>=over=item B<sets>Reference to an array of DVD::Set objects=item B<config>Reference to a hash representing the config=item B<coverdir>Where to write the Kover files=item B<title>Reference to a two element array representing the config=item B<debug>Optional flag to get some debug output=back=item I<Description>Using the commands in the config, burn the DVDs and prompt for user to insert blank media between them=back=cut#---------------------------------------------------------------------------#  End of Documentation for BurnDVDs()#---------------------------------------------------------------------------   sub CreateKovers {      validate( @_, { sets =>                        { optional  => 0,                         type      => ARRAYREF,                         callbacks =>                           { 'Contains DVD::Set objects' =>                              sub {                                  for ( @{ $_[0] } ) {                                    unless ( $_->isa( 'DVD::Set' ) ) {                                       return 0;                                    }                                 }                                 return 1;                              },                         }                      },                      coverdir =>                        { optional => 0 },                      title    =>                       { optional => 0,                         type     => ARRAYREF },                      config    =>                       { optional => 0,                         type     => HASHREF },                    } );      my ( $rh_args ) = ( @_ );      my $ra_Sets        = $rh_args->{ sets };      my $ra_TitleText   = $rh_args->{ title };      my $coverDirectory = $rh_args->{ coverdir };      my $rh_config      = $rh_args->{ config };      my $generalSection =          DVD::Kover::General->new( config => $rh_config->{ 'Kover General' } );      my $imgSection = DVD::Kover::Images->new( );      my $inlet =          DVD::Kover::Inlet->new( config => $rh_config->{ 'Kover Inlet' } );      for my $set ( @{ $ra_Sets } ) {         my @currentTitle = @{ $ra_TitleText };         my ( $dvd1,$dvd2 ) =  @{ $set->GetDVDs() };         my $discs  = "DVD ".$dvd1->GetID();         if ( $dvd2 ) {            $discs .= ' & '.$dvd2->GetID();         }         push @currentTitle, $discs;         my $titleSection =             DVD::Kover::Title->new( config => $rh_config->{ 'Kover Title' },                                    text   => \@currentTitle );         my $file = join "_", @currentTitle;         $file =~ s/[ ]/_/g;         $file =~ s/[&]/and/;         $file .= '.kover';         my $ra_Content = [ {}, {},                            'Disc '.$dvd1->GetID().':' ];         for my $dir ( @{ $dvd1->GetContents } ) {           push @{ $ra_Content }, $dir->GetNumber().'. '.$dir->GetName();         }         if ( $dvd2 ) {            push @{ $ra_Content }, {};            push @{ $ra_Content }, 'Disc '.$dvd2->GetID().':';            for  my $dir ( @{ $dvd2->GetContents } ) {              push @{ $ra_Content }, $dir->GetNumber().'. '.$dir->GetName();            }         }         my $content =             DVD::Kover::Content->new( text   => $ra_Content,                                      config => $rh_config->{'Kover Content'});         my $kover   = DVD::Kover->new( title   => $titleSection,                                        config  => $rh_config,                                        content => $content,                                        general => $generalSection,                                        images  =>  $imgSection,                                        inlet   =>  $inlet );         print "Creating $file\n";         open OUT, '>', "$coverDirectory/$file" or die $!;         print OUT $kover->GetXML();      }   }}=head1 DOCUMENTATION FOR CLASSES The following is the documentation for all classes defined for usein this script.All classes are designed using Object::InsideOut.  In most cases, there areno interesting methods on the classes, they are just data containers.  Assuch, I am documenting the contructors only, and in rare cases the othermore interesting methods.  All attributes have accessors/mutators using thefollowing naming convention (see Object::InsideOut for details):  constructor attribute    |  Accessor   | Mutator  ===================================================          name             |  GetName()  | SetName()=cutBEGIN {#---------------------------------------------------------------------------#  Documentation for DVD::Entry#---------------------------------------------------------------------------=head1 B<DVD::Entry>=head2 B<new()>=over=item I<Parameters>=over=item B<number>The track number on the DVD=item B<name>The name of the entry=item B<size>The size of the entry=item BThe absolute path to the source=back=item I<Description>Contructs a DVD::ENtry object representing one item (file or subdirectory)on the DVD=back=cut#---------------------------------------------------------------------------#  End of Documentation for DVD::Entry#---------------------------------------------------------------------------   package DVD::Entry;   {      use strict;      use warnings;      use Object::InsideOut;      my @trackNumber :Field( Get => 'GetNumber', Set => 'SetNumber' );      my @name        :Field( Get => 'GetName',   Set => 'SetName' );      my @size        :Field( Get => 'GetSize',   Set => 'SetSize' );      my @srcPath     :Field( Get => 'GetSource', Set => 'SetSource' );      my %initArgs :InitArgs = (         track  => {            Type      => 'Numeric',            Field     => \@trackNumber },         name   => {            Field     => \@name },         size   => {            Field     => \@size },         source => {            Field     => \@srcPath }      );   }#---------------------------------------------------------------------------#  Documentation for DVD#---------------------------------------------------------------------------=head1 B<DVD>=head2 B<new()>=over=item I<Parameters>=over=item B<id>An ID number to identify this DVD=item B<contents>A reference to an array of DBD::Entry objects=item B<size>The size of the DVD Data=item B<title>A two element array reference to be used as the title=back=item I<Description>Contructs a DVD::Entry object representing one item (file or subdirectory)on the DVD=back=cut#---------------------------------------------------------------------------#  End of Documentation for DVD#---------------------------------------------------------------------------   package DVD;   {      use strict;      use warnings;      use Object::InsideOut;      my @id       :Field( Get => 'GetID',       Set => 'SetID' );      my @contents :Field( Get => 'GetContents', Set => 'SetContents' );      my @size     :Field( Get => 'GetSize',     Set => 'SetSize' );      my @title    :Field( Get => 'GetTitle',    Set => 'SetTitle' );      my %initArgs :InitArgs = (         id       => {            Type      => 'Numeric',            Field     => \@id          },         contents => {            Type      => 'LIST',            Field     => \@contents,            Default   => [ ]          },         size     => {            Type      => 'Numeric',            Field     => \@size,            Default   => 0          },         title    => {            Field     => \@title,         },      );      sub AddContent {         my ( $self, $content ) = @_;         push @{ $self->GetContents }, $content;         $self->SetSize( $self->GetSize() + $content->GetSize() );      }   }   package DVD::Set;   {      use strict;      use warnings;      use Object::InsideOut;      my @dvds     :Field( Get => 'GetDVDs',  Set => 'SetDVDs' );      my @title    :Field( Get => 'GetTitle', Set => 'SetTitle' );      my %initArgs :InitArgs = (         dvds  => {            Type  => 'LIST',            Field => \@dvds }      );      sub AddDVD {         my ( $self, $dvd ) = @_;         push @{ $self->GetDVDs() }, $dvd;      }   }   package DVD::Kover;   {      use strict;      use warnings;      use Object::InsideOut;      use XML::Simple;      my @content :Field( Get => 'GetContent', Set => 'SetContent' );      my @general :Field( Get => 'GetGeneral', Set => 'SetGeneral' );      my @images  :Field( Get => 'GetImages',  Set => 'SetImages' );      my @inlet   :Field( Get => 'GetInlet',   Set => 'SetInlet' );      my @name    :Field( Get => 'GetName',    Set => 'SetName' );      my @title   :Field( Get => 'GetTitle',   Set => 'SetTitle' );      my @version :Field( Get => 'GetVersion', Set => 'SetVersion' );      my %initArgs :InitArgs = (         content => {            Field   => \@content,            Type    => 'DVD::Kover::Content',         },         general => {            Field   => \@general,            Type    => 'DVD::Kover::General',         },         images  => {            Field   => \@images,            Type    => 'DVD::Kover::Images',         },         inlet   => {            Field   => \@inlet,            Type    => 'DVD::Kover::Inlet',         },         name    => {            Field   => \@name,            Default => 'kover',         },         title   => {             Field   => \@title,            Type    => 'DVD::Kover::Title',         },         version => {            Field   => \@version,            Default => '2.9.6'         },      );      sub GetAll {         my ( $self ) = @_;         return { content => $self->GetContent()->GetAll(),                  general => $self->GetGeneral()->GetAll(),                  img     => $self->GetImages()->GetAll(),                  inlet   => $self->GetInlet()->GetAll(),                  name    => $self->GetName(),                  title   => $self->GetTitle()->GetAll(),                  version => $self->GetVersion() };      }      sub GetXML {         my ( $self ) = @_;         return XMLout( $self->GetAll() );      }   }   package DVD::Kover::Content;   {      use constant {         DEFAULT_COLOR         => '#000000',         DEFAULT_FONT          => 'Monospace',         DEFAULT_FONT_SETTINGS => 'Monospace,9,-1,5,50,0,0,0,0,0',         DEFAULT_ITALIC        => 0,         DEFAULT_SIZE          => 9,         DEFAULT_WEIGHT        => 50,      };      use strict;      use warnings;      use Object::InsideOut;      my @color        :Field( Get => 'GetColor',        Set => 'SetColor' );      my @config       :Field( Get => 'GetConfig',       Set => 'SetConfig' );      my @font         :Field( Get => 'GetFont',         Set => 'SetFont' );      my @fontSettings :Field( Get => 'GetFontSettings', Set => 'SetFontSettings' );      my @italic       :Field( Get => 'GetItalic',       Set => 'SetItalic' );      my @size         :Field( Get => 'GetSize',         Set => 'SetSize' );      my @text         :Field( Get => 'GetText',         Set => 'SetText' );      my @weight       :Field( Get => 'GetWeight',       Set => 'SetWeight' );      my %initArgs :InitArgs = (         text => {            Field   => \@text,            Default => [ ],            Type    => 'LIST',         },      );      sub _Init :Init {         my ( $self, $args ) = @_;         my $config = $args->{ config };         $self->SetConfig( $config );         if ( my $color = $config->{ color } ) {            $self->SetColor( $color );         } else {            $self->SetColor( DEFAULT_COLOR );         }         if ( my $font = $config->{ font} ) {            $self->SetFont( $font );         } else {            $self->SetFont( DEFAULT_FONT );         }         if ( my $fontsettings = $config->{ fontsettings } ) {            $self->SetFontSettings( $fontsettings );         } else {            $self->SetFontSettings( DEFAULT_FONT_SETTINGS );         }         if ( my $italic = $config->{ italic } ) {            $self->SetItalic( $italic );         } else {            $self->SetItalic( DEFAULT_ITALIC );         }         if ( my $size = $config->{ size } ) {            $self->SetSize( $size );         } else {            $self->SetSize( DEFAULT_SIZE );         }         if ( my $weight = $config->{ weight } ) {            $self->SetWeight( $weight );         } else {            $self->SetWeight( DEFAULT_WEIGHT );         }      }      sub GetAll {         my ( $self ) = @_;         return { color         => $self->GetColor(),                  font          => $self->GetFont(),                  font_settings => $self->GetFontSettings(),                  italic        => $self->GetItalic(),                  size          => $self->GetSize(),                  text          => $self->GetText(),                  weight        => $self->GetWeight() };      }   }   package DVD::Kover::General;   {      use strict;      use warnings;      use constant {         DEFAULT_BG_COLOR => '#ffffff',         DEFAULT_CDDB_ID  => '',         DEFAULT_NUMBER   => 0,      };      use Object::InsideOut;      my @bgColor :Field( Get => 'GetBGColor', Set => 'SetBGColor' );      my @config  :Field( Get => 'GetConfig',  Set => 'SetConfig' );      my @CDDBid  :Field( Get => 'GetCDDBid',  Set => 'SetCDDBid' );      my @number  :Field( Get => 'GetNumber',  Set => 'SetNumber' );      sub _Init :Init {         my ( $self, $args ) = @_;         my $config = $args->{ config };         $self->SetConfig( $config );         if ( my $bgcolor = $config->{ bgcolor } ) {            $self->SetBGColor( $bgcolor );         } else {            $self->SetBGColor( DEFAULT_BG_COLOR );         }         if ( my $cddbID = $config->{ cddb_id } ) {            $self->SetCDDBid( $cddbID );         } else {            $self->SetCDDBid( DEFAULT_CDDB_ID );         }         if ( my $number = $config->{ number } ) {            $self->SetNumber( $number );         } else {            $self->SetNumber( DEFAULT_CDDB_ID );         }      }      sub GetAll {         my ( $self ) = @_;         return { bgcolor => $self->GetBGColor(),                  cddb_id => $self->GetCDDBid(),                  number  => $self->GetNumber() };      }   }   package DVD::Kover::Images;   {      use strict;      use warnings;      use Object::InsideOut;      my @images :Field( Get => 'GetImages', Set => 'SetImages' );      my %initArgs :InitArgs = (         img => {            Field   => \@images,            Default => [ { mode   => 0,                           src    => '',                           target => 0 },                         { mode   => 0,                           src    => '',                           target => 0 },                         { mode   => 0,                           src    => '',                           target => 0 },                       ],            Type    => 'LIST'         }      );      sub GetAll {         my ( $self ) = @_;         return $self->GetImages();      }   }   package DVD::Kover::Inlet;   {      use strict;      use warnings;      use constant {         DEFAULT_FONT          => 'Helvetica',         DEFAULT_FONT_SETTINGS => 'helvetica,10,-1,5,50,0,0,0,0,0',         DEFAULT_ITALIC        => 0,         DEFAULT_SIZE          => 10,         DEFAULT_SPINE_TEXT    => 0,         DEFAULT_WEIGHT        => 75,      };      use Object::InsideOut;      my @config      :Field( Get => 'GetConfig',       Set => 'SetConfig' );      my @font        :Field( Get => 'GetFont',         Set => 'SetFont' );      my @fontSettings :Field( Get => 'GetFontSettings', Set => 'SetFontSettings' );      my @italic      :Field( Get => 'GetItalic',       Set => 'SetItalic' );      my @size        :Field( Get => 'GetSize',         Set => 'SetSize' );      my @spineText   :Field( Get => 'GetSpineText',    Set => 'SetSpineText' );      my @weight      :Field( Get => 'GetWeight',       Set => 'SetWeight' );      my %initArgs :InitArgs = (         spinetext => {            Default => 0,            Field   => \@spineText,         },      );      sub _Init :Init {         my ( $self, $args ) = @_;         my $config = $args->{ config };         $self->SetConfig( $config );         if ( my $font = $config->{ font} ) {            $self->SetFont( $font );         } else {            $self->SetFont( DEFAULT_FONT );         }         if ( my $fontsettings = $config->{ fontsettings } ) {            $self->SetFontSettings( $fontsettings );         } else {            $self->SetFontSettings( DEFAULT_FONT_SETTINGS );         }         if ( my $italic = $config->{ italic } ) {            $self->SetItalic( $italic );         } else {            $self->SetItalic( DEFAULT_ITALIC );         }         if ( my $size = $config->{ size } ) {            $self->SetSize( $size );         } else {            $self->SetSize( DEFAULT_SIZE );         }         if ( my $weight = $config->{ weight } ) {            $self->SetWeight( $weight );         } else {            $self->SetWeight( DEFAULT_WEIGHT );         }      }      sub GetAll {         my ( $self ) = @_;         return {                  font          => $self->GetFont(),                  font_settings => $self->GetFontSettings(),                  italic        => $self->GetItalic(),                  size          => $self->GetSize(),                  spine_text    => $self->GetSpineText(),                  weight        => $self->GetWeight() };      }   }   package DVD::Kover::Title;   {      use strict;      use warnings;      use constant {         DEFAULT_COLOR         => '#000000',         DEFAULT_DISPLAY       => 0,         DEFAULT_FONT          => 'DejaVu Serif',         DEFAULT_FONT_SETTINGS => 'DejaVu Serif,20,-1,5,75,0,0,0,0,0',         DEFAULT_ITALIC        => 0,         DEFAULT_SIZE          => 20,         DEFAULT_WEIGHT        => 75,      };      use Object::InsideOut;      my @color        :Field( Get => 'GetColor',        Set => 'SetColor' );      my @config       :Field( Get => 'GetConfig',       Set => 'SetConfig' );      my @display      :Field( Get => 'GetDisplay',      Set => 'SetDisplay' );      my @font         :Field( Get => 'GetFont',         Set => 'SetFont' );      my @fontSettings :Field( Get => 'GetFontSettings', Set => 'SetFontSettings' );      my @italic       :Field( Get => 'GetItalic',       Set => 'SetItalic' );      my @size         :Field( Get => 'GetSize',         Set => 'SetSize' );      my @text         :Field( Get => 'GetText',         Set => 'SetText' );      my @weight       :Field( Get => 'GetWeight',       Set => 'SetWeight' );      my %initArgs :InitArgs = (         text => {            Default => [],            Field   => \@text,            Type    => 'LIST',         },      );      sub _Init :Init {         my ( $self, $args ) = @_;         my $config = $args->{ config };         $self->SetConfig( $config );         if ( my $color = $config->{ color } ) {            $self->SetColor( $color );         } else {            $self->SetColor( DEFAULT_COLOR );         }         if ( my $display = $config->{ display } ) {            $self->SetDisplay( $display );         } else {            $self->SetDisplay( DEFAULT_DISPLAY );         }         if ( my $font = $config->{ font} ) {            $self->SetFont( $font );         } else {            $self->SetFont( DEFAULT_FONT );         }         if ( my $fontsettings = $config->{ fontsettings } ) {            $self->SetFontSettings( $fontsettings );         } else {            $self->SetFontSettings( DEFAULT_FONT_SETTINGS );         }         if ( my $italic = $config->{ italic } ) {            $self->SetItalic( $italic );         } else {            $self->SetItalic( DEFAULT_ITALIC );         }         if ( my $size = $config->{ size } ) {            $self->SetSize( $size );         } else {            $self->SetSize( DEFAULT_SIZE );         }         if ( my $weight = $config->{ weight } ) {            $self->SetWeight( $weight );         } else {            $self->SetWeight( DEFAULT_WEIGHT );         }      }      sub GetAll {         my ( $self ) = @_;         return { color         => $self->GetColor(),                  display       => $self->GetDisplay(),                  font          => $self->GetFont(),                  font_settings => $self->GetFontSettings(),                  italic        => $self->GetItalic(),                  size          => $self->GetSize(),                  text          => $self->GetText(),                  weight        => $self->GetWeight() };      }   }}__END__</pre>
</article>
<article>
<h1>psh (jettero)</h1>
<pre class="block_code">#!/usr/bin/perluse strict;use Data::Dumper; $Data::Dumper::Indent = $Data::Dumper::Sortkeys = 1;use Term::ReadLine;if( $ARGV[0] eq "-h" or $ARGV[0] eq "--help" ) { exec "perldoc", $0; exit 900 }my $term = new Term::ReadLine 'psh';my $OUT  = $term->OUT || \*STDOUT;my @s = ();*d = *Dumper;BEGIN {    eval "require Math::Units::PhysicalValue; import Math::Units::PhysicalValue(qw(PV))";    unless( $@ ) {        *pv = *PV;        *p = *PV;    }}$SIG{INT} = sub { exit 0 };$SIG{HUP} = sub { exit 0 };print "Welcome to Paul's perl shell ", q($Revision: 1.16 $), " (type 'help' for documentation)\n";for my $file ("$ENV{HOME}/.psh_stack", "$ENV{HOME}/.pshrc") {    if( -f $file and open IN, $file ) {        local $/; my $thefile = <IN>;        no strict "vars";        eval $thefile;         die "(while evaluating $file): $@" if $@;    }}END {    eval { # try it... don't freak out if it doesn't work        $term->write_history("$ENV{HOME}/.psh_history");    };    open SOUT, ">$ENV{HOME}/.psh_stack" or die "couldn't save psh stack-data: $!";    print SOUT q(my $the_stack;);    print SOUT "", Data::Dumper->Dump([\@s], [qw(the_stack)]);    print SOUT q(        @s = @$the_stack if ref $the_stack;        print "[loaded ", int @s, " symbols into the stack.]\n";    );    close SOUT;}my $cmd  = 0;eval { # try it, but don't freak out if it fails...    $term->read_history("$ENV{HOME}/.psh_history");    print "[loaded ", int ($term->GetHistory), " command(s) from history file]\n";};print "\n";$term->ornaments('', '', '', '');our $PS1; $PS1 = "\\# psh> " unless $PS1;while ( defined ($_ = $term->readline(&sub_ps1_vars($PS1))) ) {    s/^\s*//; s/\s*$//; s/[\r\n]//g;    s/\bs(\d+)/\$s[$1]/g;    print "\r\e[2K"; # move to start of line and erase it    $cmd ++;    if( m/^(?:q|e|quit|exit)/ ) {        exit;    } elsif( m/^\/?(?:hist|last)\s*(\d*)/ ) {        my @hist = reverse $term->GetHistory;        my $max = ($1>0 ? $1-1 : $#hist);        for my $i ( reverse 0 .. $max ) {            print "$i - $hist[$i]\n";        }    } elsif( m/^\/?(?:help)/ ) {        system("perldoc", $0);    } elsif( m/^\/?(?:man|m)\b\s*(.+)/ ) {        system("man", &argparse($1));    } elsif( m/^\s*'\s*(.+)/ and my $args = &balanced_single_quotes($1) ) {        system(&argparse($args));    } elsif( m/^\/?(?:doc|func|f)\b\s*(.+)/ ) {        system("perldoc", "-f", &argparse($1));    } elsif( m/^\/?(?:s|l|stack|list)\b\s*(\d*)/ ) {        my $max = ($1>0 ? $1-1 : $#s);        for my $i ( reverse 0 .. $max ) {            my $r = "";            if( my $R = ref $s[$i] ) {                $r = "\t\t[$R]";            }            print "s$i = $s[$i]$r\n";        }    } elsif( m/./ ) {        my $val; NOSTRICT: {            no strict "vars";            $val = eval $_;        }        if( $@ ) {            $@ =~ s/\s*line \d+\.$//;            $@ =~ s/at\s*\(eval\s*\d+\)/in command #$cmd/;            warn "ERROR: $@\n";        } else {            &do_val( $val );            print "s0 = $val\n";        }        # this is actually automatic        # $term->addhistory($_) if /\S/;    }    print "\n";}sub sub_ps1_vars {    my $p = shift;    $p =~ s/\\#/$cmd/eg;    return $p;}sub do_val {    my $v = shift;    unshift @s, $v unless "$s[$#s]" eq "$v";    pop @s while @s > 50;}sub argparse {    my $args = shift;    #TODO: handle quotes    return split /\s+/, $args;}sub balanced_single_quotes {    my $v = shift;    my $cnt = () = $v =~ m/\'/g;    return undef unless ($cnt/2) == int ($cnt/2);    return $v;}__END__=head1 NAMEpsh -- yet another perl shell, complete with fun=head1 SYNOPSISI wanted a hilfe (pike shell) or python shell like setup forperl.  Because I designed the shell through actual use, I endedup including a few handy shortcuts and commands.=head1 THE STACKEverything returned from expressions you type is dumped into thestack (@s).  The most recent value is s0.  You can type the literal's0' anywhere in an expression and psh will substitue '$s[0]'(which also works).  You can similarly type 's15' for '$s[15]'.The @s never grows bigger than 50.You can view the stack with: 'list', 'l', 'stack', and 's'.These commands take an optional number (e.g. 'l 10') argument tolimit the lines printed.=head1 STRICTNESSYour expressions are evaluated under 'use strict'; but also underno strict 'vars'.  Warnings are not enabled, but you can 'usewarnings' in your .pshrc.=head1 HISTORYThe history is nothing fancy.  I highly recommend installingTerm::ReadLine::Gnu, but that is a personal preference I suppose.** However, your history will NOT save until you install it **You can list your history with 'last'.  Presently there is no wayto actually execute something from history other than the obviousarrow keys and/or vim keys (iff applicable).=head1 COMPLETE COMMAND LISTYou can lead each command with a '/' if you desire.  Why wouldyou want to? IRC and TinyFugue habits?  The '/' is optional.    last, hist        - show the history    s, l, stack, list - show the stack    man, m            - fork of man <something>    doc, func, f      - fork of perldoc -f <something>    '                 - arbitrary fork (checks for unbalanced 's)    help              - this document    q, e, quit, exit  - exit=head1 COMPLETE LIST OF SUBSTITUTIONS    *p  = *PV     -- from Math::Units::PhysicalValue (if available)    *pv = *PV     -- from Math::Units::PhysicalValue (if available)    *d  = *Dumper -- from Data::Dumper               (if available)    s/\bs(\d+)/\$s[$1]/g; # s0 becomes $s[0] and s2 becomes $s[2]=head2 GLOB SUB EXAMPLES    (Disclaimer: This may be a plug for PV. Meh.)        psh> p "3,000 ft"    psh> p "2 minutes"    psh> (s1/s2) + "0 miles/hour"Violla, s0 is now set to 17.05 miles/hour!Lastly, because you probably do not even have PV installed, but most likely do have Data::Dumper (since it's required):    psh> [qw(lol dude!)]    psh> d s0    psh> d [1, 2, 3]Oh and one more because strange attractors are neat.    psh> 7    psh> sqrt s0    psh> sqrt s0    psh> sqrt s0=head1 FILES    $ENV{HOME}/.psh_history - contains your command history    $ENV{HOME}/.psh_stack   - contains your stack in a Data::Dumper format    $ENV{HOME}/.pshrc       - evaled at starttime if it exists=head1 PS1I intend to add many bash substitutions, but for now only \# (cmdnumber) actually works.  You can (and possibly should) set yourPS1 in your .pshrc. I choose this because I like blue:    $PS1 = "\e[1;34m\\# psh>\e[0;37m ";=head1 AUTHORPaul Miller <japh@voltar-confed.org>=head1 VERSION$Id: psh,v 1.16 2006/05/11 17:14:33 jettero Exp $=head1 COPYRIGHTPublic Domain!  I relinquish all my rights to anything written in thisdocument/program.  However, I politely request that you leave myname on the project unless you rewrite, add, or alter the projectin such a way that the diff -u is bigger than the original sourcefile.=head1 SEE ALSONOTE: In a few ways this is a reduplication of the perl debugger.In many other ways, it is most definitely not.perl(1), perldebug(1), perldebtut(1)=cut</pre>
</article>
<article>
<h1>find directory ACL change in a tree (Discipulus)</h1>
<pre class="block_code">use strict;use warnings;use Win32::FileSecurity qw(Get EnumerateRights);use Data::Compare;open LOG, ">c:/scripts/acl3.log";select LOG;my $basedir = 'C:/inetpub/wwwroot/';my @sottrarre = split /\//, $basedir;my $targdir =  'yourfolder/';my $iniziale = $basedir.$targdir;my @cartelle = &recursive($iniziale);my %livelli =  &per_livelli(@cartelle);    print "PERMESSI DELLA ROOT\n\n";    &secdump($iniziale);    print "\n#######\n";foreach my $lvl(sort keys %livelli){      foreach my $item(keys %{$livelli{$lvl}} )      {        next if $item=~/_private|_vti_cnf|_vti_log|_vti_pvt|_vti_script|_vti_txt/;##skip vicious FrontPage dirs        &compara_madre($item,$lvl);      }}my $now = time();print "\n\nTEMPO TOTALE TRASCORSO: ",$now-$^T," SECONDI\n\n";################################################################################sub compara_madre{    my $figlio = shift;    my $lvl = shift;    return if $lvl == 0;    my $madre;    my $diff;    if ($figlio =~/[\w\d\.\s-]+\/$/){$diff = $&}    $madre = $figlio;    $madre =~s/$diff$//;    unless (Compare \$livelli{$lvl-1}{$madre}, \$livelli{$lvl}{$figlio} ){            print "################\n#DIFFERENZE TRA:\n$figlio\tFIGLIA DI\n$madre\n################\n";        foreach my $usr(keys %{$livelli{$lvl}{$figlio}}){            if (not defined $livelli{$lvl}{$figlio}{$usr})                {print "nessuna entry in $figlio per $usr\n";return}            if (not defined $livelli{$lvl-1}{$madre}{$usr})                {print "nessuna entry in $madre per $usr\n";return}            if  ($livelli{$lvl}{$figlio}{$usr} != $livelli{$lvl-1}{$madre}{$usr})            {                       print "MADRE: $madre\n";                       print "\t\tUSER: $usr\n";                       my @happy;                       EnumerateRights( $livelli{$lvl-1}{$madre}{$usr}, \@happy ) ;                       print "\n\t",join( "\n\t", @happy ), "\n";                       print "FIGLIO: $figlio\n";                       print "\t\tUSER: $usr\n";                       my @happytoo;                       EnumerateRights( $livelli{$lvl}{$figlio}{$usr}, \@happytoo ) ;                       print "\n\t",join( "\n\t", @happytoo ), "\n";            }          }          print "\n#######\n";    }}################################################################################sub recursive{ my $root  = shift;  my @dirs  = ($root);  for my $path (@dirs){    opendir ( CART, $path ) or next;   # skip dirs we can't read    while (my $file = readdir CART) {      next if $file eq '.' or $file eq '..'; # skip dot files      next if -l $path.$file;                # skip sym links        if ( -d $path.$file ) {             push @dirs, $path.$file."/";     # add dir to list               }    }    closedir CART; }  return @dirs;}################################################################################sub per_livelli{    my @dirs = @_;    my %livelli;    foreach my $ele (@dirs){             my @temp = split /\//, $ele;             $livelli{$#temp-$#sottrarre-1}{$ele}=&filsec($ele);    }  return   %livelli;}################################################################################sub filsec{        my $cart = shift;        my %hash;        next unless -e $cart ;        if ( Get( $cart, \%hash ) ) {return \%hash;}        else {print STDERR "Error #", int( $! ), ": $!" ;}}################################################################################sub secdump{        my ($cart, $name, $mask, @happy, %hash)= (shift, undef, undef, undef, undef);        if ( Get( $cart, \%hash ) ) {while( ($name, $mask) = each %hash ) {print "$name: $mask\n\t";}}        else {print( "Error #", int( $! ), ": $!" ) ;}}</pre>
</article>
<article>
<h1>Strangely addictive Tk::Zinc based game (thundergnat)</h1>
<pre class="block_code">use warnings;use strict;use Tk;use Tk::Zinc;use Time::HiRes qw( gettimeofday tv_interval );my ( $window_width, $window_height ) = ( 1000, 800 );my $top    = 30;my $bottom = $window_height - $top;my $left   = $top;my $right  = $window_width - $left;my ( %ball, %wall, %time, %parameter );my $delay_init = 0;$ball{velocity} = [ 0, 0 ];if ( $ARGV[0] and $ARGV[0] !~ /\D/ ) {    $delay_init = $ARGV[0];    set_parameters($delay_init);}elsif ( $ARGV[0] and $ARGV[0] =~ /\D/ ) {    die"Pass a numeric delay in milliseconds to override auto update speed detection.Something in the range 20-80 is recommended. For example:\n$0 50\n";}else {    set_parameters(50);}my $mw = MainWindow->new;$mw->geometry("${window_width}x$window_height");$mw->resizable( 0, 0 );my $zframe = $mw->Frame->pack( -expand => 1, -fill => 'both' );my $zinc = $zframe->Zinc(    -backcolor => 'black',    -render    => 1  )->pack(    -fill   => 'both',    -expand => 1,  );my $group = $zinc->add( 'group', 1, -visible => 1 );{    $ball{radius} = 20;    my $x = $window_width / 2;    my $y = $window_height / 2;    $ball{position} = [ $x, $y ];    $ball{widget} = $zinc->add(        'arc', $group,        [            [ $x - $ball{radius}, $y - $ball{radius} ],            [ $x + $ball{radius}, $y + $ball{radius} ]        ],        -filled    => 1,        -fillcolor =>          '=radial -20 -20|#ffffff 0|#f700f7 48|#900090 80|#ab00ab 100',        -linewidth => 0,        -visible   => 1,    );}$wall{widget} = $zinc->add(    'curve', $group,    [        [ $left,  $top ],        [ $right, $top ],        [ $right, $bottom ],        [ $left,  $bottom ],        [ $left,  $top ]    ],    -linecolor => '#00ff00',    -linewidth => 6,    -priority  => 100,    -visible   => 1,);$time{current}{widget} = $zinc->add(    'text', $group,    -position => [ $window_width / 8, 0 ],    -color    => '#c0c000',    -font     => "Times 14",    -visible  => 1,);$time{power}{widget} = $zinc->add(    'text', $group,    -position => [ $window_width / 8 * 3, 0 ],    -color    => '#c0c000',    -font     => "Times 14",    -visible  => 1,);$time{high}{widget} = $zinc->add(    'text', $group,    -position => [ $window_width / 8 * 5, 0 ],    -color    => '#c0c000',    -font     => "Times 14",    -visible  => 1,);$zframe->bind( '<Enter>' => sub { $zframe->configure( -cursor => 'dot' ) } );$zframe->bind( '<Leave>' => sub { $zframe->configure( -cursor => 'arrow' ) } );$time{current}{value} = gettimeofday;$time{high}{value}    = 0;my $repeat = $mw->repeat( $parameter{delay}, \&update );MainLoop;sub update {    my ( $x,  $y )  = @{ $ball{position} };    my ( $dx, $dy ) = @{ $ball{velocity} };    my ( $mx, $my ) =      ( $mw->pointerx - $mw->x, $mw->pointery - $mw->y );    # mouse position    my $ximpulse = 0;    my $yimpulse = 0;    $parameter{repel} -= $parameter{repel_decay};            #power decay    my $elapsed = tv_interval( [ $time{current}{value} ], [gettimeofday] );    $zinc->itemconfigure( $time{current}{widget},        -text => ( sprintf "Current %.2f Secs.", $elapsed ) );    my $percent = sprintf "%.1f",      $parameter{repel} / $parameter{repel_start} * 100;    $zinc->itemconfigure( $time{power}{widget}, -text => "$percent% Power" );    if ( $time{high}{value} < $elapsed ) {        $time{high}{value} = $elapsed;        $zinc->itemconfigure( $time{high}{widget},            -text => ( sprintf "High  %0.2f : $percent%%", $elapsed ) );    }    if (    $my > $top - $ball{radius}        and $my < $bottom + $ball{radius}        and $mx > $left - $ball{radius}        and $mx < $right + $ball{radius} )    {        my $y_component = $y - $my;        my $x_component = $x - $mx;        my $impulse     = $parameter{repel} * $parameter{delay}**.3 * 150 /          ( $y_component**2 + $x_component**2 );        $yimpulse = $y_component * $impulse;        $ximpulse = $x_component * $impulse;    }    $dx *= .99;    # a little velocity decay.    $dy *= .99;    if (   ( $x - $ball{radius} + $dx < $left )        or ( $x + $ball{radius} + $dx > $right ) )    {        $dx = -$dx;        reset_time( $elapsed, $percent );    }    if (   ( $y - $ball{radius} + $dy < $top )        or ( $y + $ball{radius} + $dy > $bottom ) )    {        $dy = -$dy * .75;        reset_time( $elapsed, $percent );    }    $zinc->translate( $ball{widget}, $dx, $dy );    $dy += $parameter{gravity} + $yimpulse;    $dx += $ximpulse;    my ( $x0, $y0, $x1, $y1 ) = $zinc->bbox( $ball{widget} );    $ball{position} = [ ( $x0 + $x1 ) / 2, ( $y0 + $y1 ) / 2 ];    $ball{velocity} = [ $dx, $dy ];    unless ( $delay_init and $elapsed ) {        $delay_init = $elapsed;        set_parameters( int( $delay_init * 250 ) );        $repeat->cancel;        $mw->repeat( $parameter{delay}, \&update );    }}sub reset_time {    my ( $elapsed, $percent ) = @_;    printf "%.2f Seconds : %.1f%% Power\n", $elapsed, $percent      if $elapsed > 10;    $time{current}{value} = gettimeofday;    $parameter{repel} = $parameter{repel_start};}sub set_parameters {    $parameter{delay}       = shift;    $parameter{gravity}     = $parameter{delay} / 15;    $parameter{repel_start} = $parameter{gravity}**.5 / 3;    $parameter{repel}       = $parameter{repel_start};    $parameter{repel_decay} =      $parameter{repel_start} / ( 70000 / $parameter{delay} );    print "Delay set to $parameter{delay} ms.\n\n" if $delay_init;}</pre>
</article>
<article>
<h1>script-starter (frodo72)</h1>
This is the template (living in Linux, I put it into <tt class="inline_code">$HOME/.module-starter/script.tpl</tt>):<pre class="block_code">#!/usr/bin/perluse strict;use warnings;use Carp;use Pod::Usage qw( pod2usage );use Getopt::Long qw( :config gnu_getopt );use version; my $VERSION = qv('0.0.1');my %config;GetOptions(\%config, 'usage', 'help', 'man', 'version');pod2usage("$0 v$VERSION") if $config{version};pod2usage(-verbose => 99, -sections => 'USAGE') if $config{usage};pod2usage(-verbose => 99, -sections => 'EXAMPLES|USAGE|OPTIONS')  if $config{help};pod2usage(-verbose => 2) if $config{man};# Other recommended modules (uncomment to use):#  use IO::Prompt;#  use Readonly;#  use Data::Dumper;#  use Log::Log4perl qw( :easy );# Script implementation here__END__=head1 NAME<SCRIPT-NAME> - [A line to describe the script]=head1 VERSIONSee version at beginning of script, variable $VERSION.=head1 EXAMPLES   shell$ <SCRIPT-NAME>=for the author:   Some brief example to show the most common usage for the script. This   will probably be the most read section, so include meaningful   examples.  =head1 USAGE   <SCRIPT-NAME> [--usage] [--help] [--man] [--version]=for the author:   Include a complete usage block of text, like any other good command  =head1 DESCRIPTION=for the author:   A complete description of the script and its characteristics, with a   possible structure into deeper sections (via =head2, =head3). Leave   options description for the next section!=head1 OPTIONS=for the author   A description of all the available options that the script accepts.   The pre-defined ones are already included, of course.=over=item --usageprint a concise usage line and exit.=item --helpprint a somewhat more verbose help, showing usage, this description ofthe options and some examples from the synopsis.=item --manprint out the full documentation for the script.=item --versionprint the version of the script.=back=head1 DIAGNOSTICS=for the author   Include all error messages and possible exit conditions, even those   that "should never happen".=over=item C<< Error message here, perhaps with %s placeholders >>[Description of first error...]=item C<< Another error message here >>[Description of another error...][... and so on...]=back=head1 CONFIGURATION AND ENVIRONMENT=for the author   Describe any configuration file that is used by the script, and   any environment variable that affects the its behaviour. Include   details about the position of the files, their formats, etc.  <SCRIPT-NAME> requires no configuration files or environment variables.=head1 DEPENDENCIES=for the author   A list of all modules the script is based for, together with an   indication of their version and the required perl version.None.=head1 BUGS AND LIMITATIONS=for the author   A list of all known problem about the script, with an indication of   when (and if) they will be eventually solved. Also include a   description of all feature restrictions and limitations.No bugs have been reported.Please report any bugs or feature requests to the AUTHOR=head1 AUTHORFlavio Poletti C<flavio [at] polettix.it>=head1 LICENCE AND COPYRIGHTCopyright (c) 2006, Flavio Poletti C<flavio [at] polettix.it>. All rights reserved.This script is free software; you can redistribute it and/ormodify it under the same terms as Perl itself. See L<perlartistic>and L<perlgpl>.=head1 DISCLAIMER OF WARRANTYBECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTYFOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHENOTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIESPROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHEREXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIEDWARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THEENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITHYOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALLNECESSARY SERVICING, REPAIR, OR CORRECTION.IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITINGWILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/ORREDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BELIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL,OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USETHE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEINGRENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR AFAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IFSUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OFSUCH DAMAGES.=cut</pre>This is the script that creates a new script based on the template above, I named it <tt class="inline_code">script-starter</tt><pre class="block_code">#!/usr/bin/perluse strict;use warnings;use Carp;use Pod::Usage ();use version; my $VERSION = qv('0.0.1');my $original = "$ENV{HOME}/.module-starter/script.tpl";# Other recommended modules (uncomment to use):#  use IO::Prompt;#  use Perl6::Export;#  use Perl6::Slurp;#  use Perl6::Say;#  use Regexp::Autoflags;#  use Readonly;# Script implementation heremy $script_name = shift;if (! defined $script_name ) {   Pod::Usage::pod2usage(-verbose => 1);   exit 0;}if ($script_name =~ /-h|--help/) {   Pod::Usage::pod2usage(-verbose => 2);   exit 0;}croak "file '$script_name' already exists, stopped" if -e $script_name;open my $input_fh, '<', $original  or croak "open() for original '$original': $!";open my $output_fh, '>', $script_name  or croak "open() on '$script_name': $!";while (<$input_fh>) {   s/<SCRIPT-NAME>/$script_name/g;   print {$output_fh} $_;}close $input_fh;close $output_fh;__END__=head1 NAMEscript-starter - create the base for a new script=head1 VERSIONThis document describes script-starter version 0.0.1=head1 SYNOPSIS   # Ask for help   shell$ script-starter      # Generate a new script from the template   shell$ script-starter nome-script  =head1 DESCRIPTIONThis script helps to create other scripts, in a way much similar tomodule-starter. It takes the $original script (see start of script)and copies to the destination one, setting the script name on thefly.=head1 INTERFACEThe script requires only one argument, which should be a validfilename for a non-existing file.When called without options, it prints the examples in the L<SYNOPSIS>.When called with -h/--help, it perldoc-s the script to show thishelp page.=head1 DIAGNOSTICS=over=item C<< file '$script_name' already exists, stopped at... >>The name of the script to be generated refers to an already existing file.This is not allowed, script-starter won't let you shoot at your feet soeasily. Note that there is still space for a race condition between theexistence test and the actual file open for writing, be sure to aim well.=item C<< open() for original '/path/to/template': <specific error> >>There was a problem opening the template file.=item C<< open() on '/path/to/target-script': <specific error> >>There was a problem opening the target file.=back=head1 CONFIGURATION AND ENVIRONMENTGiven the fact that I'll never publish this script, it can be easilytweaked modifing the C<$original> variable at the beginning, whichpoints to the template model.=head1 DEPENDENCIESA few:=over=item -version=item -Pod::Usage=back=head1 INCOMPATIBILITIESNone reported.=head1 BUGS AND LIMITATIONSNo bugs have been reported.Please report any bugs or feature requests through http://rt.cpan.org/=head1 AUTHORFlavio Poletti C<< flavio@polettix.it >>=head1 LICENCE AND COPYRIGHTCopyright (c) 2006, Flavio Poletti C<< flavio@polettix.it >>. All rights reserved.This script is free software; you can redistribute it and/ormodify it under the same terms as Perl itself. See L<perlartistic>and L<perlgpl>.Questo script  software libero: potete ridistribuirlo e/omodificarlo negli stessi termini di Perl stesso. Vedete ancheL<perlartistic> e L<perlgpl>.=head1 DISCLAIMER OF WARRANTYBECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTYFOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHENOTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIESPROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHEREXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIEDWARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THEENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITHYOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALLNECESSARY SERVICING, REPAIR, OR CORRECTION.IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITINGWILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/ORREDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BELIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL,OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USETHE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEINGRENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR AFAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IFSUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OFSUCH DAMAGES.=head1 NEGAZIONE DELLA GARANZIAPoich questo software viene dato con una licenza gratuita, nonc' alcuna garanzia associata ad esso, ai fini e per quanto permessodalle leggi applicabili. A meno di quanto possa essere specificatoaltrove, il proprietario e detentore del copyright fornisce questosoftware "cos com'" senza garanzia di alcun tipo, sia essa espressao implicita, includendo fra l'altro (senza per limitarsi a questo)eventuali garanzie implicite di commerciabilit e adeguatezza peruno scopo particolare. L'intero rischio riguardo alla qualit edalle prestazioni di questo software rimane a voi. Se il softwaredovesse dimostrarsi difettoso, vi assumete tutte le responsabilited i costi per tutti i necessari servizi, riparazioni o correzioni.In nessun caso, a meno che ci non sia richiesto dalle leggi vigentio sia regolato da un accordo scritto, alcuno dei detentori del dirittodi copyright, o qualunque altra parte che possa modificare, o redistribuirequesto software cos come consentito dalla licenza di cui sopra, potressere considerato responsabile nei vostri confronti per danni, iviinclusi danni generali, speciali, incidentali o conseguenziali, derivantidall'utilizzo o dall'incapacit di utilizzo di questo software. Ciinclude, a puro titolo di esempio e senza limitarsi ad essi, la perditadi dati, l'alterazione involontaria o indesiderata di dati, le perditesostenute da voi o da terze parti o un fallimento del software adoperare con un qualsivoglia altro software. Tale negazione di garanziarimane in essere anche se i dententori del copyright, o qualsiasi altraparte,  stata avvisata della possibilit di tali danneggiamenti.Se decidete di utilizzare questo software, lo fate a vostro rischioe pericolo. Se pensate che i termini di questa negazione di garanzianon si confacciano alle vostre esigenze, o al vostro modo diconsiderare un software, o ancora al modo in cui avete sempre trattatosoftware di terze parti, non usatelo. Se lo usate, accettate espressamentequesta negazione di garanzia e la piena responsabilit per qualsiasitipo di danno, di qualsiasi natura, possa derivarne.=cut</pre>
</article>
</main></body></html>

/zed	open this help page
gogle://	any standard PerlMonks shortcut like pad://, cpan:, etc.
/cb60	open mini-cb60.flux8.com
/nn	open Newest Nodes
/float	float zedulator in a chromeless window
/filepath	open a local file

searches	automatically appear in bottom frame
links in other zedulator frames	drag and drop the link to the search input box and submit the search
browser bookmarks	copy the link, paste it into the search input box and submit the search

create custom search shortcuts	edit the shortcut/url associations in zedulator.html
start with page other than zedulator help	edit the browse_frame.src in zedulator.html
permanent resize/move/ delete frame	edit framesets in zedulator.html
retarget search to tab or window	edit the form target in zedulator.search.html