snippet

Gtk2-annotate-draggable texts on image (zentara)

Someone on a newsgroup asked how to do this, and I thought it would be easy( like with Tk :-) ) However, I found that dragging text in Gtk2 needs 1 undocumented trick..... the text needs to be in a group of it's own. So I post this to save others the brainf**k.

This may be useful for placing text on maps, or identifying people in photos, etc. I know Gimp does that, but this is easierfor quick jobs. It saves a screenshot when desired.

#!/usr/bin/perluse warnings;use strict;use Gtk2 '-init';use Gnome2::Canvas;use Glib qw/TRUE FALSE/;my $file = shift or die "Need an image file $!\n";#draggable text to addmy @text =(['foobar',20,20,'Arial Bold 60','yellow'],           ['foobaz',20,100,'monospace Bold 14','green'],           ['goobar',20,150,'Sans Bold 24','pink'],            );my ( $dragging, $last_x, $last_y ); # item_move globalsmy $window = Gtk2::Window->new();$window->set_title('Text Dragging');# you may want to make this smaller for small photos$window->set_size_request(350,250);$window->signal_connect('destroy'=>\&delete_event );my $vbox= Gtk2::VBox->new(FALSE, 1 );$window->add($vbox);my $scroller = Gtk2::ScrolledWindow->new();my $canvas = Gnome2::Canvas->new_aa();$scroller->add($canvas);my $hbox= Gtk2::HBox->new(TRUE, 1 );$vbox->pack_start($hbox,TRUE,TRUE,0);$hbox->set_border_width(2);$hbox->add($scroller);$vbox->pack_start(Gtk2::HSeparator->new, FALSE, FALSE, 0);my $hbox1= Gtk2::HBox->new(FALSE, 1 );$vbox->pack_end($hbox1,FALSE,FALSE,0);$hbox1->set_border_width(2);my $button1 = Gtk2::Button->new('Screenshot Window');$hbox1->pack_start( $button1, FALSE, FALSE, 0 );$button1->signal_connect( clicked => \&screenshot );my $label_w_markup = Gtk2::Label->new();$label_w_markup->set_markup(   "Resize to desired size\n before screenshot");$hbox1->pack_end( $label_w_markup, FALSE, FALSE, 0 );my $root   = $canvas->root;my $im = Gtk2::Gdk::Pixbuf->new_from_file( $file );my $image = Gnome2::Canvas::Item->new ($root,       'Gnome2::Canvas::Pixbuf',         pixbuf => $im,       x      => 0,                  y      => 0,       width  => $im->get_width,       height => $im->get_height,       anchor => 'nw',       );$canvas->set_scroll_region(0,0,$im->get_width,$im->get_height);$image->lower_to_bottom();foreach my $t( @text ){ my ($text,$x,$y,$font,$color) = @$t;my $font_desc = Gtk2::Pango::FontDescription->from_string($font);my $layout = $canvas->create_pango_layout($text);$layout->set_font_description($font_desc);my $tgroup = Gnome2::Canvas::Item->new ($root, 'Gnome2::Canvas::Group',       x => $x,       y => $y);    Gnome2::Canvas::Item->new($tgroup, 'Gnome2::Canvas::Text',                     text=> $text ,                     font_desc=>$font_desc,                     anchor =>'nw',     fill_color=> $color,                     x=>0, y=>0);$tgroup->raise_to_top();$tgroup->signal_connect( "event", \&item_move );}$window->show_all();Gtk2->main();################################################sub delete_event {    Gtk2->main_quit;    return FALSE;}  #############################################sub item_move {    my ( $item, $event ) = @_;#       print "$item $event->type\n";    if ( $event->type eq "button-press" ) {        $item->raise_to_top();        $canvas->window->set_cursor( Gtk2::Gdk::Cursor->new('fleur') );        $last_x   = $event->x;        $last_y   = $event->y;        $dragging = 1;    }    elsif ( $event->type eq "motion-notify" ) {        if ($dragging) {            my $new_x = $event->x;            my $new_y = $event->y;            $item->move( $new_x - $last_x, $new_y - $last_y );            $last_x = $new_x;            $last_y = $new_y;        }    }    elsif ( $event->type eq "button-release" ) {         $dragging = 0;         $canvas->window->set_cursor (undef);    }return 0;}##############################################################sub get_filename{my $dstr = sprintf q{%02d%s%d}, (split /\s+/,localtime)[2,1,4];return $dstr.time.'.jpg';} #####################################sub screenshot{#we are going to save the visible canvas windowmy ($width, $height) = $canvas->window->get_size;# create blank pixbuf to hold the imagemy $gdkpixbuf = Gtk2::Gdk::Pixbuf->new ('rgb',                    0,                    8,                    $width,                    $height);$gdkpixbuf->get_from_drawable ($canvas->window,              undef, 0, 0, 0, 0, $width, $height);#only jpeg and png is supported !!!! it's 'jpeg', not 'jpg'$gdkpixbuf->save ( get_filename() , 'jpeg', quality => 100);return FALSE;}#####################################################__END__

rightway from US.pm (Intrepid)

Let it be more convenient to use the 3rd-party unix-like sh shells with/from Win32-ish Perls.

This code is written as a module so that it is convenient to use from the command line. Seethe SYNOPSIS section in the embedded POD, below.

package US;use strict;use warnings;use vars qw($VERSION @ISA @EXPORT);sub rightway;$VERSION ='0.01';use base 'Exporter';@EXPORT  = ('rightway');=head1 NAMEUS.pm - correct slash orientation in file path specs from native Win32 to Perl-canonical form.=head1 VERSIONThis documentation describes version B<0.01> of US.=head1 SYNOPSIS  use US;  use Win32;  use File::Glob 'bsd_glob';  {      local $\ = "\n";      print for glob(         rightway Win32::GetShortPathName(Win32::GetFolderPath(Win32::CSIDL_COMMON_DOCUMENTS))       . "/*") ;  }=head1 DESCRIPTIONMakes it more convenient to use the 3rd-party unix-like sh shells with/from Win32-ish Perls."US" as a name was not chosen with a nationalistic or xenophobic intention. The authorexpects to use this code mainly from the commandline (in "1-liners" as we say in Perl),and as such a short, easy to remember name is a matter of convenience. Ok? "U"=="Unix","S"=="Slash". Thus, "US.pm".=cut=head1 EXPORTED FUNCTIONS=head2 rightway=cutsub rightway ($) {    my $pstr = shift @_;    $pstr=~ s{\\}{/}g;    $pstr;}1; # US like all modules, should return "TRUE".__END__=head1 AUTHOR, WARRANTY, COPYRIGHT, & LICENCE INFONO COPYRIGHT, NO WARRANTY, USE AT OWN RISK.Created Oct 25 2006 by Soren Andersen. This code is considered by theauthor to be so obvious and trivial that he hereby releases all claimof rights to (and disclaims any responsibility for) the code, andplaces it in the PUBLIC DOMAIN. Last modified: 25 Oct 2006 at 09:31 AM EDT=cut

csv2sql.pl (ciderpunx)

For various reasons I had a bunch of csv files that should really have been in a database. cvs2sql is a little script that helped me put them there (relatively) painlessly. Perhaps it might be useful for others at some point.

#!/usr/bin/perl=head1 NAMEcsv2sql.pl=head2 VERSION0.1=head1 SYNOPSISread a csv file and convert fields from first line into sqlinsert statements=head2 OPTIONS=over=item   name of the database and table into which we want to insert=back=head1 REQUIREMENTSPerl 5.8.4 (not tried on other versions)Text::CSV_XS IO::Handle=head1 COPYRIGHT AND LICENCE               Copyright (C)2006  Charlie Harvey This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA. Also available on line: http://www.gnu.org/copyleft/gpl.html=head1 SEE ALSO=cutuse strict;use warnings;use Text::CSV_XS;use IO::Handle;my $usage="Usage: $0 ";die $usage unless($#ARGV==0);my ($db,$table)=(split/:/,shift);die $usage unless($db && $table);my $sql = "INSERT INTO `$db`.`$table` ";my $csv = Text::CSV_XS->new ({binary=>1});my $in  = IO::Handle->new;my $out = IO::Handle->new;$in->fdopen(fileno(STDIN), 'r') or die "Can't fdopen STDIN: $!\n";$out->fdopen (fileno (STDOUT), "w") or die "Cannot fdopen STDOUT: $!\n";$csv->parse($in->getline) or die ("Can't parse first line of STDIN! $!\n");my $cols = "(";my $col_count =0;for ($csv->fields){  $cols .= "`$_`, ";  $col_count++;}$cols =~ s/, $//;$sql  .= "$cols) VALUES ";while (!$in->eof) {  IO::Handle->input_record_separator("\n");  my $row = $csv->getline($in);  next unless defined $row ;  if((@$row) != $col_count) {    warn "Odd row: " ;    warn (join ", ",@$row);    warn "\nExpecting $col_count elements, got " . (@$row) . "\n";    next;  }  my $vals='';  for(@$row) {    $_=~s/"/\\"/g;    $vals.='"' .$_ .'", ';  }  $vals =~s/, $//;  $sql.= "($vals), \n";}undef $in;$sql=~s/, $/;/;$out->print($sql);undef $out;

Testing hash equality and reporting differences (GrandFather)

I needed to be able to check that two hashes have the same contents as part of a test suite. A [Super Search] turned up [id://89879] which has answers for the equality bit, but doesn't address the reporting bit.

The following code uses [mod://List::Compare::Functional] to assist in comparing two hashes and reporting differences between them. Note that the application specific warning strings may need to be adjusted for your context. :-)

use List::Compare::Functional qw(get_unique get_complement);sub hashesEqual {    my ($have, $want) = @_;    my @keysHave = sort keys %$have;    my @keysWant = sort keys %$want;    my @haveOnly = get_unique ([\@keysHave, \@keysWant]);    my @wantOnly = get_complement ([\@keysHave, \@keysWant]);        if (@haveOnly) {        warn 'Unexpected parameters ' . (join ',', @haveOnly) . " for email send\n";        return;    }        if (@wantOnly) {        warn 'Expected parameters ' . (join ',', @haveOnly) . " missing for email send\n";        return;    }        my $ok = 1;    for (@keysHave) {        next if $have->{$_} eq $want->{$_};        $ok = undef;        warn "Email send parameter $_ expected '$want->{$_}', got '$have->{$_}'\n";    }        return $ok;}

How to quickly display an image on a webpage via perl (Melly)

This one seems to come up a lot in Seekers, so I thought I'd drop a simple script in here.

Although this script displays a random image from a specified directory, the principle should be adaptable to any image display code... basically, use a "Location:" redirect...

#!/usr/bin/perl -wT use strict;# Call in img tag - e.g.: my @files = glob("./jpegs/*.jpg");print "Location: $files[int(rand @files)]\n\n";

HTML Tables - populating TD from an array (Melly)

Although it's fairly easy to write a series of "print '<TD>', $_->[0], '</TD>'" statements to populate table TD elements with the contents of an array, it's not necessarily obvious how to do it using the more formal CGI syntax.

However, [davidrw] [id://577404|enlightened me] on the use of [doc://map] for such cases.

use CGI qw(:standard);@links = (  ['CPAN', 'http://cpan.perl.org'],  ['Active State', 'http://www.activestate.com'],  ['Perl Monks', 'http://www.perlmonks.org']);print start_html('Perl Links');print table({-border=>1},  Tr([    th(['Site', 'URL']),    map{      td([$$_[0], a({-href=>$$_[1]},$$_[1])])    }@links  ]));print end_html();

METAreqWeb - overview of CPAN dist prerequisites (Intrepid)

Solution to a chatterbox FAQ: what modules required are shipped with Perl? Which are already on the system?

This cli script sits at the corner of my desk awaiting the next time I am looking up Perl modules at search.cpan.org.

Finding the module I am interested in, I examine its directory (like: http://search.cpan.org/~moconnor/YAML-AppConfig-0.16/ ) ... there are a number of files listed, including Makefile.PL (or Build.PL), MANIFEST, README, and ...META.yml.

I context-click on the META.yml file and click "Copy Link Location" to put the URL pointing to the META.yml file on the system clipboard. Then I run the snippet below to quickly get the overview of this module's prerequisites.

#!/usr/bin/env perl# Last modified: 10 Oct 2006 at 12:02 PM EDT# Author: Soren Andersen # $Id$use strict;use warnings;use YAML qw/ Load Dump LoadFile /;use LWP::Simple;use POSIX qw(isatty);sub coremod { "" };sub hr;sub dimmer;sub find_longest_keystring;sub mtest;sub testyml {    my $metayml_uri =      (shift(@_) || 'http://search.cpan.org/src/RUBYKAT/html2dbk-0.03/META.yml');    my $docu;    if( $docu = get $metayml_uri ) {return $docu    }    die "Could not retrieve '$metayml_uri'. Network troubles? Bad URI?";}## And now a brief interlude of presentational trivia, not very interestingmy $screenW = $ENV{COLUMNS} || 42;my $unxterm = isatty(*STDOUT) && $^O !~/MSWin32/ ? 1 : 0;if ($unxterm) {    require Term::ANSIColor and import Term::ANSIColor ('colored');   #print colored("Using Term::ANSIColor", 'dark white'), "\n";} ## done with interlude, back to main showmy $metadoc = testyml (shift(@ARGV) || undef);my $modmeta = Load( $metadoc );if( $modmeta->{requires} ) {    my ($k,$v);    my $fmtlen;    my %reqrs = %{                   my($mkl,@hash)                    = find_longest_keystring($modmeta->{requires});                   $fmtlen = $mkl || 28;                   my $rh = {@hash};                 };    if (eval "use Module::CoreList; 1" and not $@)    {        no warnings ('redefine','once');        sub coremod        {            my($pm) = @_;            my $presence_in_core = $Module::CoreList::version{$]}{$pm};            return "\n" unless defined $presence_in_core;            my $pmv;            $pmv = $presence_in_core == 0 ? "without a VERSION number"               : "version $presence_in_core";            my $prn  = Module::CoreList->first_release($pm);            my $note = <<"        ELEPHANT";  CORE: $pm was first included in the core Perl distribution at Perl release $prn        The present Perl system shipped with $pm $pmv        ELEPHANT            return $note;        }    }    print hr;    printf <<"        YODOWN" %-${fmtlen}s %s   %s%s        YODOWN => ($k,($v eq '0'? 'any version':"at version $v") , mtest($k), coremod($k))           while ($k,$v) = each %reqrs;    print hr;} else # there are no prerequisite modules or pragmata listed    {  print "No requires for $modmeta->{name}\n"; }sub mtest{    my $installed_version;    my $wherep;    my $modname = shift();    my $modlibp = $modname;    $modlibp =~ s{ :: } {/}xg;    $modlibp .= '.pm';    my $can_req = eval "use $modname; 1;";  if   ($can_req and not $@)    {        no strict 'refs';        $wherep = $INC{ $modlibp };        $installed_version = (${$modname.'::VERSION'}) || 0;    }  else    {        return colored(sprintf(            "%-32s is not installed"=> $modname) , 'cyan')           if ($unxterm);        return sprintf(            "%-32s is not installed"=> $modname)    }        if ($unxterm) {    colored(        sprintf('%-32s v%4s found as %s'         => ($modname , $installed_version , $wherep))      , 'magenta' );    } else {        sprintf('%-32s v%-4s found as %s'         => ($modname , $installed_version , $wherep))    }}sub find_longest_keystring{    my %rethash = %{ shift() };    return () unless 1 * @{[ %rethash ]};    delete $rethash{'perl'};    my $l_maxed_at = 0;    for (keys(%rethash)) {$l_maxed_at = length() > $l_maxed_at ? length() : $l_maxed_at    }    return ( $l_maxed_at, %rethash );}sub hr{    my $decor = $unxterm      ? dimmer("-" x $screenW)      :       ("-" x $screenW);    $decor . "\n";}sub dimmer{    colored( shift() , 'dark white' );}__END__=head1 NAMEMETAreqWeb=head1 SYNOPSIS  ./METAreqWeb [  ]=cut

Tk Realtime data aquisition (zentara)

[id://576881] prompted me to try it. This is a realtime Tk data graph, getting the data through a socket connection. I made it as simple as I could for demo purposes. It will monitor for 86400 seconds ( broke the minutes into 10'ths). I also just let the sending script send a count (0..86400), mostly so I could speed it up for testing. In reality, you would want the sender to send the time of it's read, instead of the count.

I noticed that as the data array(for the curve) got bigger, the cpu rate would rise to handle reconfiguring the curve with the huge array. So I broke the day into 500 second segments, which limits the point data array to 1000 elements. On my machine the cpu usage varied between 5 and 10%.

There are 2 scripts, the socket-sender-test and the main Tk program.The socket-sender-test

#!/usr/bin/perluse IO::Socket;my $machine_addr = 'localhost';$sock = new IO::Socket::INET(PeerAddr=>$machine_addr,      PeerPort=>7070,      Proto=>'tcp',      );die "Could not connect: $!" unless $sock;foreach my $count(1..86400){  my $temp = 800 + int(rand 100);  my $send = "$count $temp";  print $sock "$send\n";  print "$send\n";  select(undef,undef,undef,.1) ;}close ($sock);__END__

And the Tk monitor

#!/usr/bin/perluse warnings;use strict;use IO::Socket;use Tk;$|++;my $listen = IO::Socket::INET->new(    Proto       => 'tcp',    LocalPort   => 7070,    Listen      => 1,    Reuse       => 1,) or die "Can't create listen socket : $!\n";my $margin = 50;my $offset = 20;   #axis offsetmy $x_max = 86400;my $y_max = 1000;my $connected = 'Not Connected';my %data;            #why continuosly update the entire                     #data set? cpu rate will climb, so my $current_seg = 0; #break graph into 500 second segments                     #to avoid cpu rate climbing, will create     # 86400/500 =~ 175 lines (data) segemntsmy $mw = tkinit;$mw->fileevent($listen, 'readable', sub { new_connection($listen) });my $scanvas = $mw->Scrolled('Canvas',                 -width => 620,  -height => 420,                 -scrollregion => [-$margin,-$margin,                   $x_max + $margin,                   $y_max + $margin + $offset ], -bg => 'black')->pack();&build_axis();my $canvas = $scanvas->Subwidget('scrolled');$canvas->Tk::bind("", [ \&print_xy, Ev('x'), Ev('y') ]);sub print_xy {  my ($canv, $x, $y) = @_;  print "(x,y) = ", $canv->canvasx($x), ", ", $canv->canvasy($y), "\n";}#for simplicity create the lines firstforeach my $line(0..172){  push @{$data{$line}{'data'}},0,0,0,0; #initilize, will remove later  $data{$line}{'line_obj'} = $canvas->createLine(                            @{$data{$current_seg}{'data'}},                          -width => 1,                          -smooth => 1,  -fill => 'lightgreen');}my $subframe = $mw->Frame(-background =>'gray50')->pack(-fill => 'x');$subframe->Button(-text =>'Exit',            -background => 'hotpink',            -activebackground => 'red',    -command => sub{ exit }            )->pack(-side=>'left',-padx=>40);$subframe->Label(-textvariable => \$connected,            -background => 'black',    -foreground => 'green',            )->pack(-side=>'left');MainLoop;#######################################################################sub new_connection {    my ($listen) = @_;    my $client = $listen->accept() or warn "Can't accept connection";    $client->autoflush(1);    $mw->fileevent($client, 'readable', sub { handle_connection($client) });    $connected = 'Connected';}sub handle_connection {    my ($client) = @_;    my $message = <$client>;#    print "$message\n";#    if( $message = eof){print "crashed\n"}    if ( defined $message ) {     $message =~ s/[\r\n]+$//;     my ($x, $y) = split( " ", $message);            if( $#{$data{$current_seg}{'data'}} >  1000 ){  #2 entries per point       #initialize next segmnet, pop off last 2 of previous segment       my($xo,$yo) =  @{$data{ $current_seg}{'data'}}[-2, -1 ];       $current_seg++;       print "current seg $current_seg\n";           #inititialize by overwriting the initial 0,0,0,0       ${$data{$current_seg}{'data'}}[0] = $xo;       ${$data{$current_seg}{'data'}}[1] = $yo;       ${$data{$current_seg}{'data'}}[2] = $xo;       ${$data{$current_seg}{'data'}}[3] = $yo;      }        push @{$data{$current_seg}{'data'}}, $x, $y;        $scanvas->coords( $data{$current_seg}{'line_obj'}, @{$data{$current_seg}{'data'}} );     #$scanvas->xviewScroll(1,'units');      $scanvas->xview('moveto', $x/86400 );#     $text->insert('end', "Got message [$message]\t");#     $text->see('end');    }    else {       #$text->insert('end', "Connection Closed\n");       #$text->see('end');      $client->close();      $connected = 'NOT Connected';      print "not connected\n";     }}##############################################################sub build_axis{# axismy $xaxis = $scanvas->createLine( 0, $y_max + $offset, $x_max, $y_max + $offset,                          -width => 1,  -fill => 'lightblue');my $yaxis = $scanvas->createLine( 0, $y_max + $offset ,0,0,                          -width => 1,  -fill => 'lightgreen');# x axis ticksmy $tflag;my $labflag;my $min = 0;my $minflag = 0;my $hour = 0;my $hourflag = 0;my $tlength;my $color;for(1..$x_max){    $tflag = 0;    $tlength = 5;    $color = 'white';    $hourflag = 0;    $minflag = 0;    $labflag = 0;    if( ($_ % 10) == 0 ){ $tflag = 1 }  #minutes are broken into 10 sec intervals    if( ($_ % 60) == 0 ){ $tlength = 15 ;                           $color = 'yellow';   $min++;   $minflag = 1;  $labflag = 1;  }      if( ($_ % 3600) == 0 ){ $tlength = 25;                             $color = 'hotpink';                             $hour++;     $hourflag = 1;    $labflag = 1;    $min = 0;    $minflag = 0;   }    if( $tflag ){      $scanvas->createLine( $_, $y_max + $offset, $_, $y_max + $offset + $tlength,                          -width => 1,  -fill => $color);                   if($labflag){            my $label;    if($minflag){ $label = $min; }            if($hourflag){ $label = $hour; }          $scanvas->createText( $_,  $y_max + $offset + 1.2*$tlength,                           -text => $label,                   -fill => $color,   -anchor => 'n',   );           }     }}# y axis ticksmy $uflag;my $midflag;my @array = reverse(0..$y_max );for(@array){    my $num = $y_max - $_;  #reverse normal axis    $tflag = 0;    $tlength = 5;    $color = 'white';    $uflag = 0;    $midflag = 0;    $labflag = 0;    if( ($num % 10) == 0 ){ $tflag = 1 }    if( ($num % 50) == 0 ){ $tlength = 10 ;                           $color = 'yellow';   $midflag = 1;  $labflag = 1;  }      if( ($num % 100) == 0 ){ $tlength = 20;                             $color = 'hotpink';                             $uflag = 1;    $labflag = 1;    $midflag = 0;   }    if( $tflag ){      $scanvas->createLine( 0 - $tlength, $num + $offset, 0, $num + $offset,                          -width => 1,  -fill => $color);                   if($labflag){            my $label;    if($midflag){ $label =  $num; }            if($uflag){ $label =  $num; }          $scanvas->createText( -20 ,  $y_max + $offset - $num ,                           -text => $label,                   -fill => $color,   -anchor => 'e',   );           }     }}$scanvas->xview('moveto',0);$scanvas->yview('moveto',1);}

Timer for data recive????? (samirpatry)

i have a client/server program.Now i want to set timer for the same.That means if client send a request to the server and with 10 sec if the particular response is not arrive to the client then it will show the timeout.After that it will resend the request to the server and increase the value of timer.

The platform is windows

Customize your Test::More (Ovid)

The problem: your code sometimes does things that you do not want it to do while tests are running. Mocking up objects or methods is all fine and dandy, but if in the middle of a chunk of procedural code, you find yourself sending email by printing to a filehandle, that can be difficult to trap.

One solution is to wrap this code in a conditional, checking to see if $ENV{HARNESS_ACTIVE} or something is true. However, if you run your test script directly through perl and not through prove, that environment variable won't be set. One way of handling this is to use a custom Test::More module. The following snippet shows how to write one. It's a drop-in replacement for Test::More. You can include any behaviors you want, thereby making it easier for code to know if it's being run in a test environment.

  package My::Test::More;  use Test::Builder::Module;  @ISA = qw(Test::Builder::Module);    use Test::More;  @EXPORT = @Test::More::EXPORT;    # add whatever you need here  $ENV{WE_BE_TESTING} = 1;  1;

Tk photo pixel colors (zentara)

I saw this type of app in the Gtk2 examples, and thought it would be nice to have a Tk version. It loads a bmp, gif, jpg, or png and gives the pixel position, decimal rgb color, hex rgb color, and a color swatch.

#!/usr/bin/perluse warnings;use strict;use Tk;use Tk::JPEG;use Tk::PNG;my $file = shift || die "need a bmp, gif,jpg or png as arg 1\n";my $mw  = Tk::MainWindow->new;my $topframe = $mw->Frame(-bg => 'black')->pack(-fill=>'x');my $tf1 = $topframe->Frame(-bg => 'black')->pack(-side=>'left',-fill=>'x');my $xy = $tf1->Label(-text => '  X - Y  ',                       -fg => 'hotpink',       -bg => 'black',                  )->pack(-side => 'top',-padx=>2);my $rgb = $tf1->Label(-text => 'R - G - B',                       -fg => 'hotpink',       -bg => 'black',                  )->pack(-side => 'top', -padx=>2);my $hex = $tf1->Label(-text => '   HEX   ',                       -fg => 'hotpink',       -bg => 'black',                  )->pack(-side => 'top',-padx=>2);my $tf2 = $topframe->Frame(-bg => 'black')->pack(-side=>'left',-fill=>'x');my $xycurrent;my $xyr = $tf2->Label(-textvariable => \$xycurrent,                       -fg => 'lightgreen',       -bg => 'black',                  )->pack(-side => 'top',-padx=>2);my $rgbcurrent;my $rgbr = $tf2->Label(-textvariable => \$rgbcurrent,                       -fg => 'lightgreen',       -bg => 'black',                  )->pack(-side => 'top', -padx=>2);my $hexcurrent;my $hexr = $tf2->Label(-textvariable => \$hexcurrent,                       -fg => 'lightgreen',       -bg => 'black',                  )->pack(-side => 'top',-padx=>2);my $swatch = $topframe->Label(                     -text => '       ',                     -bg=>'black',                    )->pack(-side=>'left',-fill=>'y',-pady => 5); my $tf3 = $mw->Frame(-bg => 'hotpink')->pack(-fill=>'x');my $divider = $tf3->Label(                     -text => '       ',                     -bg=>'hotpink',                    )->pack(-side=>'left',-fill=>'y',-pady => 1); my $can = $mw->Scrolled('Canvas',                 -height => 400, -width  => 400, -scrollbars => 'osoe',                 -highlightthickness=>0, -borderwidth =>0,                 )->pack( -fill =>'both',-expand=>1);my $realcan = $can->Subwidget('scrolled');my $img = $mw->Photo( -file => "$file",       -palette => '256/256/256' );$can->createImage(0,0,  #hardcoded offset                  -image => $img,   -anchor => 'nw',  -tags => ['img'],   );my @bbox = $can->bbox( 'img'  );$can->configure(-scrollregion => [@bbox] );$realcan->Tk::bind("", [ \&print_xy, Ev('x'), Ev('y') ]);$realcan->Tk::bind("", sub{            $xycurrent  = '';            $rgbcurrent = '';    $hexcurrent = '';   });MainLoop();############################################################ a cheap hack to prevent the Tk Photo object from issuing# an out of bounds error if the window is expanded bigger # than the photosub Tk::Error { }#####################################################sub print_xy {  my ($canv, $x, $y) = @_;  $xycurrent = $canv->canvasx($x).' - '.$canv->canvasy($y);        my($r,$g,$b) = $img->get($canv->canvasx($x), $canv->canvasy($y) );   $rgbcurrent = sprintf('%.3d', $r).'-'.sprintf('%.3d', $g).'-'.sprintf('%.3d', $b);   #convert to hex from decimal   $r = sprintf('%.2x', $r);   $g = sprintf('%.2x', $g);   $b = sprintf('%.2x', $b);   $hexcurrent = $r.'-'.$g.'-'.$b; $swatch->configure(-bg=>"#$r$g$b");}

WMI: Classes (jschollen)

The last part of the triology ;-)After retrieving all namespaces and all the properties of the classes, this piece of code retrieves al the classes within a given namespace.

It works for me ('till now) and I'm using it on Windows XP SP2.

(thanks again to the Microsoft Scripting Guys for the vb code)

use Win32::OLE('in');use strict;my $stepOk = 1;my $errorMsg = "";my $wmiService = "";my $computer   = "."; # Computer to connect to: . = local hostmy $namespace  = "\\root\\cimV2"; # Namespace to connect tomy @classes    = ();$wmiService = Win32::OLE->GetObject("winmgmts:\\\\".$computer.$namespace);my $subDevices = $wmiService->SubclassesOf();foreach my $subDevProp ( in( $subDevices ) ){  print "Class $count: ".$subDevProp->{Path_}->{Path}."\n";  if($subDevProp->{Path_}->{Path} =~ /.*:(.*)/)  {    my $class = $1;    print "Detected class: $class\n";    push(@classes,$class);  }}# Scripted by jschollen# Thanks to the Microsoft Scripting Guys

WMI: Namespaces (jschollen)

This peace of code helps you retrieves all the namespaces that are on your pc.
All the namespaces are printed to the screen and are stored in the array @nameSpaces.
(Note that the stored namespaces are using a single backslash, which should be replaced by a double backslash in order to connect to it.)

The code works for me and I tested it on Windows XP SP2.

(Thanks to the Microsoft Scripting Guys for providing the vb code).

#!/usr/local/perluse Win32::OLE('in');use strict;# Variablesmy $stepOk     = 1;my $errorMsg   = "";my $wmiService = "";my $computer   = "."; # Computer to connect to: . = local hostmy @nameSpaces = ();enumNameSpaces("root");sub enumNameSpaces{  my $nameSpaceStr = shift;    print $nameSpaceStr."\n";  push(@nameSpaces,$nameSpaceStr);    $wmiService = Win32::OLE->GetObject("winmgmts:\\\\".$computer."\\".$nameSpaceStr);  ($stepOk = 0) unless $wmiService;  if(! $stepOk)  {    $errorMsg = "Unable to open wmi services";    print $errorMsg."\n";  }    my $subDevices = $wmiService->InstancesOf("__NAMESPACE");    foreach my $subDevProp ( in( $subDevices ) )  {    enumNameSpaces($nameSpaceStr."\\".$subDevProp->{Name});  }}# Scripted by jschollen# Thanks to the Microsoft Scripting Guys

WMI: display Class properties (jschollen)

This piece of code displays all the properties (with their values) that are available for a WMI class method.With it, you have to change just 1 parameter in stead off all the properties.

By changing the variables, you can change either the computer, namespace or class method.

I've tested in on an Windows XP SP2 machine, and had no problems so far.

(Thanks to the Microsoft Scripting guys for the vb code)

#!/usr/local/perluse Win32::OLE('in');use strict;my $stepOk = 1;my $errorMsg = "";# Variablesmy $wmiService = "";my $computer   = "."; # Computer to connect to: . = local hostmy $namespace  = "\\root\\cimV2"; # Namespace to connect tomy $class      = "CIM_Controller"; # Class Method from which you want to retrieve the properties$wmiService = Win32::OLE->GetObject("winmgmts:\\\\".$computer.$namespace);($stepOk = 0) unless $wmiService;if(! $stepOk){  $errorMsg = "Unable to open wmi services";  print $errorMsg."\n";}else{  my $subDevices = $wmiService->ExecQuery("Select * from ".$class);  print "***********************************************\n";  foreach my $subDevProp ( in( $subDevices ) )  {    foreach my $prop (in($subDevProp->{Properties_}))    {      print "***** ".$prop->{Name}.": ".$prop->{Value}."\n";    }    print "*********************************************\n";  }}# Scripted by jschollen# Thanks to the Microsoft Scripting Guys

Saving spreadsheets to HTML that have quotes in them. (blue_cowdawg)

In one of my hobby related tasks I get to create schedules for workers working rings at a dog trial. One of the annoyances I run into is when I have cells that have something like

20" - 24" walk through

the quotes and the dashes end being morphed into wide characters when I save the spreadsheet as HTML. When those wide characters get sent to a browser they end up looking like garbage instead of the dashes and quotes that I started with.

Using the od -c command I found that therewas an offending set of octals that showed up repeatedly everywhere that this offense occured. What follows is a one liner that removes them quite nicely.

 perl -spi -e 's/\342\200\235/"/g' dvgsdc.jsp

Get US stock tables from WSJ (Scott7477)

After years of posting daily stock prices on its website in practically useless pdf files; the Wall Street Journal has set up a page where one can download daily stock price data as CSV files. This script simply goes to the relevant page at WSJ.com, downloads the files, and names each file with the market acronym and the day's date concatenated.

use strict;use LWP::Simple;while (my $downloadurl = ){my $x="http://online.wsj.com/internal/mdc/";my $finurl=$x.$downloadurl;my @urlsplit=split /\./, $downloadurl; my $now_string = substr(localtime,0,11);my $savefilename = $urlsplit[0].$now_string;print $savefilename;print "\n";my $status = getstore($finurl,$savefilename);print $status."\n" if is_success($status);}__END__;NYSE.csv?mod=stocksdailyNasdaq.csv?mod=stocksdailySCAP.csv?mod=stocksdailyAMEX.csv?mod=stocksdaily

List all perldoc FAQs (Dietz)

This will list all FAQs from perlfaq[1-9] without their answers.
Just a modification of already imported subroutines from Pod::Perldoc.

Sample output:

$ perldocfaqsWhat is Perl?Who supports Perl?  Who develops it?  Why is it free?..snip...What machines support perl?  Where do I get it?...snip...How do I fetch/put an FTP file?How can I do RPC in Perl?

Lists all FAQs line by line

$ perldocfaqs -n[perlfaq1 - 01]  What is Perl?[perlfaq1 - 02]  Who supports Perl?  Who develops it?  Why is it free?...snip...[perlfaq2 - 01]  What machines support perl?  Where do I get it?...snip...[perlfaq9 - 25]  How do I fetch/put an FTP file?[perlfaq9 - 26]  How can I do RPC in Perl?

Called with '-n' lists all FAQs with leading file info and faq number

#!/usr/bin/perluse strict;use warnings;use File::Basename 'fileparse';use Pod::Perldoc;my $show_faqnums = (shift||0) eq '-n' ? 1 : 0;@ARGV = qw(-oText -q.);no warnings 'redefine';sub Pod::Perldoc::search_perlfaqs {  my ($self, $found_things, $pod) = @_;  local $_;  for my $file (@$found_things) {    my $perlfaq = fileparse($file, qr/\.pod/);    open(INFAQ, '<', $file) or die "$file: $!\n";    my $faqnum = sprintf '%02d', 1;    while () {      if (/^=head2\s/) {        $show_faqnums and substr($_, 7, 0, "[$perlfaq - $faqnum]  ");        push @$pod, "$_\n";        $faqnum++;      }    }    close(INFAQ);  }  return;}sub Pod::Perldoc::page {  my ($self, $output) = @_;  open(TMP, '<', $output) or die "$output: $!\n";  local $_;  while () {    s/^\s+//;    print or die "$!\n";  }  close TMP or die "$output: $!\n";  $self->unlink_if_temp_file($output);  return;}Pod::Perldoc->run();

Reaped: (NodeReaper)

This node was taken out by the NodeReaper on 2006-09-18 10-04-01
Reason: [davorg]: reap

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

quick startup time profiler (merlyn)

I was curious about the startup time of my program, so I wanted to figure out how many lines of code were being loaded and how long that was taking.

So I created "MM.pm", and loaded my top-level module with perl -MMM -MMy::Module -e0. MM shows real time, and cpu for user, system, child user, and child system, and then opens each of the included modules and gives a line count, including a total linecount.

package MM;my @times = (time, times);END {  warn sprintf("real %d, user %.2g, sys %.2g, cuser %.2g, csys %.2g\n",       map { $_ - shift @times } time, times);  local *ARGV;  @ARGV = sort values %INC;  my $sum = 0;  while (<>) {    next unless eof;    warn "$ARGV: $.\n";    $sum += $.;    close ARGV;  }  warn "total: $sum\n";}1;

z-charcoal-video-converter (zentara)

Time for Friday afternoon fun!!

Ever want to make one of those animated videos, like are currently popular on american tv, that are obviously recorded, yet appear to be drawn? Here is a 1 shot script to do it. A morepowerful program to do this is Lives

A sample video is at a sample from youtube and it's charcoal version .

#!/usr/bin/perluse warnings;use strict;use File::Path qw(rmtree);use Image::Magick;# Usage: $0 colors.flv  OR  $0 r# The r option will skip ripping and recombine# the contents of the riptemp-$base subdir.# This allows you to manually edit individual files.# If more than 2 riptemp dirs are present, the first# in a dirlist will be used. So.... work on 1 at a time# in their own directories. This is just a snippet. :-)# I admit, that the Lives (Linux Video Editing System)# at http://lives.sourceforge.net/# is much more powerful than this. Check it out, and # it's "smogrify" perl script.... which is it's workhorse. $|++;my $video = shift || 'colors.flv';my $base;if($video eq 'r'){ recombine();   }else{       $video =~ /^(.+)(\.\w+)$/;       $base = $1;}#rip to jpg's and audio#will make it's own temp dirmy @moptions =( 'mplayer',                '-osdlevel', 0,                '-vo', "jpeg:quality=100:outdir=riptemp-$base:maxfiles=2000",                '-noframedrop',  #important for quality'-ao', "pcm:file=$base.wav",$video,);system(@moptions);opendir my $dh, "riptemp-$base" or die "Error: $!\n";my @files = grep !/^\.\.?$/, readdir $dh;closedir $dh;my $p = new Image::Magick; #only make one and reusemy $max = scalar @files;my $count = 0;foreach my $file ( @files ) {  # operate on jpgs for effects  $count++;  print "\rprocessing file $count/$max";  $p->Read("riptemp-$base/$file");  $p->Negate();  $p->Charcoal('0x1');  $p->Write("riptemp-$base/$file");  undef @$p;  #clear out object data}print "\n\nDone effects processing\n\n";###################### recombinerecombine();#ask to keep clips or notprint "\n\nDone! Delete temp clips? (n/y) Defaults to n\n";my $return = <>;if($return =~ /^[yY].*$/){  rmtree("riptemp-$base", 0, 1); # verbose report, and ignore undeleteables }else{exit}#####################################################################sub recombine{opendir my $dh, '.' or die "Error: $!\n";my @files = grep !/^\.\.?$/, readdir $dh;@files = grep /^riptemp-(.*)$/, @files;closedir $dh;my $dir = $files[0];$dir =~ /^riptemp-(.*)$/;my $base = $1;#print "$dir\t$base\n";my @moptions =( 'mencoder',                "mf://$dir/*.jpg",                '-mf', 'fps=29.97', #NTSC tv video rate in                 '-audiofile', "$base.wav", '-srate', 22050,'-o', "$base-char.avi",                '-ovc', 'lavc','-lavcopts', 'vcodec=mpeg4:vbitrate=100','-oac', 'mp3lame',#'-audio-delay', 0.2, #adjust for audio syncing problems);system(@moptions);}######################################################################3

Find names of an object or class's methods (GrandFather)

Given an object or class name and an optional member name prefix MembersMatching returns a list of matching member names for the class.

The sample prints:

getoptions, configure, new

Note: this ignores inheritance.

Updated to return only methods

Updated following advice from [ysth]

use strict;use warnings;use Getopt::Long;my $p = new Getopt::Long::Parser;print join ', ', MembersMatching($p, '[a-z_]');sub MembersMatching {    my ($object, $prefix) = @_;        $object = ref $object if ref $object;    $prefix ||= '';        no strict;    no strict;    return grep {/^$prefix/ && exists &{"${object}::$_"}} keys %{"${object}::"};}

Reaped: test (NodeReaper)

This node was taken out by the NodeReaper on 2006-09-09 10-16-26
Reason: [Albannach]: delete - no content

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

Retrieve list of used modules and their version numbers (GrandFather)

The first part of the snippet goes at the top of your script.

The second part goes where you want to list the modules and versions. Sample output looks like:

Tk 804.027Tk::Event 4.015Tk::Event::IO 4.008AutoLoader 5.60DynaLoader 1.05Tk::Submethods 4.004Encode::Unicode 1.40

use strict;use warnings;BEGIN {our @usedModules; unshift @INC, sub {push @usedModules, [@_]; return undef;}}our @usedModules;...my $versions = '';for (@usedModules) {   my $name = $_->[1];   $name =~ s/\..*//;   $name =~ s|[\\/]|::|g;      my $version = eval{eval "\$$name\::VERSION"};   $versions .= "$name \t$version\n" if defined $version;}print $versions;

Tk Patio/Office layout designer (zentara)

This is an attempt to improve on [id://570950]. After some experimentation with rotations, and collision detection, I finally came to the conclusion that collision detection wasn't robust enough. Why? First, the overlap detection only works on rectangular regions. This prevents circular pavers, and triangular cut pavers from working with collision detection. Second, the amount of computation needed to detect overlaps on each incremental move, sometimes caused "lack of smooth dragging and rotating". So bye-bye collision detection.

I did add arbitrary rotation in 15 degree increments, and added circles.

This probably could be useful in planning a patio, office layout, or even a garden.

One note of interest, is that to get arbitrary rotations, rectangles and triangles, must be plotted as polygons, where each vertex is defined. See Ala Qumsieh's [cpan://Tk-RotCanvas]

#!/usr/bin/perluse warnings;use strict;use Tk;# USAGE: $0 x-dimension y-dimension# in meters e.g. $0 8.65 4.1# Your going to lay a patio using brand of precast concrete # "stone effect" pavers that come in a range of sizes:# in centimeters to make screen sizing easier, 1 cm per pixel# we need the rectangles to be created as polygons because #  rotations of arbitrary degrees need every vertex identified# r for rectangular, c for circlesmy %ss = (  'a' => [30,30,'hotpink','r'],   'b' => [45,30,'red','r'],   'c' => [45,45,'lightblue','r'],   'd' => [60,45,'pink','r'],   'e' => [60,60,'grey70','r'],   'f' => [60,30,'lightgreen','r'],   'g' => [75,60,'wheat1','r'],   'h' => [75,75,'khaki','r'],   'i' => [90,60,'plum1','r'],   'j' => [30,30,'lightsteelblue','c'],  'k' => [45,45,'lightsteelblue','c'],  'l' => [60,60,'lightsteelblue','c'],  'm' => [90,90,'lightsteelblue','c'],);# print $ss{'a'}->[0] , $ss{'a'}->[1], $ss{'a'}->[2],"\n";# print @{ $ss{'a'} },"\n";#The size of the patio as input can be 'rounded up' in either #or both dimensions to the next of the greatest #common divisor (GCD) of the list of sizes. #(This puts all cuts to be made in the actual #patio at one of the four edges). #For example. The GCD of the 9 sizes above is 150mm. #This forms a minimum grid for the layout. If the patio size #entered was 8.65 x 4.1, then this would be round up to# my $patio_xin = 8.65;# my $patio_yin = 4.1;# my $patio_x =  0.15 * ( 1 + int( $patio_xin / 0.15 ) ); # my $patio_y =  0.15 * ( 1 + int( $patio_yin / 0.15 ) );# print "$patio_x  $patio_y\n"; # 8.7 x 4.2my $patio_xin = shift || 8.65;my $patio_yin = shift || 4.1;my $patio_x =  0.15 * ( 1 + int( $patio_xin / 0.15 ) ); my $patio_y =  0.15 * ( 1 + int( $patio_yin / 0.15 ) );my $dx;   #globals used for draggingmy $dy;my $ptag;my $patio;my $mw = MainWindow->new;$mw->fontCreate('big',   -family=>'arial',   -weight=>'bold',   -size=>int(-18*18/14));my $topframe = $mw->Frame(-bg=>'black')->pack(-fill=>'x');$topframe->Label(-text=>"X-Y = $patio_x - $patio_y (rounded)",                 -bg => 'black', -fg => 'lightblue', -font => 'big', )->pack(-side=>'left');$topframe->Label(-text=>'  ',                 -bg => 'black', )->pack(-side=>'left');$topframe->Label(-text=>'Drag pavers with left button, rotate them with a right (or shift-right)click',                 -bg => 'black', -fg => 'lightgreen', )->pack(-side=>'left'); my $S_canvas = $mw->Scrolled('Canvas',                -width => 600, -height => 600,                -bg => 'grey40',-borderwidth => 0, -relief => 'sunken',-scrollbars => 'osoe',-scrollregion => [ 0, 0, 1000, 1000 ],   )->pack(-expand => 1, -fill =>'both');my $canvas = $S_canvas->Subwidget('scrolled');my $closebutton = $mw->Button(-text => 'Exit', -command => sub{Tk::exit(0)})               ->pack; my $x0 = 20; #slight offsetmy @count = reverse(1..99);foreach my $num (@count){foreach my $paver ('a'..'m'){    my($x,$y,$color,$type) = @{ $ss{ $paver } };#    print "$x,$y,$color,$type\n";#   $canvas->createRectangle($x0, 0, $x0 + $x, $y,    if($type eq 'r'){       $canvas->createPolygon( $x0, 0,                              $x0 + $x, 0,     $x0 + $x, $y,      $x0, $y,     $x0, 0,      -fill => $color,     -tags => ['move', "$paver$num".'p', 'paver'],      -width => 0, );    }   if($type eq 'c'){       $canvas->createOval( $x0, 0,                              $x0 + $x, $y,     -fill => $color,    -tags => ['move', "$paver$num".'p', 'paver'],     -width => 0, );    }    $canvas->createText($x0 + ($x/2)  , $y/2,           -anchor=>'center',   -fill => 'black',           -text => "   $paver$num\n".($ss{$paver}->[0]).'x'.($ss{$paver}->[1]),   -tags => ['move', "$paver$num".'t', 'paver'],  );    $x0 += $x; }$x0 = 20;}# rectangle to simulate patio for dragging pavers to$canvas->createRectangle(15, 120, 15+$patio_x*100, 120 + $patio_y*100,                              -fill => 'black',     -outline => 'white',     -width => 2,     -tags => ['patio'],     );$canvas->lower('patio', 'paver');$canvas->configure(-width => $patio_x * 100 + 20,                    -height=> $patio_y * 100 + 130);$canvas->configure(-scrollregion => [0,0,$patio_x * 100 + 120,$patio_y * 100 + 250]);$canvas->bind('move', '<1>', sub {&mobileStart();});$canvas->bind('move', '', sub {&mobileMove();});$canvas->bind('move', '', sub {&mobileStop();});$canvas->bind('paver','<3>', sub {                       my(@tags) = $canvas->gettags("current");                       @tags = grep{/^\w{1}\d+[pt]$/} @tags;                              chop $tags[0]; #pull off t or p                       my $ptag = $tags[0];       &rotate_poly($ptag,-15,undef,undef);  });$canvas->bind('paver','', sub {                       my(@tags) = $canvas->gettags("current");                       @tags = grep{/^\w{1}\d+[pt]$/} @tags;                              chop $tags[0]; #pull off t or p                       my $ptag = $tags[0];       &rotate_poly($ptag,15,undef,undef);  });#postscript save$topframe->Button(    -text    => "Save as postscript",    -command => [sub {         $canvas->update;         my @capture=();         my ($x0,$y0,$x1,$y1)=$canvas->bbox('all');         $y0 = 120; #lop off paver stacks @capture=('-x'=>$x0,'-y'=>$y0,-height=>$y1-$y0,-width=>$x1-$x0);         my $filename = $patio_x.'-'.$patio_y.'--'.time.'.ps'; $canvas->postscript(-colormode=>'color',                              -file=> $filename,      -rotate=>0,      -width=>$patio_x + 100,      -height=>$patio_y + 100,           @capture);                                     }   ]  )->pack;MainLoop;#####################################################sub mobileStart {      my $ev = $canvas->XEvent;      ($dx, $dy) = (0 - $ev->x, 0 - $ev->y);      my(@tags) = $canvas->gettags("current");      @tags = grep{/^\w{1}\d+[pt]$/} @tags;             chop $tags[0]; #pull off t or p      $ptag = $tags[0];     # print "$ptag\n";      $canvas->raise($ptag.'p');      $canvas->raise($ptag.'t'); #keep text showing#     print "START MOVE->  $dx  $dy\n";}############################################################sub mobileMove {            return if ($ptag eq '');      my $ev = $canvas->XEvent;      my $y = $ev->y;      foreach($ptag.'p', $ptag.'t'){         $canvas->move($_, $ev->x + $dx, $ev->y +$dy);        }          ($dx, $dy) = (0 - $ev->x, 0 - $ev->y);}##############################################################sub mobileStop{ $ptag = '' }#############################################################sub rotate_poly {    my ($tag, $angle, $midx, $midy) = @_;    #taken from Ala Qumsieh's ROTCanvas module        $tag = $tag.'p';    return if($canvas->type($tag) eq 'oval');        # Get the old coordinates.    my @coords_in = $canvas->coords($tag);    my @old = @coords_in;             # Get the center of the poly. We use this to translate the    # above coords back to the origin, and then rotate about    # the origin, then translate back. (old)    ($midx, $midy) = _get_CM(@coords_in) unless defined $midx;    my @new;    # Precalculate the sin/cos of the angle, since we'll call    # them a few times.    my $rad = 3.1416*$angle/180;    my $sin = sin $rad;    my $cos = cos $rad;    # Calculate the new coordinates of the line.    while (my ($x, $y) = splice @coords_in, 0, 2) {my $x1 = $x - $midx;my $y1 = $y - $midy;push @new => $midx + ($x1 * $cos - $y1 * $sin);push @new => $midy + ($x1 * $sin + $y1 * $cos);    }    # Redraw the poly.    $canvas->coords($tag, @new); }################################################################## This sub finds the center of mass of a polygon.# I grabbed the algorithm somewhere from the web.# I grabbed it from Ala Qumsieh's RotCanvas :-)sub _get_CM {    my ($x, $y, $area);    my $i = 0;    while ($i < $#_) {my $x0 = $_[$i];my $y0 = $_[$i+1];my ($x1, $y1);if ($i+2 > $#_) {    $x1 = $_[0];    $y1 = $_[1];} else {    $x1 = $_[$i+2];    $y1 = $_[$i+3];}$i += 2;my $a1 = 0.5*($x0 + $x1);my $a2 = ($x0**2 + $x0*$x1 + $x1**2)/6;my $a3 = ($x0*$y1 + $y0*$x1 + 2*($x1*$y1 + $x0*$y0))/6;my $b0 = $y1 - $y0;$area += $a1 * $b0;$x    += $a2 * $b0;$y    += $a3 * $b0;    }    return split ' ', sprintf "%.0f %0.f" => $x/$area, $y/$area;}####################################################################

Reaped: parse log (NodeReaper)

This node was taken out by the NodeReaper on 2006-09-06 06-38-42
Reason: [GrandFather]: reap - empty node

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

HTML to text (fatalserpent)

A one(half) line code for HTML to text conversion.

perl -pe 's/<.*?>//g'

EDIT: Forgot the dot... lolzerz EDITEDIT:OMG, I forgot the ? too... heh heh heh *yawn* I'm too tired to be posting code on PM (also I'm not a very good perl scripter, but this one was just repeated typos)

Reaped: Perl (NodeReaper)

This node was taken out by the NodeReaper on 2006-09-04 15-12-37
Reason: [tye]: (reap) Failed search attempt?

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

Find common elements in a list of arrays (GrandFather)

The snippet finds all the common elements across a list of arrays.

It is similar to List::Compare's get_intersection except that it returns all the common elements, rather than a list of the unique common elements:

findCommon ([1, 2, 2], [2, 2, 3]);

would return (2, 2) for example.

Gotchas

findCommon expects the lists to be sorted
findCommon destroys the lists passed in

Note that Storable's dclone can be used to efficiently copy the lists if required.

sub findCommon {    my @lists = @_;    my @common;        while (@lists == grep {@$_} @lists) {        my %hits;                $hits{$_->[0]}++ for @lists;                my $least = (sort keys %hits)[0];                push @common, $least if $hits{$least} == @lists;        $_->[0] eq $least && shift @$_ for @lists;    }        return @common;}

Tk-front-end-to YouTube.com videos (zentara)

In an attempt to merge [id://570467] and my Tk front end to Mplayer at [id://417164], here is a YouTube.com sampler. It is not perfect. The categories are hard coded in, and it only gets the first page of each category( maybe 10 videos each)

Also I hacked a quick Listbox widget to display the retreived files. But since I used a thread to download, I needed to update the listbox every 10 seconds manually, which can be annoying if you try to select a file right at update time.

Anyways, it will work on linux (X11) only, and you need an mplayer that can play .flv files.

I creatively named the downloaded files, by concating the titles and flv filename, so you can tell what they are more easily.

Start the app, if any flv files are present in the working dir, they will be listed. Otherwise, press the Select Catagories button, and select 1 or more categories to sample. Then the downloader will get the videos in the background.

#!/usr/bin/perl -wuse strict;use Tk;require Tk::Pane;use Proc::Killfam;                                                                        use Tk::ROText;use LWP::UserAgent;use LWP::Simple;use HTML::LinkExtor;use URI::URL;use threads;use threads::shared;#  it will work on linux (X11) only, and you need an mplayer # that can play .flv files.#I creatively named the downloaded files, by concating the # titles and flv filename, so you can tell what they are more # easily.# Start the app, if any flv files are present in the working dir, # they will be listed. Otherwise, press the Select Catagories # button, and select 1 or more categories to sample. Then the # downloader will get the videos in the background. # must setup thread code before any Tk code is used# to avoid Tk thread-safety problemsmy $thread_die : shared;my $thread_go : shared;my @selected : shared;my @ready : shared;$thread_die = 0;$thread_go = 0;@selected = ();@ready = ();my $thread = threads->new( \&work );###################################################                                                                                          $|++;my @links;  #a global for Link extractor, funky callback hack my $ua = LWP::UserAgent->new();my @selected_cats =();my @ready_lb; #local non-thread copy of @ready to prevent              #Tk from segfaulting$SIG{INT} = sub { &close_it_up };$SIG{PIPE} = 'IGNORE';my $mpg_in = shift || ''; #mpg to play from command line# needs an init.mpg which will be created if you# don't supply oneif( ! -e 'init.mpg'){ &make_init}#setup local files to play  @ready = <*.flv>;#newly downloaded files will be pushed onto @ready#if there are no .flv files in the dir, the first completed#download will play upon arrival@ready_lb = @ready;my $cur_play;my $title;my $playing = 0; #flag used in auto-playing first completed downloadmy $timer;my $timer1;my $mw = MainWindow->new(-background =>'black');$mw->geometry('530x650+20+30');$mw->Tk::bind("", sub{&close_it_up});$mw->Tk::bind("", sub{&close_it_up});my $cframe1 = $mw->Frame(-background =>'black')            ->pack( -fill =>'x');my $cframe2 = $mw->Frame(-background =>'black')            ->pack( -fill =>'x');my $canv = $mw->Scrolled('Canvas',     -bg => 'black',     -borderwidth => 0,     -highlightthickness => 0,     -relief => 'sunken',     -width =>  500,     -height => 400,     -scrollregion=>[0,0,500,400],                                                                  -scrollbars=>'osoe',        )->pack();my $contWidth = 500;my $contHeight = 400;## this Frame is needed for including the window in Tk::Canvasmy $Container = $canv->Frame(-container => 1);my $xtid = $Container->id();# converting the id from HEX to decimal as xterm requires a decimal Idmy ($xtId) = sprintf hex $xtid;my $dcontitem = $canv->createWindow(10,10,   -anchor=>'nw',   -window => $Container,   -width => $contWidth,   -height => $contHeight,   -state => 'hidden',   -tags => ['viewport'],   );my $pid;my @options = (  '-slave','-loop 0', '-zoom',                 "-x $contWidth", "-y $contHeight", '-really-quiet',  "-wid $xtId",       );my $loadu_but = $cframe1->Button(-text => 'Select Category',              -padx => 0,              -command => sub{         my $url = &get_url;         })->pack(-side =>'left',-padx=>10 );$cframe1->Button(-text => "Exit",              -padx => 0,             -command => [sub{&close_it_up}] )     ->pack(-side=>'right', -padx =>10 );$cframe1->Button(-text => "Stop Download",              -padx => 0,             -command => sub{ $thread_go = 0;                     $timer1->cancel; #stop updating list                        } )     ->pack(-side=>'right', -padx =>10 );my $sound = 1;                                                                  $cframe1->Checkbutton(                                                                                 -text => 'Sound',                                                       -background => 'lightblue',-variable => \$sound,                                                               -command  => \&set_sound,                                                                  )->pack(-fill =>'y' );                                                                                  $cframe2->Label(-text => 'SpaceBar->Pause    q or esc -> exit     left and right arrow keys navigate',                -background => 'black',-foreground => 'lightgreen',                 )->pack(-expand=>1 );$cframe2->Label( -textvariable => \$title ,                -background => 'black',-foreground => 'lightblue',                 )->pack(-expand=>1 );&start_player;if($mpg_in ne ''){ &play($mpg_in)}$mw->Label( -text => 'Left Click Select...Right Click Play',                -background => 'black',-foreground => 'green',                 )->pack(-fill => 'x',-expand => 1 );my $lb = $mw->Scrolled('Listbox',              -scrollbars=>'osow',             -listvariable => \@ready_lb,             -background => 'white',     )->pack(-fill => 'x',-expand=>1);$lb->bind( '',  sub{        my $file = $lb->get($lb->curselection);        $playing = 1; #set flag that we are playing a local file&play($file);    });MainLoop();#########################################################sub get_url{my %cats = (1 => 'Arts &Animation',2 => 'Autos & Vehicles',23 => 'Comedy',24 => 'Entertainment',10 => 'Music',25 => 'News & Blogs',22 => 'People',15 => 'Pets & Animals',26 => 'Science & Technology',17 => 'Sports',19 => 'Travel & Places',20 => 'Video Games');my $url_top = "http://youtube.com/categories_portal";    # for instance@links = &get_links( $url_top );# http://youtube.com/categories_portal?c=1&e=1my $lead = 'http://youtube.com/categories_portal?c=';my $rx = qr/\Q$lead\E(.*)/;@links = grep{/$rx/} @links;#remove dups@links = keys %{{map{$_,1} @links}};my %result_list =();#sort the links according to categorymy $rx1 = qr/\Q$lead\E(\d+).*/;   foreach my $link (@links){   $link =~ /$rx1/;   my $cat = $1;             push @{ $result_list{ $cat } }, $link;}my @hyperlinks =();foreach my $key (keys %result_list){#       print $cats{$key},"\n";#       print join( "\n", @{ $result_list{ $key } } ), "\n\n\n";      push @hyperlinks, "$cats{$key}\n";           foreach( @{ $result_list{ $key } } ){         push @hyperlinks, "$_\n";             }     }#popupmy $tl = MainWindow->new();$tl->title("Select YouTube Categories");$tl->fontCreate('big',   -family=>'arial',  -weight=>'bold',  -size=>int(-18*18/14));my $t = $tl->Scrolled('ROText',             -width => 80,     -height => 30,     -background => 'white',     )->pack();my $ebutton = $tl->Button(-text =>'Done Selecting',            -command => sub{                $tl->destroy;                #print "@selected_cats\n";                #now start to process links and download#videos in the work thread            &start_downloads;        })->pack();#add colors$t->tagConfigure( 'tag1', -foreground => 'red', -font => 'big' );my $tag = "tag000";foreach (@hyperlinks) {    chomp;    my @res = split (/(http:\S+)/);    foreach (@res) {        if (/(http:\S+)/) {            $t->insert( 'end', $_, $tag );            $t->tagConfigure( $tag, -foreground => 'blue' );            $t->tagBind( $tag,                '' => [ \&manipulate_link, $tag, 'raised', 'hand2' ]            );            $t->tagBind( $tag,                '' => [ \&manipulate_link, $tag, 'flat', 'xterm' ] );            $t->tagBind( $tag,                '' => [ \&manipulate_link, $tag, 'sunken' ] );            $t->tagBind( $tag,                '' =>                  [ \&manipulate_link, $tag, 'raised', undef, \&printme ] );            $tag++;        }        else {            $t->insert( 'end', $_ , 'tag1' );        }    }    $t->insert( 'end', "\n" ); }}##############################################sub get_links{  my $url_in = shift;   # Set up a callback that collect image links  @links = ();  # a global# Make the parser.  Unfortunately, we don't know the base yet# (it might be diffent from $url)my $p = HTML::LinkExtor->new(\&callback,\@links);# Request document and parse it as it arrivesmy $res =  $ua->request( HTTP::Request->new( GET => $url_in ),                             sub { $p->parse( $_[0] );     } );# Expand all  URLs to absolute onesmy $base = $res->base;@links = map { $_ = url( $_, $base )->abs; } @links;return @links;}#################################################sub callback {       my ( $tag, %attr) = @_;    return if $tag ne 'a';     # we only look closer at     push( @links, values %attr );}####################################################sub printme {#    print "@_\n";    $_[0]->tagConfigure( $_[2], -foreground => 'yellow', -background => 'black' );    push @selected_cats, $_[1];    #now we have an array of urls to fetch and process for all    #video links    #this is done in the 'Done Selecting' callback}#######################################################sub manipulate_link {    # manipulate the link as you press the mouse key    my ($a)      = shift;    my ($tag)    = shift;    my ($relief) = shift;    my ($cursor) = shift;    my ($after)  = shift;    # by configuring the relief (to simulate a button press)    $a->tagConfigure( $tag, -relief => $relief, -borderwidth => 1 );    # by changing the cursor between hand and xterm    $a->configure( -cursor => $cursor ) if ($cursor);    # and by scheduling the specified action to run "soon"    if ($after) {        my ($s) = $a->get( $a->tagRanges($tag) );        $mw->after( 100, [ $after, $a, $s, $tag, @_ ] ) if ($after);    }}########################################################sub get_file{  my @types =( ["mpeg,mp3,avi", [qw/.mpg .mpeg .mp3 .avi .flv/]],);  my $file = $mw->getOpenFile( -filetypes => \@types );  return $file;}###########################################################sub set_sound{   &stop;  if($sound == 1 ){ @options = grep{ $_ ne '-nosound'} @options;}  else{ unshift @options, '-nosound';}  &start_player;   &play($cur_play);}##############################################################sub start_player{  $pid = open(MP, "| mplayer @options  init.mpg >/dev/null 2>&1 ");   $canv->itemconfigure($dcontitem,-state => 'normal');}##############################################################sub play {      my $mpg = shift || 'init.mpg';             syswrite(MP, "loadfile $mpg\n");      $cur_play = $mpg;      my $filename = substr ($mpg, rindex ($mpg, "/") + 1);      $mw->configure(-title=>$filename);      $title = $filename; }###################################################################sub stop{       syswrite(MP, "quit\n");       $canv->itemconfigure($dcontitem,-state => 'hidden');       killfam 9, $pid;       close MP;}#################################################################sub close_it_up{&stop;$thread_die = 1;$thread->join;exit;}##############################################################################sub start_downloads{      foreach my $page( @selected_cats ){         my @links1 = &get_links( $page );         # "http://youtube.com/watch?v=EkTpUxh8Vxc";         my $lead = 'http://youtube.com/watch?v=';         my $rx = qr/\Q$lead\E(.*)/;     @links1 = grep{/$rx/} @links1; #remove dups         @links1 = keys %{{map{$_,1} @links1}};         #print "@links1\n"; foreach(@links1){ push @selected , $_  }      }          #print join "\n", @selected,"\n";          #start downloading thread if needed  if( scalar @selected > 0 ){     $thread_go = 1;         # timer to autoplay first download    $timer = $mw->repeat(500, sub{           if( scalar @ready > 0 ){                if( ! $playing ){ &play( $ready[0] ) };             $timer->cancel;     }            });      #update download list (hack for tk thread safety)    #use 10 seconds to allow time to make selections    #definitely a hack :-)    $timer1 =       $mw->repeat(10000, sub{              @ready_lb = @ready;      $lb->update;      });   }}#############################################################sub work{  no warnings "all"; #stops a harmless shared var warning    my $received_size;  my $request_time;  my $last_update;  my $ua = LWP::UserAgent->new();$|++; while(1){   if($thread_die == 1){ goto END };           if ( $thread_go  == 1 ){      print "starting next page retrieval\n";      my $urlin  = shift @selected;      my $content = get( $urlin  ) or die "$!\n";       print "done page retrieval\n";            #get human friendly title for video      $content =~ /(.*)<\/title>/;      my $title = $1;        #put underscores for spaces in title      $title =~ tr/ /_/;       # regex for 2 key text strings which identify the video file     # the second one $2 is unique for each download attempt     $content =~ /player2\.swf\?video_id=([^&]+)&.*t=([^&]+)&/ ;      print $1, "\n" , $2, "\n";            #make add title to filename for ease of identification     my $infile = $title.'--'.$1.'.flv';  #add a .flv extension     #http://www.youtube.com/get_video?video_id=p_YMigZmUuk&t=OEgsToPDskLRl9-iKyfQVcNT8xes2OIT     my $get_url = 'http://www.youtube.com/get_video?video_id='.$1.'&t='.$2;     print "gettin video file $get_url\n";     # don't buffer the prints to make the status update     $| = 1;     open(IN,"> $infile") or die "$_\n";      $received_size = 0;     my $url = $get_url;     print "Fetching $url\n";     $request_time = time;     $last_update = 0;     my $response = $ua->get($url,                        ':content_cb'     => \&callback_t,                        ':read_size_hint' => 8192,                       );     print "\n";     close IN;     print "$infile done\n";       push @ready, $infile;       }else         { select(undef,undef,undef,.1); } #sleep .1 second  } #end while loop sub callback_t {   my ($data, $response, $protocol) = @_;   my $total_size = $response->header('Content-Length') || 0;   $received_size += length $data;   # write the $data to a filehandle or whatever should happen   # with it here.   print IN $data;   my $time_now = time;   if($thread_go == 0){last}   if($thread_die == 1){ goto END };    # this to make the status only update once per second.   return unless $time_now > $last_update or $received_size == $total_size;   $last_update = $time_now;   print "\rReceived $received_size bytes";   printf " (%i%%)", (100/$total_size)*$received_size if $total_size;   printf " %6.1f/bps", $received_size/(($time_now-$request_time)||1)      if $received_size; }END:}###################################################################sub make_init{use MIME::Base64;                                                                         my $init_mpg =' UklGRvYUAABBVkkgTElTVOgRAABoZHJsYXZpaDgAAABAQg8AfJIAAAAAAAAQCQAAAwAAAAAAAAABAAAAAAAQAMAAAACQAAAAAAAAAAAAAAAAAAAAAAAAAExJU1SQEAAAc3RybHN0cmg4AAAAdmlkc0RJVlgAAAAAAAAAAAAAAAABAAAAAQAAAAAAAAADAAAAAAAQAP////8ARAEAAAAAAMAAkABzdHJmKAAAACgAAADAAAAAkAAAAAEAGABESVZYAEQBAAAAAAAAAAAAAAAAAAAAAABKVU5LFBAAAAQAAAAAAAAAMDBkYwAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAEpVTksEAQAAb2RtbGRtbGj4AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAABMSVNUwgIAAG1vdmkwMGRjbAEAAAAAAbABAAABtYkTAAABAAAAASAAxI2IAA0GBBIUYwAAAbJGRm1wZWcwLjQuOGI0NjgwAH8AAAGzABAHAAABthYPGC/bfxtt/G238bbfxtt/G238bbfxtt/G238bbfxtt/G238bbfxtt/G238bbfxtt/G238bbfxtt/G238bbfxtt/G238bbfxtt/G238bbfxtt/G238bbfxtt/G238bbfxtt/G238bbfxtt/G238bbfxtt/G238bbfxtt/G238bbfxtt/G238bbfxtt/G238bbfxtt/G238bbfxtt/G238bbfxtt/G238bbfxtt/G238bbfxtt/G238bbfxtt/G238bbfxtt/G238bbfxtt/G238bbfxtt/G238bbfxtt/G238bbfxtt/G238bbfxtt/G238bbfxtt/G238bbfxtt/G238bbfxtt/G238bbfxtt/G238bbfxtt/G238bbfxtt/G238bbfxtt/G2378wMGRjIwEAAAAAAbZrgRC+5wX3OC+5wX3OC+5wX3OC+5wX3OC+5wX3OC+5wX3OC+5wX3OC+5wX3OC+5wX3OC+5wX3OC+5wX3OC+5wX3OC+5wX3OC+5wX3OC+5wX3OC+5wX3OC+5wX3OC+5wX3OC+5wX3OC+5wX3OC+5wX3OC+5wX3OC+5wX3OC+5wX3OC+5wX3OC+5wX3OC+5wX3OC+5wX3OC+5wX3OC+5wX3OC+5wX3OC+5wX3OC+5wX3OC+5wX3OC+5wX3OC+5wX3OC+5wX3OC+5wX3OC+5wX3OC+5wX3OC+5wX3OC+5wX3OC+5wX3OC+5wX3OC+5wX3OC+5wX3OC+5wX3OC+5wX3OC+5wX3OC+5wX3OC+5wX3OC+5wX3OC+5wX3OC+5wX3OfwAwMGRjFQAAAAAAAbZrAR//////////////////fwBpZHgxMAAAADAwZGMQAAAABAAAAGwBAAAwMGRjAAAAAHgBAAAjAQAAMDBkYwAAAACkAgAAFQAAAA==';open(FH,"> init.mpg") or die "$!\n";print FH decode_base64($init_mpg);close FH;}</pre>
</article>
<article>
<h1>Guess Number (alandev)</h1>
i  wrote code that would have a number and the user got to guess it correctly. every time user guess is wrong the number gets updated/changed. <pre class="block_code">#!/usr/bin/perluse term;$SIG{INT}='IGNORE';$seed=substr(rand(1)*10,0,1);$seed+=1;print "Guess the Code:";$st=time();$ip=<>;chop($ip);while($seed != $ip){$seed=substr(rand(1)*10,0,1);$seed++;$ip=<>;}if($seed == $ip){        $et=time();        $tt=$et-$st;print "\n  Time Taken 2 break the Code ..:",$tt," Seconds\n";}</pre>
</article>
<article>
<h1>Another date parsing technique (Boyd)</h1>
Probably not new, but it is to me - a quick way to create a date string w/o using modules, etc.<pre class="block_code">my $date_str =   sprintf q{%02d%s%d},   (split /\s+/,localtime)[2,1,4];</pre>
</article>
<article>
<h1>YouTube Video Downloader (zentara)</h1>
Shamelessly converted to perl from the python script <a href=http://www.arrakis.es/~rggi3/youtube-dl/> youtube.dl </a><p>It downloads the front page, extracts the necessary strings, then gets the flash video file ( .flv ) which is then opened in mplayer. The large video download has a progress callback.<pre class="block_code">#!/usr/bin/perluse warnings;use LWP::Simple;use LWP::UserAgent;# shamelessly reversed engineered from a python script :-) print "startring first page retrieval\n";my $urlin  = shift || "http://youtube.com/watch?v=EkTpUxh8Vxc";my $content = get( $urlin  ) or die "$!\n"; print "done first page retrieval\n";#print $content;# regex for 2 key text strings which identify the video file# the second one $2 is unique for each download attempt$content =~ /player2\.swf\?video_id=([^&]+)&.*t=([^&]+)&/ ;print $1, "\n" , $2, "\n";  my $infile = $1.'.flv';  #add a .flv extension#http://www.youtube.com/get_video?video_id=p_YMigZmUuk&t=OEgsToPDskLRl9-iKyfQVcNT8xes2OITmy $get_url = 'http://www.youtube.com/get_video?video_id='.$1.'&t='.$2;print "gettin video file $get_url\n";# don't buffer the prints to make the status update$| = 1;open(IN,"> $infile") or die "$_\n"; my $ua = LWP::UserAgent->new();my $received_size = 0;my $url = $get_url;print "Fetching $url\n";my $request_time = time;my $last_update = 0;my $response = $ua->get($url,                        ':content_cb'     => \&callback,                        ':read_size_hint' => 8192,                       );print "\n";close IN;#play the flv file with mplayersystem( "mplayer $infile" );#############################################sub callback {  my ($data, $response, $protocol) = @_;  my $total_size = $response->header('Content-Length') || 0;  $received_size += length $data;  # write the $data to a filehandle or whatever should happen  # with it here.  print IN $data;  my $time_now = time;  # this to make the status only update once per second.  return unless $time_now > $last_update or $received_size == $total_size;  $last_update = $time_now;  print "\rReceived $received_size bytes";  printf " (%i%%)", (100/$total_size)*$received_size if $total_size;  printf " %6.1f/bps", $received_size/(($time_now-$request_time)||1)     if $received_size;}__END__</pre>
</article>
<article>
<h1>Recursively display nested lists with Template Toolkit (friedo)</h1>
Template Toolkit does not allow recursively including template files, but you can use a VIEW to recurse over a data structure. VIEWs are still experimental but it works for me.<pre class="block_code">use Template;use strict;use warnings;my $t = Template->new;my @nodes = ({name => "one"},{name => "two", children => [ {name => "red"},                              {name => "green"} ] },{name => "three", children => [  {name => "blah", children => [    {name => "yakko" },    {name => "wacko" },    {name => "dot" }   ]  }]} );$t->process("rec.tt", { nodes => \@nodes } );</pre><p>And the template:<p><pre class="block_code">[% VIEW nested_list %]  [% BLOCK list %]    <ul>      [% FOREACH i IN item %]        <li>[% i.name %]</li>        [% IF i.children %]          [% view.print(i.children.list) %]        [% END %]      [% END %]    </ul>  [% END %][% END %][% nested_list.print(nodes) %]</pre><p>And that outputs:<p>    <ul>              <li>one</li>                       <li>two</li>                       <ul>              <li>red</li>                       <li>green</li>                   </ul>                        <li>three</li>                       <ul>              <li>blah</li>                       <ul>              <li>yakko</li>                       <li>wacko</li>                       <li>dot</li>                   </ul>                    </ul>                    </ul>
</article>
<article>
<h1>A little demo for Net::SSH2 (zentara)</h1>
From the Net::SSH2 README<p>Net::SSH2 is a perl interface to the libssh2 (http://www.libssh2.org)library.  It supports the SSH2 protocol (there is no support for SSH1)with all of the key exchanges, ciphers, and compression of libssh2.At present, libssh2 requires OpenSSL (http://www.openssl.org) and canoptionally use zlib for compression (http://www.zlib.net).The Net::SSH::Perl modules are showing signs of age; with the requirementto be compatible with SSH versions 1 and 2, support of newer features suchas channels is difficult; it also has many dependencies, some of whichare hard to build (e.g. Math::Pari).<p>So to help you get into it, here is a simple demo of what works, including a key authorization example. Some of the docs are hard to deal with because of way xs works, so here are some working usages that should allow you to handle almost anything, sftp, scp, running scripts, etc.<pre class="block_code">#!/usr/bin/perluse warnings;use strict;use Net::SSH2;use Data::Dumper;# assuming a user named 'z' for demonstration # connecting to localhost, so you need your sshd running# see maillist archives at# http://lists.sourceforge.net/lists/listinfo/ssh-sftp-perl-users# for deeper discussionsmy $ssh2 = Net::SSH2->new();#connect$ssh2->connect('localhost') or die "Unable to connect Host $@ \n";# authorize# this works but I use keys below # $ssh2->auth_password('z','foopass') or die "Unable to login $@ \n";#this dosn't work#$ssh2->auth(username=>'z', interact => 1);# for a tutorial on auth-keys setup, see# http://cfm.gs.washington.edu/security/ssh/client-pkauth/#get the password for the keyuse Term::ReadKey;print "And your key password: ";ReadMode('noecho');chomp(my $pass = ReadLine(0));ReadMode('restore');print "\n";$ssh2->auth_publickey('z',         '/home/z/.ssh/id_rsa.pub', #testing on localhost '/home/z/.ssh/id_rsa',      $pass );my $chan = $ssh2->channel();$chan->exec('ls -la');while (<$chan>){ print } #will get dir named 2my $chan1 = $ssh2->channel();$chan1->exec('ls -la 2');while (<$chan1>){ print } # mkdir with sftpmy $sftp = $ssh2->sftp();my $dir = '/home/z/3';$sftp->mkdir($dir);my %stat = $sftp->stat($dir);print Dumper([\%stat]), "\n";#put a filemy $remote = "$dir/".time;$ssh2->scp_put($0, $remote);#get a small file to a scalaruse IO::Scalar;my $local = IO::Scalar->new; #it needs a blessed reference$ssh2->scp_get($remote, $local);print "$local\n\n";#get a large file like a 100Meg wav file my $remote1 = $dir.'/1.wav';use IO::File;my $local1 = IO::File->new("> 2.wav"); #it needs a blessed reference $ssh2->scp_get($remote1, $local1);# get a dirlistmy $dh = $sftp->opendir($dir);while(my $item = $dh->read) {    print $item->{'name'},"\n";    }#shell usemy $chan2 = $ssh2->channel();$chan2->shell();print $chan2 "uname -a\n";print "LINE : $_" while <$chan2>;print $chan2 "who\n";print "LINE : $_" while <$chan2>;$chan2->close;__END__</pre>
</article>
<article>
<h1>Find the name of a CODEref (Dylan)</h1>
Inspired by http://perlmonks.org/?node_id=448016, I wrote this little function to figure out the name of a CODEref.Uses a nifty B:: hack.<pre class="block_code">use B;sub findit {    my $ref = shift;    die "I only work for CODErefs!" unless ref $ref eq 'CODE';    my $package = B::svref_2object($ref)->START->stashpv;    local(*alias, *stash);    *stash = *{"${package}::"};    while ((my $varname, my $globvalue) = each %stash){        next if $varname eq "alias";        *alias = $globvalue;        if (defined(&alias)){               if ($ref == \&alias){                return $varname;            }        }    }    return undef;}</pre>
</article>
<article>
<h1>Zero sound detection with Tk graphics (zentara)</h1>
Someone asked on the perl.beginners list how to detect silence on the linux sound card, to be used in a studio to detect when the DJ is sleeping. :-)  This reads /dev/dsp and detects when sound is zero.  Just play a song on your alsa sound system (standard on linux), start this script, and watch. :-)  It works for wavs, mp3's, etc, but not midi's.<p>UPDATE Aug16,2006....fixed a division by zero error when app is started with a quiet sound card.<pre class="block_code">#!/usr/bin/perluse warnings;use strict;use Tk;use Audio::DSP;use constant PI => 3.1415926;#alsamixer must be setup right, AC'97 capture adjusts sensitivity,#just turn it up to 100 for this to work as intendedmy ($buf, $chan, $fmt, $rate) = (4096, 1, 16 , 8000);my $dsp = new Audio::DSP(buffer   => $buf,                     channels => $chan,                     format   => $fmt,                     rate     => $rate);$dsp->init() || die $dsp->errstr();my $mw = MainWindow->new;my $x = 300;my $y = 300;$mw->protocol('WM_DELETE_WINDOW' => sub { &clean_exit });$mw->fontCreate('big', -family=>'arial',     -weight=>'bold', -size=> 36 );my $count_tot = 0;my $count_max = 0;my $c = $mw->Canvas(              -width => $x,              -height => $y,              -bd => 2,              -relief => 'sunken',              -background => 'black',              )->pack();$c->createLine( $x/2, $y/2, 10 , $y/2 ,          -tags => ['needle'],          -arrow => 'last',          -width => 15,          -fill => 'hotpink',           );my $gauge = $c->createArc(        10,10, $x-10,$y-10,        -start => 0,        -style => 'arc',        -width => 5,        -extent => 180,        -outline => 'skyblue',        -tags => ['gauge'],);my $hub = $c->createArc(        ($x/2 - 20), ($y/2 - 20) ,( $x/2 + 20) ,( $y/2 + 20),        -start => 90,        -extent => 359,        -fill => 'lightgreen',        -tags => ['hub'],);my $text = $c->createText(      $x/2, $y/2 + 150,       -text  => $count_max,       -font  => 'big',       -fill  => 'yellow',       -anchor => 's',       -tags => ['text'] );$c->raise('needle','text');$c->raise('hub','needle');$mw->bind('<space>',sub{ &toggle_status  });$mw->waitVisibility;my $timer = $mw->repeat(50,sub{                     my $value = &update_meter;                    $value = sprintf('%2.1f',$value);    if($value <= 0){$value = 0 }                    if($value >= 100){$value = 100}                  my $pos = $value/100;                    my $x1 = $x/2 - .95*$x/2 * (cos( $pos * PI ));                  my $y1 = $y/2 - .95*$y/2 * (sin( $pos * PI ));                  $c->coords('needle', ($x/2), ($y/2), $x1, $y1);                   if($value > $count_max){ $count_max = $value }                   if($value == 0){ $count_max = 0 }                    $c->itemconfigure($text, -text => $value);                    $mw->update;                });MainLoop;#########################################################sub update_meter {  my $samples = 15;  my $num_tot = 0;  my $div_tot = 0;  my $value =0;# Record x samples of soundfor (1..$samples) {        #read 16 bits of raw data        my $data = $dsp->dread(16); # || die $dsp->errstr();        my $num =  unpack( 'v', $data  );            #filter out baseline noise    if($num > 65000){next}else{    #print  "$num ";            $num_tot += $num;            $div_tot += 32768;  #gives a good average} } if( $div_tot != 0 ){   $value = ($num_tot/$div_tot) * 100;} return $value;}####################################################################### sub clean_exit{    $timer->cancel;    $dsp->close();    exit;}#################################################################__END__</pre>
</article>
<article>
<h1>Finding all files that are writeable by the current user (imp)</h1>
One liner that identifies all files on the current system that are writeable by the current user.This version will find the files/directories writeable by the current user:<pre class="block_code">perl -MFile::Find -e 'find(sub {my $f = $File::Find::name; print $f, "\n" if -w $f && !-l $f}, "/")'</pre>The following snippet will identify the files that are writeable for the given user - but only if the current user can access all of the directories that the specified user can see. If you can't see it, you can't check it. Note that this version will collect all of the files before printing anything.<pre class="block_code">use File::Find::Rule::Permissions;my $user = @ARGV ? $ARGV[0] : $ENV{USER};print $_,"\n" for File::Find::Rule::Permissions->file() ->permissions( user => $user, isWriteable => 1) ->in("/");</pre>
</article>
<article>
<h1>dump-static-nodes.pl - Pull content from your webserver according to .htaccess (Corion)</h1>
<p>To create static versions of pages that get hit from the outside, I wrote this program, which runs as a cron job. It parses the <tt class="inline_code">.htaccess</tt> file of the webserver and createsstatic HTML versions of the pages listed in the <tt class="inline_code">.htaccess</tt> file. Currently, thereis no parsing so that the redirect from the <tt class="inline_code">.htaccess</tt> gets generated as the output file, but as entries into the <tt class="inline_code">.htaccess</tt> file get made by another script, that's not as problematic.</p><pre class="block_code">#!/usr/bin/perl -wuse strict;use File::Basename;use LWP::Simple;use Getopt::Long;GetOptions(   'wwwroot:s'   => (\my $wwwroot),   'staticdir:s' => (\my $outdir),   'server:s'    => (\my $server),   'node:i'      => (\my @nodes),   'htaccess:s'  => (\my $htaccess),   'savepath:s'  => (\my $savepath),);$wwwroot  ||= './public_html';#$htaccess ||= "$wwwroot/.htaccess";$server   ||= "perlmonks.org";$savepath ||= $wwwroot;my $uri = "http://$server?node_id=%d;style=static";my $save = "$savepath/%d.html";# -d $wwwroot or die "wwwroot: '$wwwroot' is no directory.";-d $savepath or die "savepath: '$savepath' is no directory.";if (! scalar @nodes) {    open my $hta, "<", $htaccess        or die "Couldn't read '$htaccess' : $!";    push @nodes, map { /^\s*RewriteCond %\{QUERY_STRING\} node_id=(\d+)\$/ ? $1 : () } <$hta>;};for my $node (@nodes) {    my $url = sprintf $uri, $node;    my $target = sprintf $save, $node;    print "Saving $node via $url to $target";    printf ", %d\n", mirror($url, $target);};</pre>
</article>
<article>
<h1>Autovivification trick (blazar)</h1>
Minimal example exhibiting a <strong>double reference autovivification trick</strong> (learnt from <em>Brian McCauley</em> in a <a href="/out/href/news:comp.lang.perl.misc">clpmisc</a> <a href="/out/href/news:1155102735.358626.78050@i3g2000cwc.googlegroups.com">thread</a>) to convert a list of structured strings as that below the <tt class="inline_code">__END__</tt> token to a complex data structure as that illustrated by the output of the program. [id://567024|More details] follow.<pre class="block_code">#!/usr/bin/perluse strict;use warnings;use Data::Dumper;my %dirhash;while (<DATA>) {    chomp;    my $last=\\%dirhash;    $last=\$$last->{$_} for split qr|/|;}print Dumper \%dirhash;__END__/file.txt/a/file.txt/a/b/c/a/b/c/file.txt/z/m/w/file.txt</pre>
</article>
<article>
<h1>Remove broken symlinks with IO::All (Dylan)</h1>
<p>This is a short script using IO::All to remove broken symlinks.<p>Note, it has to redefine the readlink() method, because as of version 0.35 of IO::All, readlink doesn't handle relative symlinks.<p>IO::All sure makes my life easier!<pre class="block_code">#!/usr/bin/perluse strict;use warnings;use IO::All::Link; # Because we redefine readlink()...use IO::All;my $file = shift @ARGV || '.';my @ios = ( io($file) );while (my $io = shift @ios) {    if ($io->is_dir) {        push @ios, $io->all;    } elsif ($io->is_link and not $io->readlink->exists) {        print "$io is broken, removing.\n";        $io->unlink;    }}# this has been submitted as a patch to IO::All...no warnings 'redefine';sub IO::All::Link::readlink {    my $io = shift;    my $path = CORE::readlink($io->name);    unless (File::Spec->file_name_is_absolute($path)) {        $path = File::Spec->join($io->filepath, $path);    }    IO::All->new($path);}</pre>
</article>
<article>
<h1>pickFromRange (tye)</h1>
<p>This uses a partial Fisher-Yates shuffle to efficiently pick a random selection of elements from a contiguous range of integers, using a hash to prevent using a lot of memory when the range of integers to choose from is huge.</p><p>If the number of integers you want to select is nearly as large as the range you are selecting from, then using a hash in this way isn't a big win and you are probably better off just putting the range of integers into an array and doing a partial Fisher-Yates shuffle on it.</p><p>If you can rely on your version(s) of Perl having the // operator, then the code can be simplified, replacing all but the first and last two lines of the loop with the two commented-out lines.</p><p>Command-line usage of included sample code:</p><pre class="block_code">    perl pickFromRange.pl [ count [ max | min max ] ]    pickFromRange [ count [ max | min max ] ]</pre><p>Count defaults to 20.  If max is not given, then the range 100..999 is used.  If max is given but not min, then 1..max is used.</p><p>(Minor updates applied.)</p><pre class="block_code">#!/usr/bin/perl -wuse strict;sub pickFromRange{    my( $count, $min, $max )= @_;    my $range= $max - $min + 1;    die "pickFromRange: $max - $min + 1 < $count"   if  $range < $count;    my @pick;    my %replace;    while(  0 < $count--  ) {        my $pick= $min + int( rand($range) );        my $next= $replace{$pick};        push @pick, defined($next) ? $next : $pick;        # push @pick, $replace{$pick} // $pick;        $next = $replace{$max};        $replace{$pick}= defined($next) ? $next : $max;        # $replace{$pick}= $replace{$max} // $max;        delete $replace{$max--};        $range--;    }    return @pick;}my $count=  @ARGV ? shift(@ARGV) : 20;my( $min, $max )= !@ARGV ? (100,999) : 1==@ARGV ? (1,@ARGV) : @ARGV;my @pick= pickFromRange( $count, $min, $max );print "@pick\n";</pre>
</article>
<article>
<h1>Perl template maker (fatalserpent)</h1>
This script takes one argument and outputs a perl executable file ready to have code added to it! w/e lolz. It's easy enought to figure out anyway... <i>PD code</i><pre class="block_code">#!/usr/bin/perl$filename = @ARGV[0];open(FILE, ">$filename");print{FILE}"#!/usr/bin/perl\n# $filename\nuse warnings\;\nuse strict\;\n";close(FILE);system("chmod 755 $filename");</pre>
</article>
<article>
<h1>xd and dx -- hexdump for debugging purposes (Skeeve)</h1>
I often need hexdumps of files or output streams. So I wrote these 2 little helpers years ago. Maybe others find them useful too (and because [neversaint] asked me in th CB to post them...)<pre class="block_code">###### xd -- hexdump#!/usr/bin/perl@fill= qw( .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. );if (scalar(@ARGV)) {foreach $file(@ARGV) {$size= -s $file;$form= length(sprintf("%x",$size))-1;++$form unless $form;print "File: ",$file,"\n";open (IN,$file);&dump(*IN, $form);close (IN)}}else {&dump(*STDIN, 4);}sub dump {local(*IN, $form)= @_;my ($buf, $i);while ($rb= read(IN, $buf, 16)) {@x= unpack("H2" x $rb, $buf);$buf=~ s/[\x00-\x1f\x7f-\xff]/./g;$buf.= ' ' x (16-length($buf));printf ("%0${form}x0: %s [%s]\n",$i++,,sprintf ("%s %s %s %s  %s %s %s %s - %s %s %s %s  %s %s %s %s", @x, @fill),$buf);}}###### dx -- undump the dump#!/usr/bin/perlif (scalar(@ARGV)) {foreach $file(@ARGV) {open (IN,$file);&undump(*IN);close (IN)}}else {&undump(*STDIN);}sub undump {local(*IN)= @_;local($_);while (<IN>) {#next unless s/^([0-9a-f]+)://;s/^([0-9a-f]+)://i;s/[^\-\s0-9a-f].*$//i;@match= /(\b[0-9a-f][0-9a-f]\b)/ig;print pack("H2" x scalar(@match), @match);}}</pre>
</article>
<article>
<h1>King (alandev)</h1>
<pre class="block_code">print '===KING==='</pre><p><small>  Considered by [marto]: Restore content or Reap empty node. <br />  Unconsidered by [planetscape]: keep (and edit) votes [id://409197|prevented] reaping ( keep:1 edit:12 reap:20 )</small></p>
</article>
<article>
<h1>tf - tail a file and output separator line when inactive (imp)</h1>
I got tired of tailing an error log and hitting enter several times to create a gap between requests, so I automated this behaviour.This script will tail a file and print a line '='x80 whenever there is a 2 second silent period - but will not output multiple separator lines for long silent periods.<pre class="block_code">#!/usr/bin/perluse strict;use warnings;# Pipe the output of tail -fopen TAIL, "tail -f @ARGV |" or die "Failed to pipe to 'tail -f @ARGV'. $!";# Create a handle for SIGALRM that outputs a line of '=', 80 width.$SIG{ALRM}=sub{    printf "\n%s\n", '='x80;};# Read from TAIL# Print output# Set the alarm timer to 2 seconds.## By setting the alarm to 2 seconds with each line processed we can detect# the first 2 second silent period, and trigger $SIG{ALRM}.# After the alarm is triggered no further separators will be output until the## This will not trigger multiple separator lines, since alarm will not be reset# to 2 seconds until the next line is read.#print && alarm(2) while<TAIL>__END__=head1 NAMEtf - script for tailing a file and outputting a separator line when inactive=head1 SYNOPSIS tf /var/log/messages=cut</pre>
</article>
<article>
<h1>More clear dumper debugging lines (jimt)</h1>
<p>This is a trivially simple little formatting trick I use when tossing in lines to dump out during debugging or whatnot.</p><p>My thought process tends to go along the lines of, "Hey, I need to check the values of this variable here, so I'll add a print statement...wait, I should print out another one. Wait, I really need to print out this whole complex data structure, I need to dump it."</p><p>Nothing special there, just use Data::Dumper and print it out. But I find that marginally annoying since (1) if I later want to shut off that print line and remove the module, I need to add two comments or (2) if I want to delete the statement, I need to remember to delete two lines, lest I end up with useless imports of Data::Dumper.</p><p>Solution? Simply toss the use onto the end of your debugging line. Since the use is hit at compile time, you're still importing the module in advance, so it works. Your print line is very clear on the left side of your code (no use in front of it), and then you only have one line to go back and clean up when you get rid of it.</p><pre class="block_code">print Dumper($some_complex_structure); use Data::Dumper;</pre>
</article>
<article>
<h1>Text aligner (in table) (Yunus)</h1>
A set of routines to align text within columns. Suitable to build ascii-text based table. (include demo rountine)<br><br>I dunno how to make CPAN modules (with POD). sorry. welcome any input/comment/feedback etc. Hopefully someone might find it useful ;)<br><br><b>update : </b>Data (especially text) will be aligned (smartly) in column. <pre class="block_code">## By Mohd Yunus Sharum (youknows@gmail.com)# Universiti Putra Malaysia, Malaysia.## Copyright (C) 2006 Mohd Yunus Sharum## This program is free software; you can redistribute it and/or modify it under# the terms of the GNU General Public License as published by the Free Software# Foundation; either version 2  of the  License, or  (at your option) any later# version.## This program is distributed in the  hope that it will  be useful, but WITHOUT# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS# FOR A PARTICULAR PURPOSE.See the GNU General Public License for more details.## http://www.gnu.org/licenses/gpl.html#SEC1#use strict;# justification codes - used by alignColumns()#--------------use constant ALIGN_LEFT   => -1;use constant ALIGN_CENTER => 0;use constant ALIGN_RIGHT  => 1;# word separator  - used by alignColumns()#--------------my $separator = '\s,.\-\+';my $not_separator = '^'.$separator;# functions' declaration#--------------sub alignColumns($$$@);         # align data in multi columns (basic function)sub alignRows($$$@);            # same, but extended for multiple rows, no numbering featuressub numberedAlignRows($$$@);    # same, but extended with numbered rows#--------------# FUNCTION: #     SAMPLE PROGRAM - demonstrate the capability of aligner functions## IN: #     none# OUT:#     none#--------------sub main{    print "Not auto numbered\n";    alignRows("",                         # output handle (default STDOUT)          [ALIGN_LEFT, ALIGN_LEFT],       # column alignment          [5, 50],                        # list of columns width          ["Id", "Residue"],              # list of data          ["-----", "----------"],          ["123.12", "AAABACACCA ".                  "AAABACACCACAGGATCCACACTCAAGTTT ".                  "AAABACACCACAGGATCCACACTCAAGTTTGGTAGGATCCACACTTTAAAGGATCCACACTAGGATCCACACTGGATCCACACT"  ],          ["A342", "AGGATCCACAGGA"],          ["B652", "AGGATCCACACTAGGATCCACACTAGGATCCACACT" ]);    print "\n\n";    print "auto Numbered\n";    numberedAlignRows("",                 # output handle (default STDOUT)          [ALIGN_LEFT, ALIGN_LEFT],       # column alignment          [5, 50],                        # list of columns width          ["Id", "Residue"],              # list of data          ["-----", "----------"],          ["123.12", "AAABACACCACAGGATCCACACTCAAGTTTGGTAGGATCCACACTTTAAAGGATCCACACTAGGATCCACACTGGATCCACACT".                  "AAABACACCACAGGATCCACACTCAAGTTTGGTAGGATCCACACTTTAAAGGATCCACACTAGGATCCACACTGGATCCACACT".                  "AAABACACCACAGGATCCACACTCAAGTTTGGTAGGATCCACACTTTAAAGGATCCACACTAGGATCCACACTGGATCCACACT"  ],          ["A342", "AGGATCCACAGGA"],          ["B652", "AGGATCCACACTAGGATCCACACTAGGATCCACACT" ]);}main();#--------------# FUNCTION: #     Align data in column based on column width (only for single row)# IN: #     Filehandle: File handle to send output (default STDOUT)#     Justifies:  List of justifying codes (right,center or left)#     ColsWidth:  List of columns' width#     Data:       List of data to display (for single row)# OUT:#     none#--------------sub alignColumns($$$@){    my ($fileHandle, $justifies, $colsWidth, @data) = @_;    $fileHandle = *STDOUT if !$fileHandle;    my $totCols = scalar @$colsWidth;    my ($inline, $strLen);    my $finished = 0;    while(!$finished) {        $finished = 1;        # check each columns        #--------------        for my $colNum (0..$totCols-1) {            $data[$colNum] =~ s/^\s+//;            $strLen = length($data[$colNum]);            $inline = "";            if($strLen > 0) {                # check if data exceed column's size                #--------------                if ($strLen > $colsWidth->[$colNum]) {                    $inline = substr($data[$colNum], 0, $colsWidth->[$colNum]);                    $data[$colNum] = substr($data[$colNum], $colsWidth->[$colNum]);                    # check if single word is splitted                    #--------------                    if ($data[$colNum] =~ /^[$not_separator]/o                           and $inline =~ /[$not_separator]$/o                           and $inline =~ /[$separator]/o) {                            if ($inline =~ s/(.+[$separator]+)(.+)$/$1/) {                                $data[$colNum] = $2 . $data[$colNum];                            }                    }                    $finished = 0;                } else {                    $inline = substr($data[$colNum], 0);                    $data[$colNum] = "";                }            }            $inline =~ s/\s+$//;            # print data, justified            #--------------            print $fileHandle (" | ") if $colNum > 0;            if($justifies->[$colNum] == ALIGN_RIGHT) {                printf $fileHandle "%*s", $colsWidth->[$colNum], $inline;            } elsif($justifies->[$colNum] == ALIGN_LEFT) {                printf $fileHandle "%-*s", $colsWidth->[$colNum], $inline;            } else {                # centered                #--------------                my $lenSpc = ($colsWidth->[$colNum] - length($inline)) / 2;                my $space = "";                $space = sprintf("%*s", $lenSpc, " ") if $lenSpc > 0;                printf $fileHandle "%-*s", $colsWidth->[$colNum], $space.$inline;            }        }        print $fileHandle "\n";    }}#--------------# FUNCTION: #     Align and display data in rows.#     Use function alignColumns() to align data in single row# IN: #     Filehandle: File handle to send output (default STDOUT)#     Justifies:  List of justifying codes (right,center or left)#     ColsWidth:  List of columns' width#     Rows:       List of data to display (in mutiple rows / 2 dimensional data)# OUT:#     none#--------------sub alignRows($$$@){    my ($fileHandle, $justifies, $colsWidth, @rows) = @_;    for my $row (@rows) {        alignColumns($fileHandle, $justifies, $colsWidth, @$row);    }}#--------------# FUNCTION: #     Display data in numbered rows#     Notes - assuming first two rows of @rows are columns' headers#     Use function alignRows() to align data# IN: #     Filehandle: File handle to send output (default STDOUT)#     Justifies:  List of justifying codes (right,center or left)#     ColsWidth:  List of columns' width#     Rows:       List of data to display (in mutiple rows / 2 dimensional data)# OUT:#     none#--------------sub numberedAlignRows($$$@){    my ($fileHandle, $justifies, $colsWidth, @rows) = @_;    # add new column    #--------------    unshift(@{$rows[0]}, "No.") ;      # add new column's header     unshift(@{$rows[1]}, "-----") ;    # add new column's separator    my $count = 1;    my $num = 1;    for my $row (@rows) {        unshift(@$row, $num++) if $count > 2;   # add number on each row        $count++;    }    unshift(@$justifies, ALIGN_RIGHT);      # add new column's justification code    unshift(@$colsWidth, 5);                # add new column's width    # call alignment's function    #--------------    alignRows($fileHandle, $justifies, $colsWidth, @rows);  }</pre>
</article>
</main></body></html>