Beefy Boxes and Bandwidth Generously Provided by pair Networks
The stupid question is the question not asked
 
PerlMonks  

Snippets

( [id://11156491] : superdoc . print w/replies, xml ) Need Help??

The Snippets Section is closed, and all of the snippets which were posted there have been converted to Cool Uses for Perl. Never fear! They have each been specially tagged, and are presented here for your reference.

If you wish to post a CUFP specifically as a snippet (which we don't recommend), you may, after posting it in CUFP, add the 'snippet' keyword to it via the Keywords Nodelet.

For a list of all the snippets — titles only — you may visit the Snippets Lister.

Snippets
Using wxMemoryDC to draw on a jpeg
on Sep 26, 2009 at 21:26
0 replies by Steve_BZ
    I found it hard to locate any easy examples of drawing on Bitmaps using wxPerl. Here is some working code that I put together to see if I could make it work. Just make sure you point the .jpg filename to one that exits on your machine, and you have wxPerl installed. Many thanks to Huub Peters for helping me with Mouse events and understanding DC.
    #!/usr/bin/perl -w -- use Wx 0.15 qw[:allclasses]; use strict; use warnings; package MyFrame; use Wx qw[:everything]; use base qw(Wx::Frame); use strict; our $gl_self; sub new { my( $self, $parent, $id, $title, $pos, $size, $style, $name ) = @_ +; $parent = undef unless defined $parent; $id = wxID_ANY unless defined $id; $title = "" unless defined $title; $pos = wxDefaultPosition unless defined $pos; $size = wxDefaultSize unless defined $size; $name = "" unless defined $name; $style = wxDEFAULT_FRAME_STYLE unless defined $style; $self = $self->SUPER::new( $parent, $id, $title, $pos, $size, $sty +le, $name ); $self->SetTitle("Drawing on image"); $gl_self= $self; # Set Global variable for use in EVT handler # Image for drawing on $self->{image1} = Wx::Image->new( 'C:\insert_your_jpeg.jpg', wxBI +TMAP_TYPE_ANY, -1 ); $self->{Loc_Photo_Bmp} = Wx::Bitmap->new( $self->{image1} ) ; $self->{bitmap_1} = Wx::StaticBitmap->new( $self, wxID_ANY, $self- +>{Loc_Photo_Bmp}); # Button to draw image use Wx::Event qw( EVT_LEFT_UP ); $self->{bitmap_1}->SetCursor(wxCROSS_CURSOR); $self->{bitmap_1}->Connect( wxID_ANY,wxID_ANY,wxEVT_LEFT_UP, \&on_ +button ); # # Sizer # $self->{sizer_1} = Wx::BoxSizer->new(wxVERTICAL); $self->{sizer_1}->Add($self->{bitmap_1}, 0, 0, 0); $self->SetSizer($self->{sizer_1}); $self->{sizer_1}->Fit($self); $self->Layout(); return $self; } sub on_button{ my ($self, $event) = @_; # select it into a memory dc if (defined $gl_self->{Loc_Photo_Bmp}){ my $mdc = Wx::MemoryDC->new(); $mdc->SelectObject($gl_self->{Loc_Photo_Bmp}); my $pen = Wx::Pen->new( Wx::Colour->new(255,255,255), 3, wxSOL +ID); $mdc->SetPen( $pen ); $mdc->SetBrush( wxTRANSPARENT_BRUSH ); # Determine mouse event # my $m= Wx::MouseEvent->new($event); my $r = 50; my $x=$event->GetX(); my $y=$event->GetY(); # Draw circle round mouse event $mdc->DrawCircle( $x, $y, $r ); $mdc->SelectObject(wxNullBitmap); # deselect the bitmap out of + the DC $gl_self->{bitmap_1} ->SetBitmap($gl_self->{Loc_Photo_Bmp}); $gl_self->{bitmap_1}->SetCursor(wxSTANDARD_CURSOR); $gl_self->{bitmap_1}->Disconnect( wxID_ANY,wxID_ANY,wxEVT_LEFT +_DOWN ); $gl_self->{bitmap_1}->Disconnect( wxID_ANY,wxID_ANY,wxEVT_LEFT +_UP ); } $event->Skip() ; return $self; } 1; package main; unless(caller){ local *Wx::App::OnInit = sub{1}; my $app = Wx::App->new(); Wx::InitAllImageHandlers(); my $frame_1 = MyFrame->new(); $app->SetTopWindow($frame_1); $frame_1->Show(1); $app->MainLoop(); }
output to STDOUT or a file
on Sep 04, 2009 at 11:03
1 reply by metaperl
    apparently FileHandle is deprecated in favor of IO. Here is some code that allows you to write to either STDOUT or a file.
    use IO qw(File Handle); my $io = do { if (shift) { my $tmp = IO::Handle->new; die "open failed: $!" unless $tmp->fdopen(fileno(STDOUT),"w"); $tmp; } else { my $tmp = IO::File->new('tmp.out', 'w'); $tmp; } }; $io->print("Some text\n");
GTK2 Exif Thumbnail Reader
on Aug 31, 2009 at 08:51
2 replies by renegadex
    This snippet shows how to get the thumbnail from exif metadata. This is very usefull for generating very fast thumbnails!! I hope many would benefit from this.
    use Image::ExifTool qw(ImageInfo); my $exifTool = new Image::ExifTool; $exifTool->Options(Binary => 1); my $info = $exifTool->ImageInfo('image_file.jpg', 'thumbnailimage'); my $data = ${$$info{ThumbnailImage}}; my $loader = Gtk2::Gdk::PixbufLoader->new(); $loader->write($data); $loader->close(); $pixbuf = $loader->get_pixbuf();
    since you are able to make the thumbnail into a pixbuf then you may now use your favourite widget to preview the thumbnail.

    the $exifTool is an Image::ExifTool, so you need this module to make it work. you can yum it using... yum install perl-Image-ExifTool.

    *some of the codes i got from other monks*
XP Perl Replacement for "Send to Clipboard as Filename"
on Aug 20, 2009 at 05:52
2 replies by Melly

    For some reason, XP powertools is missing one of my favourites - the ability to right-click on a file, and send the path and name to the clipboard.

    So, I added the following to a shortcut I called "Send to Clipboard" in my SendTo folder:

    C:\Perl\bin\perl.exe -e "use Win32::Clipboard;Win32::Clipboard($ARGV[0 +]);"
    C:\Perl\bin\perl.exe -e "use Win32::Clipboard;Win32::Clipboard($ARGV[0 +]);"
un-Nifty qr OR ASCII bullet parser
on Aug 13, 2009 at 15:04
1 reply by belg4mit
    While searching for a parse of ASCII bulleted lists the other day, I ended up rolling my own:

    while( $text =~ /\G\s*($bullet)\s*([^\n]+)((?:\s*$bullet{2,}\s*[^\n]+)+)?/g ){ ...}

    And stumbled across what I believed to be a clever use of qr to create $bullet from a separate data structure (which permits us to later determine what style of bullet we had, and map it to something):
    %bullets = ('*'=>'foo', '+'=>'bar', '@'=>'qux'); #Original, which as ikegami points out, doesn't quite work #my $bullet= sprintf(qr/[%s]/, join('', keys %bullets)); #Alternate form, that I was trying to make more scrutable, with added +\Q my $bullet= qr/[\Q@{[join '', keys %bullets]}\E]/;
a2z.pl
on Jul 10, 2009 at 23:25
0 replies by Khen1950fx
    I was having a problem with CPAN's "long-list" of modules, so I've been using this as a replacement. It will search for and return the names of all authors, all distributions, and all modules on CPAN.
    #!/usr/local/bin/perl use strict; use warnings; use CPAN; CPAN::Shell->a; CPAN::Shell->d; CPAN::Shell->m;
move files to directories based on criteria
on Jul 10, 2009 at 14:20
2 replies by metaperl
    We have a log directory full of files that we need to move out into different directories. I looked around for log file rotation utilities and found none. So I set out to write something. I first looked at various File::* modules but found none of them as easy as plain old File::Find. For usage at your site, customize the functions find_root_dir and categorize.
    #!/usr/bin/perl use strict; use warnings; use lib '../..' ; use File::Copy; use File::Find; use File::Path; my $root_dir = find_root_dir; our $prefix; sub wanted { my ($file)=$_; return if -d $file; return if $File::Find::dir ne $root_dir; my $dir_to_make = categorize($file); File::Path::make_path($dir_to_make); File::Copy::move($file, $dir_to_make); } sub find_root_dir { use Local::Config; Local::Config->new->logdir; } sub categorize { my($file)=@_; substr($file, 0, 5); } File::Find::find(\&wanted, $root_dir); # thanks to jhannah in #perl-help # [09:52] <metaperl_work> Is there a utility to move files into a dire +ctory based on a prefix of the name? # [09:54] <mxf> "mv foo* bar/"? # [09:54] <metaperl_work> mxf, yes, but there are tons of files which +must be automatically moved and directories created for them # [09:55] <jhannah> trivial to write one? # [09:55] <metaperl_work> jhannah, I suppose I need one of the File::F +ind modules to do it # [09:55] <metaperl_work> people seem to lieke F::F::Rules? # [09:55] <mxf> metaperl_work, Ah, i see. # [09:55] <jhannah> why? glob the dir in question, split your prefix, +create the dirs, move files # [09:56] <jhannah> how is this more than 6 lines of perl? # [09:56] <metaperl_work> for file in <*> { ... } # [09:56] <metaperl_work> for my $file <*> { ... } # [09:56] <metaperl_work> ? # [09:56] <metaperl_work> next unless -f $file # [09:56] <jhannah> foreach $file (glob "/path/to/dir") { } # [09:56] <jhannah> my $file
One PDF file for a set of images
on Jun 17, 2009 at 01:57
0 replies by graff
    I had to scan a bunch of paper documents (one image per page), and upload them all to a web site that would accept only one PDF file containing the whole set.

    A few CPAN module can do this, but their man pages leave a lot to the imagination. After a dozen trial/error iterations, here's what worked for me, using PDF::Create (it's manual was much better than PDF::API2).

    #!/usr/bin/perl use strict; use warnings; use PDF::Create; my $pdf = new PDF::Create(filename=>"test.pdf",Author=>"Me"); my $psz = $pdf->get_page_size("Letter"); my $rt = $pdf->new_page( MediaBox => $psz ); for my $i (<*.jpg>) { my $im = $pdf->image($i); my $pg = $rt->new_page( MediaBox => $psz ); $pg->image( image => $im, xpos => 0, ypos => 0, xscale => $$psz[2] / $$im{width}, yscale => $$psz[3] / $$im{height} ); } $pdf->close;
oneliner to get module version
on Jun 14, 2009 at 15:35
6 replies by sflitman
    Sometimes it helps to have a quickie way to get the version from a module. This lets me do it from the command line.
    # PUT IN .bashrc FILE perlver() { local m=$1 perl -M$m -e "print $m->VERSION,qq{\n};" } # EXECUTE FROM COMMAND LINE AS perlver <module>
adding singleton methods to objects
on Jun 04, 2009 at 09:28
1 reply by andal
    This piece of code may serve as the base class for objects that need singleton methods (methods specific for this object and not for whole class). One can use it directly
    my $obj = DynObject->new(id => 'MyObj', action => sub{print "hi\n";}); print $obj->id, "\n"; $obj->action();
    or as base class
    $obj = MyDyn->new(id => 'MyObj'); print $obj->id, "\n"; $obj->action(); package MyDyn; use base 'DynObject'; sub action { print "hi\n"; }
    use strict; package DynObject; use Carp; my $counter = 0; sub new { my $class = shift; croak("The number of parameters must be even") unless @_ % 2 == 0; no strict 'refs'; my $type = ref $class; my $code; if(!$type) { $type = __PACKAGE__; $type .= "::obj@{[$counter++]}"; *{"${type}::ISA"} = [$class]; } for(my $i = 0; $i < @_; $i+=2) { croak("The method name '$_[$i]' is not a word") unless $_[$i] =~ /^\w+$/ && $_[$i] !~ /^\d+$/; if(ref $_[$i+1] eq 'CODE') { *{"${type}::$_[$i]"} = $_[$i+1]; } elsif(defined $_[$i+1] && !ref $_[$i+1]) { my $str = $_[$i+1]; *{"${type}::$_[$i]"} = sub{$str}; } else { delete ${"${type}::"}{$_[$i]}; } } return ref $class ? $class : bless [], $type; } sub DESTROY { my $obj = shift; my $type = ref $obj; $type =~ s/(\w+)$//; my $name = $1 . "::"; no strict 'refs'; delete ${$type}{$name}; } 1;