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>
</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