#!/usr/bin/perl
use warnings;
use strict;
use Getopt::Long;
use Pod::Usage;
use Tk;
use Tk qw(:eventtypes);
use Tk::JPEG;
use Tk::Pane;
use GD;
use Image::ExifTool qw(:Public);
use MIME::Base64;
use File::Spec;
use File::Copy;
use Fcntl;
use Time::Hires;
###
$|++;
# from GD docs:
# For backwards compatibility with scripts previous versions of GD, ne
+w
# images created from scratch (width, height) are palette based by def
+ault.
# To change this default to create true color images use:
# (somewhere before creating new images.)
# [it must unneeded for jpg but if you comment the following line you'
+ll
# get color noise]
GD::Image->trueColor(1);
######################################################################
+##########
# default configuration (that can be modified via command line paramet
+ers)
######################################################################
+##########
# source folder or glob expression to find jpg images
my $glob = './*.jpg';
# destination folder used when copying files
my $dest = '.';
# debug
my $debug = 0;
# ratio of the photo and of photo window
my $win_ratio=0.25;
my $ph_ratio= 0.25;
# index of last column and row(starting from 0(but -1 applpied after g
+etopts!))
# used to display thumbs in a grid
my $grid_col = 6;
my $grid_row = 4;
# how many photos to preload after and before current one
my $preload = 1;
# do not load thumbnails at all!
my $nothumbs = 0;
# jpeg quality
my $jpeg_quality;
# output extension (jpg as commodity alias of jpeg)
my $out_ext = 'jpg';
# png compression factor (0-9)
my $png_compression;
# date format used by Image::ExifTool
my $date_format = '%Y_%m_%d_%H_%M_%S';
######################################################################
+##########
# Getoptions
######################################################################
+##########
unless (GetOptions (
"source|src|s=s" => \$glob,
"destination|dest|d=s" => \$dest,
"debug!" => \$debug,
"phratio|pr=f" => \$ph_ratio,
"winratio|wr=f" => \$win_ratio,
"gridx|x=i" => \$grid_col,
"gridy|y=i" => \$grid_row,
"preload|p=i" => \$preload,
"nothumbs!" => \$nothumbs,
"jpegquality|quality=i"=> \$jpeg_quality,
"extension|e=s" => \$out_ext,
"pngcompression=i"=> \$png_compression,
"dateformat|df=s" => \$date_format,
)
) {
print "GetOpt::Long returned errors (see above),".
"review available options:";
pod2usage(-verbose => 1);
}
# sanitize destination path
$dest = &sanitize_dest($dest);
# adjust x and y for the grid (which is zero based)
$grid_col -= 1;
$grid_row -= 1;
######################################################################
+##########
# other global variables
######################################################################
+##########
# @files is ArrayOfArray
# each element contains pic data as follow:
# 0 path
# 1 x
# 2 y
# 3 orientation
# 4 datetime joined with underscores
# 5 GD object of THUMB
# 6 [ GD object of PHOTO]
# the last field [6] will be filled only for current file ( which inde
+x is hold in $ph_index)
# and for elelments to be preloaded: from ($ph_index - $preload) to (
+$ph_index + $preload)
# thumb data [5] will be empty if $nothumbs is defined via -nothumbs c
+ommandline switch
my @files;
# @prepost is filled and cleared by next_pic
# it holds indexes of file preloaded
my @prepost;
# is the current index of photo list (@files)
my $ph_index = 0;
# display mode
my $display_mode = $nothumbs ? 'photo' : 'thumbs';
# status of loading and copying operations
my $status = "- status informations -";
# used to jump to a photo
my $gotonum;
# autoplay
my $toggle_autoplay = 0;
# seconds interval during autoplay
my $autoplay_sleep_interval = 3.0;
# the timer to do autoplay
my $tk_timer;
#
my $mw = new MainWindow ();
# output window used for big photos and thumbnails
# see http://www.perlmonks.org/?node_id=1172209
# to know why secondary windows is not yet created
my $phwin;
# the frame used in the photo window
my $scrolledframe;
# main big photo Tk::Photo object
my $tk_ph_image ;
# the label container of the current photo
my $photo_label;
# rows of thumbnails
my @temp_frames;
# curent thumbnails
my @temp_thumbs;
# help text window
my $hw;
# ADVANCED OPTIONS USED TO COPY AND POSTPROCESS PHOTOS
# advanced copy options TopLevel window
my $advw;
# allow files copied to replace file already present
my $allow_overwrite = 1;
# bypass original file GD elaboration, simply copying it
my $bypass_orig_el = 0;
# jpeg quality label
my $jpeg_quality_lbl;
# jpeg quality entry
my $jpeg_quality_ent;
# enable multi copies off by default
my $enable_multiple_copies = 0;
# skip original image
my $skip_orig = 0;
# skip original label
my $skip_orig_lbl;
# checkbutton associated to the above
my $skip_orig_chk;
# the pattern used to have multiple copies (800x600 1024x768 ..)
my $multi_pattern = '';
# pattern label
my $multi_pattern_lbl;
# entry widget for the above
my $multi_pattern_ent;
# enable post process of copied images off by default
my $enable_postprocess = 0;
my $exiftool_path = '';
my $exiftool_args = '';
# widget used by the above
my ($post_prog_lbl, $post_prog_btn,
$post_prog_ent, $post_prog_arg_lbl, $post_prog_arg_ent);
# a lookup table for all global bindings that use chars:
# used to prevent Entry widgets to invoke callbacks when inappropriate
# see http://www.perlmonks.org/?node_id=1173808
my %bind_table = (
'<space>' => sub{©_with_name},
'<KeyRelease-?>' => \&help_me,
'<KeyRelease-p>' => \&autoplay,
);
######################################################################
+##########
# build immediatley the file list
@files = &build_list($glob);
######################################################################
+##########
$mw->Icon(-image => $mw->Pixmap(-data => &woodpecker_icon));
$mw->geometry("850x480+0+0");
$mw->title(" Pic Wood Pecker ");
$mw->optionAdd('*font', 'Courier 10');
$mw->optionAdd('*Label.font', 'Courier 10');
$mw->optionAdd( '*Entry.background', 'lavender' );
$mw->optionAdd( '*Entry.font', 'Courier 12 bold' );
# title frame
my $fr0 = $mw->Frame(-borderwidth => 2, -relief => 'groove'
)->pack(-side=>'top',-padx=>5,-pady=>5,-fill=>'x');
$fr0->Label(-text => "$0"
)->pack(-fill=>'x',-expand=>1,-side=>'left',-pady=>10);
$fr0->Button(-text => "?",-borderwidth => 4,
-command => \&help_me,
)->pack(-side=>'right',-padx=>10);
# list options frame
my $fr1 = $mw->Frame(-borderwidth => 2, -relief => 'groove'
)->pack(-side=>'top',-padx=>5,-pady=>5,-fill=>'x');
$fr1->Label(-text => "source")->pack(-side => 'left');
$fr1->Entry(-width => 20,-borderwidth => 4, -textvariable => \$glo
+b
)->pack(-side => 'left', -expand => 1,-padx=>5);
# 10.9 addition
$fr1->Button(-padx=> 5,-text => "browse",-borderwidth => 4,
-command => sub{
$glob = $mw->chooseDirectory(-initiald
+ir => '~',
-title => 'Choose a folder');
}
)->pack(-side => 'left',-expand => 1,-padx=>5);
# end of 10.9 addition
$fr1->Button(-padx=> 5,-text => "new list",-borderwidth => 4,
-command => sub{
&clear_current;
$ph_index = 0;
$display_mode = 'photo';
@files=&build_list($glob,undef);
&setup_draw_area;
next_pic(0);
}
)->pack(-side => 'left',-expand => 1,-padx=>5);
$fr1->Button( -padx=> 5,-text => "view list",-borderwidth => 4,
-command => sub{
if(@files){
print "Current files:\n",
map{"\t$_->[0]\n"}@files;
}
else{
print "No files in the list\n";
return;
}
}
)->pack(-side => 'left',-expand => 1,-padx=>5);
$fr1->Button( -padx=> 5,-text => "add to list",-borderwidth => 4,
-command => sub{
&clear_current;
if (scalar @files){
@files = (@files,&build_list($gl
+ob,'add'));
}
else{
@files = &build_list($glob);
$ph_index = 0;
}
$ph_index = 0 if $ph_index > $#files
+;
$display_mode = 'photo';
&setup_draw_area;
next_pic(0);
}
)->pack(-side => 'left',-expand => 1,-padx=>5);
$fr1->Button( -padx=> 5,-text => "clear list",-borderwidth => 4,
-command => sub{
&clear_current;
$ph_index = 0;
$display_mode = 'photo';
@files=();
}
)->pack(-side => 'left',-expand => 1,-padx=>5);
# photos destination folder options frame
my $fr1b = $mw->Frame(-borderwidth => 2, -relief => 'groove'
)->pack(-side=>'top',-padx=>5,-pady=>5,-fill=>'x');
$fr1b->Label(-text => "destination"
)->pack(-side => 'left');
$fr1b->Entry( -width => 50,-borderwidth => 4,
-textvariable => \$dest
)->pack(-side => 'left', -expand => 1,-padx=>5);
$fr1b->Button( -padx=> 5,-text => "set",
-borderwidth => 4,
-command => sub{$mw->focus}
)->pack(-side => 'right',-expand => 1,-padx=>5);
# photo ratio and window ratio options frame
my $fr2 = $mw->Frame(-borderwidth => 2, -relief => 'groove'
)->pack(-side=>'top',-padx=>5,-pady=>5,-fill=>'x');
$fr2->Label(-text => "photo ratio"
)->pack(-side => 'left',-expand => 1);
$fr2->Entry(-width => 4,-borderwidth => 4,
-textvariable => \$ph_ratio,
)->pack(-side => 'left', -expand => 1,-padx=>5);
$fr2->Label(-text => "window ratio"
)->pack(-side => 'left',-expand => 1);
$fr2->Entry(-width => 4,-borderwidth => 4,
-textvariable => \$win_ratio
)->pack(-side => 'left', -expand => 1,-padx=>5);
$fr2->Button( -padx=> 5,-text => "set ratios",-borderwidth => 4,
-command => sub{&set_ratio}
)->pack(-side => 'left',-expand => 1,-padx=>5);
$fr2->Label(-text => "debug"
)->pack(-side => 'left',-expand => 1);
$fr2->Checkbutton(-variable =>\$debug,
-command => sub { status('DarkGreen',
"debug informations to the con
+sole ".
($debug ? 'ENABLED' : 'DISABLE
+D'))
}
)->pack();
# current photo exif information frame
my $label_exif_txt = "too soon to have photo data..";
my $fr3 = $mw->Frame(-borderwidth => 2, -relief => 'groove'
)->pack(-side=>'top',-padx=>5,-pady=>5,-fill=>'x');
$fr3->Label( -justify => 'left',-foreground => 'black',
-textvariable => \$label_exif_txt
)->pack;
# new name frame
my $newname;
my $suffix='';
my $fr4 = $mw->Frame(-borderwidth => 2, -relief => 'groove'
)->pack(-side=>'top',-padx=>5,-pady=>5,-fill=>'x');
$fr4->Label(-text => "copy name"
)->pack(-side => 'left',-expand => 1);
my $entryname=$fr4->Entry(-width => 30,-borderwidth => 4,
-textvariable => \$newname
)->pack(-side => 'left', -expand => 1,-padx=>5);
$fr4->Label(-text => "suffix name"
)->pack(-side => 'left',-expand => 1);
$fr4->Entry(-width => 20,-borderwidth => 4,
-textvariable => \$suffix
)->pack(-side => 'left', -expand => 1,-padx=>5,-fill=>'x');
my $fr4b = $mw->Frame(-borderwidth => 2, -relief => 'groove'
)->pack(-side=>'top',-padx=>5,-pady=>5,-fill=>'x');
my $entrynamebutton = $fr4b->Button(-borderwidth => 4,
-text => ' copy this photo
+ ',
-command => \©_with_name,
)->pack(-expand=>1,-side=>'left',-padx=>5);#
$fr4b->Button(-text => "advanced",-borderwidth => 4,
-command => \&advanced_options,
)->pack(-side=>'right',-padx=>10);
# status frame
my $fr4c = $mw->Frame(-borderwidth => 2, -relief => 'groove'
)->pack(-side=>'top',-padx=>5,-pady=>5,-fill=>'x');
my $statuslabel = $fr4c->Label( -justify => 'left',-foreground => 'bl
+ack',
-textvariable => \$status
)->pack;
# commands frame
my $fr5 = $mw->Frame(-borderwidth => 2, -relief => 'groove'
)->pack(-side=>'top',-padx=>5,-pady=>5,-fill=>'x');
my $butrwd = $fr5->Button(-borderwidth => 4,
-text => ' < ',
-command => sub {
if ($display_mode eq 'phot
+o'){
&next_pic(-1);
}
else{
&prev_thumbs;
}
} )->pack(-side => 'left',-expand => 1,-padx
+=>5);
my $butfwd = $fr5->Button(-borderwidth => 4,
-text => ' > ',
-command => sub {
if ($display_mode eq 'phot
+o'){
&next_pic(1);
}
else{
&next_thumbs;
}
})->pack(-side => 'left',-expand => 1,-padx=
+>5);
### these packed right side are in reverse order!
$fr5->Label(-text => "seconds"
)->pack(-side => 'right',-expand => 1);
$fr5->Entry(-width => 4,-borderwidth => 4,
-textvariable => \$autoplay_sleep_interval
)->pack(-side => 'right', -expand => 1,-padx=>5,-fill=>'x');
$fr5->Label(-text => "each"
)->pack(-side => 'right',-expand => 1);
$fr5->Button( -borderwidth => 4,
-text => 'autoplay',
-command => \&autoplay
)->pack(-side => 'right',-expand => 1,-padx=>5);
#
$fr5->Entry(-width => 3,-borderwidth => 4,
-textvariable => \$gotonum
)->pack(-side => 'right', -padx=>5);
$fr5->Button( -padx=> 5,-text => "go to photo number",-borderwidth =>
+4,
-command => sub{&gotonum($gotonum)}
)->pack(-side => 'right',-padx=>5);
# bindings valid for all display modes
# see http://www.perlmonks.org/?node_id=1173808
foreach my $bind (keys %bind_table){
$mw->bind($bind => $bind_table{$bind});
# remove bindings for all Tk::Entry in all windows
$mw->bind('Tk::Entry', $bind,sub{Tk->break});
}
# bind Return to for Tk::Entry to give the focus to parent
$mw->bind('Tk::Entry','<Return>' => sub{$_[0]->parent->focus});
if (@files){
print "Starting with $files[$ph_index]->[0]\n";
$butrwd->configure( -text => 'not available',-state => 'disabled'
+);
# see http://www.perlmonks.org/?node_id=1172209
$mw->update;
&setup_draw_area;
$nothumbs ? &next_pic(0) : &draw_thumbs;
$phwin->focus();
}
else{ print "No file to process\n" }
$mw->MainLoop;
######################################################################
+##########
# SUBS
######################################################################
+##########
sub autoplay {
if ($toggle_autoplay == 0){
$toggle_autoplay = 1 ;
$display_mode = 'photo';
&setup_draw_area();
$ph_index--;
$tk_timer = $phwin->repeat(
1000 * $autoplay_sleep_interval,
[\&next_pic,1]
);
}
else {
$toggle_autoplay = 0;
$tk_timer->cancel if $tk_timer;
}
if ($ph_index == $#files){ $tk_timer->cancel;}
}
######################################################################
+##########
sub setup_draw_area {
print "\tsetup_draw_area called\n" if $debug ;
# chek if the window exists
if (! Exists($phwin)) {
$phwin = $mw->Toplevel();
$phwin->Icon(-image=>$mw->Pixmap(-data => &woodpecker_icon=~s/#2
+96D17/#5c6998/r ));
# photo window starts just right (+865) of command window
$phwin->geometry("0x0+865+0");
$scrolledframe = $phwin->Scrolled('Frame',
-background=>'black',
-scrollbars => 'osoe',
)->pack(-expand => 1, -fill => 'both');
$photo_label = $scrolledframe->Label(-image => $tk_ph_image,
-background =>'black'
)->pack(-side => 'top',
-anchor => 'n',
-fill => 'both',
-expand => 1,
); # was just pack
$tk_ph_image = $phwin->Photo(-file => '' ) or die $!;
# see again: http://www.perlmonks.org/?node_id=1172209
# even if here is not used
# $phwin->protocol( 'WM_DELETE_WINDOW', [sub{shift->withdraw}, $
+phwin], );
}
# window Exists
else {
$phwin->deiconify( ) if $phwin->state() eq 'iconic';
$phwin->raise( ) if $phwin->state() eq 'withdrawn';
}
$phwin->focus;
# THUMBS display
if ($display_mode eq 'thumbs') {
return if $nothumbs;
return unless @files;
# tadàààà packForget !!
$photo_label->packForget();
my $max_x = 164 * ($grid_col + 1) + 50;
my $max_y = 164 * ($grid_row + 1) + 50;
$phwin->geometry($max_x."x".$max_y.""
);
$phwin->update();
# enable buttons
$butfwd->configure( -text => ' > ',-state => 'normal
+' );
$butrwd->configure( -text => ' < ',-state => 'normal
+' );
$entrynamebutton->configure(-state=>'disabled');
# BINDINGS
$phwin->bind('<KeyRelease-Down>' => sub {&next_thumbs()} );
$phwin->bind('<KeyRelease-Up>' => sub {&prev_thumbs()} );
#
$phwin->bind('<KeyRelease-Left>' => sub {$_[0]->focusPrev;} );
$phwin->bind('<KeyRelease-Right>' => sub {$_[0]->focusNext;});
#
$mw->bind('<KeyRelease-Right>' => sub {&next_thumbs()} );
$mw->bind('<KeyRelease-Left>' => sub {&prev_thumbs()} );
}
# PHOTO display
else{
&clear_thumbs();
$photo_label->pack();
return unless @files;
$phwin->geometry( int($files[$ph_index]->[1]*$win_ratio+30) .
"x".
int($files[$ph_index]->[2]*$win_ratio+30).
""
);
$phwin->title( &file_name($files[$ph_index]->[0]) );
$entrynamebutton->configure(-state=>'normal');
# PHOTO display BINDINGS
$phwin->bind('<KeyRelease-Down>' =>
sub {
return if $nothumbs;
$display_mode = 'thumbs';
$tk_ph_image->delete if $tk_ph_image->blan
+k;
&clear_current();
&setup_draw_area();
&draw_thumbs()
} );
$phwin->bind('<KeyRelease-Up>' =>
sub {
return if $nothumbs;
$display_mode = 'thumbs';
$tk_ph_image->delete if $tk_ph_image->blan
+k;
&clear_current();
&setup_draw_area();
&draw_thumbs();
} );
$phwin->bind('<KeyRelease-Left>' => sub {&next_pic(-1) if $ph_
+index > 0} );
$phwin->bind('<KeyRelease-Right>' => sub {&next_pic(1) if $ph_
+index < $#files} );
#
$mw->bind('<KeyRelease-Left>' => sub {&next_pic(-1) if $ph_ind
+ex > 0} );
$mw->bind('<KeyRelease-Right>' => sub {&next_pic(1) if $ph_ind
+ex < $#files} );
}# end of PHOTO display setup
# bindings valid for all display modes
# see http://www.perlmonks.org/?node_id=1173808
foreach my $bind (keys %bind_table){
$phwin->bind($bind => $bind_table{$bind});
}
}
######################################################################
+##########
sub draw_thumbs {
print "\tdraw_thumbs called\n" if $debug;
next_pic(0) if $nothumbs;
my $row = 0;
my $col = 0;
&clear_thumbs();
# just get ids of which thums to load
my @cur_thumbs = &which_thumbs();
$phwin->title( 'thumbnails '.($#cur_thumbs >= 1 ?
(join '-',@cur_thumbs[0,-1]):
$cur_thumbs[0]).
" of 0-$#files (use TAB to navigate,".
" RETURN to view, UP and DOWN to load other thumbnails
+) " );
my $temp_frame = $scrolledframe->Frame(
-background => 'black', -borderwidth => 0,
)->pack(-side=>'top',-fill=>'x');
push @temp_frames,$temp_frame;
foreach my $th_ind (@cur_thumbs){
my $ph_thumb = $scrolledframe->Photo(-file => '' ) or warn $!;
$ph_thumb->configure( -file => undef,
-data => MIME::Base64::encode($files[$th
+_ind]->[5]->jpeg())
);
push @temp_thumbs,$ph_thumb;
my $canv = $temp_frame->Canvas(
-background =>'black',
-borderwidth => 0,
# no white border when not selected
-highlightbackground => 'black',
# do not allow scrolling pics inside..
-scrollregion => [0,0,160,160],
-highlightcolor => 'red3',
-takefocus => 1,
-height => 160,
-width => 160 ,
)->pack(-side => 'left',-expand => 1,-padx=>5);
$canv->createImage( 81,81,
-image => $ph_thumb,
-tags => ["$th_ind"],
);
# bind the selected canvas
$canv->CanvasBind('<Return>', sub{&choice_thumb($th_ind) } );
# highlight the first one of the current grid
$canv->focusForce if $th_ind == $ph_index;
# grid mamagement
if ($col > 0 and ($col % ($grid_col || 1)) == 0){
$col = 0;
$row++;
$temp_frame = $scrolledframe->Frame(
-background => 'black', -borderwidth => 0,
)->pack(-side=>'top',-fill=>'x');
push @temp_frames,$temp_frame;
}
else{$col++}
} # end of foreach my $th_ind (@cur_thumbs)
$phwin->focus;
}
######################################################################
+##########
sub draw_photo {
my $ph_index = shift;
print "\tdraw_photo got:\n\t",(join '|',map{defined $_ ? $_ : 'undef
+'}
(@{$files[$ph_index]}[0..4],
$files[$ph_index]->[5]?'THUMB':'NO DATA',
$files[$ph_index]->[6]?'PHOTO':'NO DATA',
)),"\n" if $debug;
$tk_ph_image->delete if $tk_ph_image->blank;
$phwin->geometry( int($files[$ph_index]->[1]*$win_ratio+30) .
"x".int($files[$ph_index]->[2]*$win_ratio+30));
$phwin->title( &file_name($files[$ph_index]->[0]) );
my $small_w = int($files[$ph_index]->[1] * $ph_ratio);
my $small_h = int($files[$ph_index]->[2] * $ph_ratio);
# create the resized but still empty GD image
my $resized = GD::Image->new($small_w,$small_h);
# copy from source into resized on
$resized->copyResampled($files[$ph_index]->[6],0,0,0,0,
$small_w,
$small_h,
$files[$ph_index]->[6]->width,
$files[$ph_index]->[6]->height);
$tk_ph_image->configure( -file => undef,
-data => MIME::Base64::encode($resized->jpe
+g())
);
# configure the Tk::Label to use the Tk::Photo as image
$photo_label->configure(-image => $tk_ph_image );
# update exif text
my @times=split /_/,($files[$ph_index]->[4] || '');
$label_exif_txt = "file ".($ph_index+1)." of ".($#files+1)." ".
"$files[$ph_index]->[0]\n".
"width:\t\t$files[$ph_index]->[1]\n".
"height:\t\t$files[$ph_index]->[2]\n".
"orientation:\t".
($files[$ph_index]->[3] ?
$files[$ph_index]->[3] :
'-NOT FOUND-')."\n".
"creation:\t".
(join '.',map{defined $_ ? $_ : 'x'} @times[0.
+.2]).' '.
(join ':',map{defined $_ ? $_ : 'x'} @times[3.
+.5])."\n".
"data loaded:\t".
(defined $files[$ph_index]->[6] ? 'OK' : 'ERRO
+R');
# udate the name used to (eventually) save current pic
$newname = &create_name($files[$ph_index]->[4]);
$phwin->focus();
}
######################################################################
+##########
sub next_pic {
return unless @files;
my $increment = shift;
$ph_index = $ph_index + $increment;
$tk_timer->cancel if $ph_index > $#files;
$ph_index = $#files if $ph_index > $#files;
$ph_index = 0 if $ph_index < 0;
#return unless @files;
print +($debug ? "\n" : '').
"Considering files[$ph_index] $files[$ph_index]->[0]\n";
&setup_draw_area unless Exists($phwin);
# enable button back because it starts disabled
if ($ph_index > 0 && $butrwd->cget('-state') eq 'disabled'){
$butrwd->configure( -text =>' < ',-state => 'normal'
+);
}
# disable it if first photo
if ($ph_index == 0 ){
$butrwd->configure( -text =>'not available',-state => 'disabled
+' );
}
# disable fwd button if last photo
if ($ph_index == $#files ){
$butfwd->configure( -text =>'not available',-state => 'disabled
+' );
}
# enable it again if not last photo
if ($ph_index < $#files && $butfwd->cget('-state') eq 'disabled'){
$butfwd->configure( -text =>' > ',-state => 'normal'
+);
}
# preload
if ($preload > 0){
# check if img is yet loaded(change of ratio cleared it?)
if (defined $files[$ph_index]->[6]) {
print "\tphoto data yet defined for files[$ph_index]\n" if $
+debug;
&draw_photo($ph_index);
}
else {
print "\tphoto data NOT defined for files[$ph_index]\n" if $
+debug;
$files[$ph_index]->[6] = &get_ph_data($ph_index);
print "\tfilled photo data for current: files[$ph_index]\n"
+if $debug;
&draw_photo($ph_index);
}
# elaborate preload: filling and clearing actions
@prepost = grep {$_ != $ph_index &&
$_ >= 0 &&
$_ <= $#files}
($ph_index - $preload)..($ph_index + $preload);
print "\tcurrent $ph_index preload [@prepost]\n" if $debug;
foreach my $ind (@prepost){
if (defined $files[$ind]->[6]){
print "\tskipping PRELOADED files[$ind] (yet defined)\n" i
+f $debug;
next;
}
else {$files[$ind]->[6] = &get_ph_data($ind);
print "\tfilled files[$ind] photo data\n" if $debug; }
}
# delete unneeded elements leaved behind or forward
if ($increment == 1){
if ( $prepost[0]-1 >= 0 && $prepost[0]-1 < $ph_index){
$files[$prepost[0]-1]->[6] = undef;
print "\tcleared files[".($prepost[0]-1)."] photo data\n"
+if $debug;
}
}
elsif ($increment == -1){
if ($prepost[-1]+1 <= $#files){
$files[$prepost[-1]+1]->[6] = undef;
print "\tcleared files[".
($prepost[-1]+1)."] photo data\n" if $debug;
}
}
else{print "\tzero or other non significant increment for next_
+pic\n" if $debug}
# update status
if ((scalar grep{defined $files[$_]->[6]}@prepost,$ph_index )
==
(@prepost +1)){
status('DarkGreen',"\tOK loaded ".
(@prepost +1).
" photo data for files[".
(join',',$ph_index,@prepost)."]");
}
else{status('red3',"\tERROR not all loaded correctly!");}
}
# no preload activated
else{
@prepost = ($ph_index);
$files[$ph_index]->[6] = &get_ph_data($ph_index);
&draw_photo($ph_index);
if (defined $files[$ph_index - 1]->[6]){
$files[$ph_index - 1]->[6] = undef;
print "\tCurrent $ph_index cleared files[".
($ph_index-1)."]\n" if $debug;
}
}
# ultradebug file list
if ($debug == 2){
foreach my $f (0..$#files){
print "FOR FILES[$f]",
(defined $files[$f]->[6]?'DATA DEFINED':'undef'),
"\n";
}
}
}
######################################################################
+##########
sub get_ph_data {
my $index = shift;
return unless -e $files[$index]->[0];
# load original pic file in GD using general purpose method
my $gd_image = GD::Image->new($files[$index]->[0]);
# if not defined try newFromJpeg
unless ($gd_image){
status('red3', "\tGD image not defined for [$files[$index]->[0]]
+".
" i'll try assuming it is JPEG");
$gd_image = GD::Image->newFromJpeg($files[$index]->[0]);
}
# if it is still undefined...
unless ($gd_image){
status('red3', "\tGD image UNAVAILABLE for [$files[$index]->[0]]
+ $!\n");
#added in 9.12e
return undef;
}
# handle rotation
if (defined $files[$index]->[3] && $files[$index]->[3] =~/(\d+)/){
my $rot = $1;
print "\tRotation detected in main photo: $rot\n" if $debug;
$gd_image = &handle_rotation(\$gd_image,$rot);
}
# check if dimensions are not present (probably never happens)
unless ($files[$index]->[1]){
$files[$index]->[1] = $gd_image->width;
print "\twidth not in EXIF tags: i'll use [$files[$index]->[
+1]]\n";
}
unless ($files[$index]->[2]){
$files[$index]->[2] = $gd_image->height;
print "\theight not in EXIF tags: i'll use [$files[$index]->
+[2]]\n";
}
return $gd_image;
}
######################################################################
+##########
sub clear_thumbs{
foreach my $temp_thumb(@temp_thumbs){
$temp_thumb->delete if $temp_thumb->blank;
$temp_thumb = undef;
}
foreach my $slave_frame (@temp_frames){
next unless Exists($slave_frame);
$slave_frame->destroy;
}
@temp_frames = ();
@temp_thumbs = ();
}
######################################################################
+##########
sub clear_current {
return unless @files;# prevent autovivification in the next line
map { $files[$_]->[6] = undef} @prepost,$ph_index;
print "\tcleared photo data of preloaded files [@prepost]\n" if
+$debug;
}
######################################################################
+##########
sub next_thumbs {
print "\tnext_thumbs: index was $ph_index\n" if $debug;
$ph_index += ($grid_col + 1) * ($grid_row + 1) ;
print "\tnext_thumbs: index is now $ph_index\n" if $debug;
if ($ph_index > $#files){$ph_index = $#files}
&setup_draw_area() unless Exists $phwin;
&draw_thumbs();
}
######################################################################
+##########
sub prev_thumbs {
print "\tprev_thumbs: index was $ph_index\n" if $debug;
$ph_index -= ($grid_col + 1) * ($grid_row + 1) ;
print "\tprev_thumbs: index is now $ph_index\n" if $debug;
if ($ph_index < 0){$ph_index = 0}
&setup_draw_area() unless Exists $phwin;
&draw_thumbs();
}
######################################################################
+##########
sub which_thumbs {
my $last = ($grid_col + 1) * ($grid_row + 1) - 1 + $ph_index;
if ($last > $#files){$last = $#files}
print "\twhich_thumbs: [",(join ' ',($ph_index .. $last)),"]\n" if
+ $debug;
$label_exif_txt = "thumbnail grid of photos: ".
(join '-',($ph_index,$last))."(0 .. $#files)";
return ($ph_index .. $last);
}
######################################################################
+##########
sub choice_thumb {
# see master zentara: http://www.perlmonks.org/?node_id=969034
# http://www.perlmonks.org/?node_id=931375
my ($index) = @_;
print "\tchoice_thumb received $index\n" if $debug;
&clear_thumbs();#added in v9.12b
$display_mode = 'photo';
&setup_draw_area;
&gotonum($index +1);
}
######################################################################
+##########
sub get_exif_data {
my $file = shift;
my $exifTool = new Image::ExifTool;
$exifTool-> Options(Binary => 1, Composite => 1,
DateFormat => $date_format, #'%Y_%m_%d_%H_%M_%
+S',
Unknown => 2, Verbose => 0);
my $exifinfo = $exifTool->ImageInfo($file,'ImageWidth',
'ImageHeight',
'Orientation',
'DateTimeOriginal',
'ThumbnailImage');
my $gd; # double dereference only fo
+r thumb!!!
eval{$gd = GD::Image->newFromJpegData(${$$exifinfo{'ThumbnailImage
+'}}||'')};
if ($@){
print "ERROR creating a thumbnail for file [$file].".
"I will use an empty one.\n";
$gd = GD::Image->new(160,160);
}
# handle rotation
if(defined $$exifinfo{'Orientation'} && $$exifinfo{'Orientation'}=
+~/(\d+)/){
my $rot = $1;
print "Rotation detected in thumbnail: $rot\n" if $debug;
$gd = &handle_rotation(\$gd,$rot);
if ($rot == 90 or $rot == 270){
# rearrange returned exif infos to adjust the photo wind
+ow too
my $orig_w = $$exifinfo{'ImageWidth'};
my $orig_y = $$exifinfo{'ImageHeight'};
$$exifinfo{'ImageHeight'} = $orig_w;
$$exifinfo{'ImageWidth'} = $orig_y;
}
}
# return a five elements list
return ($$exifinfo{'ImageWidth'},
$$exifinfo{'ImageHeight'},
$$exifinfo{'Orientation'},
$$exifinfo{'DateTimeOriginal'},
($nothumbs ? '' : $gd)
);
}
######################################################################
+##########
sub handle_rotation {
my $imgref = shift;
my $rot = shift;
my $gd = $$imgref;
if ($rot == 90){
$gd=$gd->copyRotate90();
}
elsif($rot == 180){
$gd=$gd->copyRotate180();
}
elsif($rot == 270){
$gd=$gd->copyRotate270();
}
else{print "Warning! unexpected rotation [$rot] received!\n"}
return $gd;
}
######################################################################
+##########
sub build_list{
my $glob=shift;
my $add = shift;
print "build_list received [$glob]\n" if $debug;
my @list = glob($glob);
if (@list == 1 and -d $glob) {
print "DIR found: [$glob] will be converted to [$glob".
'/*.jpg]'."\n" if $debug;
@list = glob($glob.'/*.jpg');
}
elsif (scalar @list and ! -e $list[0] ){
print "[$glob] NOT found: './*.jpg' will be used\n" if $debug;
@list = glob('./*.jpg');
}
elsif(scalar @list == 0){print "Empty list searching [$glob]!\n";r
+eturn();}
else {1}
return () unless @list;
print "Please wait while processing ".(scalar @list)." files....\n
+";
# rel2abs
@list = map {File::Spec->file_name_is_absolute($_) ?
$_ : File::Spec->rel2abs($_)} @list;
# when adding to the list check for duplicates
if ($add){
my %uniq;
@uniq{@list}=map {1} @list;
foreach my $yet (@files){
if (defined $yet->[0] && exists $uniq{$yet->[0]} ){
print "\tskipping $yet->[0] because yet in the list\
+n";
delete $uniq{$yet->[0]};
}
}
@list = keys %uniq;
}
my @files_to_add;
# populate every [0] entries with absolute path
map { push @files_to_add,[$_] } @list;
if ($debug){print "\tadding $$_[0]\n" for @files_to_add;}
# fill every [1..5] with values got from get_exif_data
foreach my $index (0..$#files_to_add){
@{$files_to_add[$index]}[1..5] = &get_exif_data($files_to_add[
+$index]->[0]);
}
return @files_to_add;
}
######################################################################
+##########
sub file_name{
my $path = shift;
my (undef,undef,$name) = File::Spec->splitpath( $path );
return $name;
}
######################################################################
+##########
sub gotonum{
my $num = shift;
unless ($num =~ /^\d+$/){status ('red3',"[$num] is not a number!")
+;return}
if ( $num < 0 or $num > $#files+1){
status ('red3',"[$num] not in range!");
return;
}
&clear_current();
$ph_index = $num - 1;
print "\tjumping to photo $num\n" if $debug;
$display_mode = 'photo';
&setup_draw_area();
&next_pic(0);
$phwin->focus();
}
######################################################################
+##########
sub status{
my ($color,$str)=@_;
($status = $str) =~s/^\s+//;
chomp $str;
print "$str\n";# if $debug;
$statuslabel->configure(-foreground=>$color);
$phwin->focus;
}
######################################################################
+##########
sub set_ratio{
foreach my $tocheck($win_ratio,$ph_ratio){
$tocheck = 0.25 if $tocheck =~/[^\d\.]+/;
$tocheck = 0.25 if $tocheck > 1;
}
my @prepost = grep { $_ >= 0 &&
$_ <= $#files }
(($ph_index - $preload)|| 0)..($ph_index + $pre
+load);
print "\tset_ratio will clear photo data for indexes [@prepost]\n"
+ if $debug;
if (@files){ #prevent autovivification?
map { $files[$_]->[6] = undef } @prepost;
}
print "\tcleared photo $ph_index and preloaded [@prepost]\n" if $d
+ebug;
&next_pic(0);
}
######################################################################
+##########
sub copy_with_name{
return if $display_mode eq 'thumbs';
my $name = &create_name($files[$ph_index]->[4]);
my @wrote;
# just original image
unless ($skip_orig){
# bypass GD if $bypass_orig_el copying directly (better qualit
+y)
if ($bypass_orig_el){ # forced jpg ext
+ension!!
my $copy = File::Spec->catfile($dest,$name.'.'.'jpg');
print "\tJust copying [$files[$ph_index]->[0]]\t[$copy]\n"
+if $debug;
if ( copy ($files[$ph_index]->[0],$copy)) {
push (@wrote, $copy);
}
}
# elaborate original with GD
else {
if (my $ok = &write_file(\$files[$ph_index]->[6],$name))
+{
push (@wrote, $ok);
}
}
}
# multiple copies enabled in advanced options
if ($enable_multiple_copies){
my @res = split /\s+/,$multi_pattern;
foreach my $size(@res){
my ($w,$h) = split /x/i,$size;
# swap dimension if original are swapped
# brutally cheching if y > x (necessary to avoid malformed imag
+es)
if ($files[$ph_index]->[2] > $files[$ph_index]->[1]){
my $temp_w = $h;
$h = $w;
$w = $temp_w;
print "\trotation detected, swapping dimensions to [$w]\t[$h]\
+n" if $debug;
}
my $resized = GD::Image->new($w,$h);
$resized->copyResampled($files[$ph_index]->[6],0,0,0,0,
$w,
$h,
$files[$ph_index]->[6]->width,
$files[$ph_index]->[6]->height);
print "\tDebug size: PHOTO data is [$files[$ph_index]->[1]]\t".
"[$files[$ph_index]->[2]]\n".
" resized [$w]\t[$h]\n" if $debug;
if (my $ok = &write_file(\$resized,$name.'_'.$w.'x'.$h)){
push (@wrote, $ok);
}
}
}# end of multiple copies
# post processing enabled in advanced options
if ($enable_postprocess){
# check if the program exists and can be run
unless( -e $exiftool_path && -x $exiftool_path){
print "warning! [$exiftool_path] not executable or not found!"
+.
" No postprocessing for [@wrote]\n";
return 0;
}
foreach my $file(@wrote){
my @args = map{s/^\$$/$files[$ph_index]->[0]/e;$_} split /\s+
+/,$exiftool_args;
print "I'll execute the following command:\n".
"$exiftool_path ".(join ' ',@args)." $file\n";
local $?; #needed?
system($exiftool_path, @args, $file);
if ($? == 0){
status('DarkGreen',"OK the postprocess command was succesf
+ul")
}
elsif ($? == -1) {
status('red3',"ERROR the postprocess command failed: $!\n"
+);
}
elsif ($? & 127) {
status ('red3',(sprintf "child died with signal %d, %s cor
+edump\n",
($? & 127), ($? & 128) ? 'with' : 'without'));
}
else {
status('red3',(sprintf "child exited with value %d\n", $?
+>> 8));
}
}
}
}
######################################################################
+##########
sub write_file{
my $gd = shift; # a reference to GD data
my $name = shift;
my $flag = $allow_overwrite ?
(O_WRONLY | O_CREAT) :
(O_WRONLY | O_CREAT | O_EXCL);
$name = File::Spec->catfile($dest,$name.'.'.$out_ext);
if (sysopen my $out,$name,$flag){
binmode $out;
if ( $out_ext eq 'jpg' &&
defined $jpeg_quality &&
$jpeg_quality =~/^\d{1,3}$/ &&
$jpeg_quality <= 100 &&
$jpeg_quality >= 0 )
{ print $out $$gd->jpeg($jpeg_quality);
print "\tquality $jpeg_quality used for jpeg\n" if $debug;
}
elsif ($out_ext eq 'jpg'){
print $out $$gd->jpeg();
print "\tdefault quality used for jpeg\n" if $debug;
}
elsif ($out_ext eq 'gif'){
print $out $$gd->gif();
}
elsif ($out_ext eq 'png' &&
defined $png_compression &&
$png_compression >= 0 &&
$png_compression <= 9 )
{
print $out $$gd->png();
print "\tcompression $png_compression used for png\n" if $de
+bug;
}
elsif ($out_ext eq 'png'){
print $out $$gd->png();
print "\tdefault cmpression used for png\n" if $debug;
}
elsif ($out_ext eq 'gd'){
print $out $$gd->gd();
}
elsif ($out_ext eq 'gd2'){
print $out $$gd->gd2();
}
else{0}
close $out;
status('DarkGreen',"OK wrote $name"),
return $name;
}
else{
status('red3',"NOT copied $name: $! - $^E"),
return 0;
}
}
######################################################################
+##########
sub create_name{
my $timestr = shift;
return ( $timestr || 'timestring_not_defined').'_'.
$ph_index.(length $suffix ? '_'.$suffix : '');
}
######################################################################
+##########
sub advanced_options {
if (! Exists($advw)) {
$advw = $mw->Toplevel();
$advw->Icon(-image=>$mw->Pixmap(-data => &woodpecker_icon));
$advw->geometry("620x315+0+0");
$advw->title("advanced copy options");
# allow overwrite frame
my $frmult0 = $advw->Frame( -borderwidth => 2,
-relief => 'groove'
)->pack(-side=>'top',-padx=>5,-pady=>5,-fill=>'x');
$frmult0->Label( -text => "allow overwrite",
-disabledforeground=>'gray'
)->pack(-side=>'left',-padx=>10);
$frmult0->Checkbutton(
-variable =>\$allow_overwrite,
)->pack(-side=>'left',-padx=>10);
# bypass original photo GD elaboration (just copy the file) fram
+e
my $frmult0a = $advw->Frame( -borderwidth => 2,
-relief => 'groove'
)->pack(-side=>'top',-padx=>5,-pady=>5,-fill=>'x');
$frmult0a->Label(-text=>"bypass original file elaboration (simpl
+e copy)",
)->pack(-side=>'left',-padx=>10);
$frmult0a->Checkbutton(
-variable =>\$bypass_orig_el,
)->pack(-side=>'left',-padx=>10);
# change extension (and data type) of the output file, quality f
+or jpeg
my $frmult0b = $advw->Frame( -borderwidth => 2,
-relief => 'groove'
)->pack(-side=>'top',-padx=>5,-pady=>5,-fill=>'x');
$frmult0b->Label( -text => "output file type",
-disabledforeground=>'gray'
)->pack(-side=>'left',-padx=>10);
$frmult0b->Optionmenu(
-options => [qw(jpg gif png gd gd2)], # wbmp ?
-command => \&advanced_options,
-variable => \$out_ext,
)->pack(-side=>'left',-padx=>10);
$jpeg_quality_lbl = $frmult0b->Label( -text => "jpeg quality (0-
+100)",
-disabledforeground=>'gray'
)->pack(-side=>'left',-padx=>10);
$jpeg_quality_ent = $frmult0b->Entry( -width => 3,-borderwidth =
+> 4,
-textvariable => \$jpeg_qu
+ality,
)->pack(-side=>'left',-padx=>10);
# multiple copies frame
my $frmult1 = $advw->Frame( -borderwidth => 2,
-relief => 'groove'
)->pack(-side=>'top',-padx=>5,-pady=>5,-fill=>'x');
my $frmult2 = $frmult1->Frame(
)->pack(-side=>'top',-padx=>10,-fill=>'x');
$frmult2->Label(-text => "enable multiple copies",
)->pack(-side=>'left');
$frmult2->Checkbutton( -variable =>\$enable_multiple_copies,
-command => \&advanced_options
)->pack(-side=>'left',-padx=>10);
my $frmult3 = $frmult1->Frame(
)->pack(-side=>'top',-padx=>10,-fill=>'x');
$skip_orig_lbl = $frmult3->Label( -text => "do not copy original
+ image",
-state=>'disabled',
-disabledforeground=>'gray'
)->pack(-side=>'left',-padx=>10);
$skip_orig_chk = $frmult3->Checkbutton( -state => 'disable',
-variable =>\$skip_orig
)->pack(-side=>'left',-padx=>10);
my $frmult4 = $frmult1->Frame(
)->pack(-side=>'top',-padx=>10,-fill=>'x');
$multi_pattern_lbl = $frmult4->Label( -text => "multi copies pat
+tern",
-disabledforeground=>'gray
+',
-state=>'disabled'
)->pack(-side=>'left',-padx=>10);
$multi_pattern_ent = $frmult4->Entry( -width => 30,-borderwidth
+=> 4,
-textvariable => \$multi_p
+attern,
-state => 'disable'
)->pack(-side=>'left',-padx=>10);
# post processing frame
my $frpost1 = $advw->Frame( -borderwidth => 2,
-relief => 'groove'
)->pack(-side=>'top',-padx=>5,-pady=>5,-fill=>'x');
my $frpost2 = $frpost1->Frame(
)->pack(-side=>'top',-padx=>10,-fill=>'x');
$frpost2->Label(-text => "enable post processing",
)->pack(-side=>'left');
$frpost2->Checkbutton( -variable =>\$enable_postprocess,
-command => \&advanced_options
)->pack(-side=>'left',-padx=>10);
my $frpost3 = $frpost1->Frame(
)->pack(-side=>'top',-padx=>10,-fill=>'x');
$post_prog_lbl = $frpost3->Label( -text => "program ",
-disabledforeground=>'gray
+',
-state=>'disabled'
)->pack(-side=>'left',-padx=>10);
$post_prog_ent = $frpost3->Entry( -width => 30,-borderwidth => 4
+,
-textvariable => \$exiftoo
+l_path,
-state => 'disabled'
)->pack(-side=>'left',-padx=>10);
$post_prog_btn = $frpost3->Button( -text=>'locate exiftool',
-command=> \&locate_exif,
-state => 'disabled'
)->pack(-side=>'left',-padx=>10);
my $frpost4 = $frpost1->Frame(
)->pack(-side=>'top',-padx=>10,-fill=>'x');
$post_prog_arg_lbl = $frpost4->Label( -text => "arguments",
-disabledforeground=>'gray
+',
-state=>'disabled'
)->pack(-side=>'left',-padx=>10); #-fill=>'x',-expand=>1,
$post_prog_arg_ent = $frpost4->Entry( -width => 30,-borderwidth
+=> 4,
-textvariable => \$exiftoo
+l_args,
-state => 'disabled'
)->pack(-side=>'left',-padx=>10);
$advw->focus;
}
# window Exists
else {
$advw->deiconify( ) if $advw->state() eq 'iconic';
$advw->raise( ) if $advw->state() eq 'withdrawn';
$advw->focus;
}
# enable quality selection if jpeg
if ($out_ext eq 'jpg'){
map{ $_->configure(-state => 'normal')
}($jpeg_quality_lbl, $jpeg_quality_ent);
}
else{
map{ $_->configure(-state => 'disabled')
}($jpeg_quality_lbl, $jpeg_quality_ent);
}
# enable multi copies options if necessary
if ($enable_multiple_copies){
map{ $_->configure(-state => 'normal')
}($skip_orig_lbl,$skip_orig_chk,$multi_pattern_lbl,$multi_pa
+ttern_ent
);
}
# or disable them and clean values
else{
map{ $_->configure(-state => 'disabled')
}($skip_orig_lbl,$skip_orig_chk,$multi_pattern_lbl,$multi_pa
+ttern_ent
);
$skip_orig = 0;
$multi_pattern = '';
}
# enable post process options if necessary
if ($enable_postprocess){
map{ $_->configure(-state => 'normal')
}($post_prog_lbl, $post_prog_btn,
$post_prog_ent, $post_prog_arg_lbl, $post_prog_arg_ent);
}
# or disable them and clean values
else{
map{ $_->configure(-state => 'disabled')
}($post_prog_lbl, $post_prog_btn,
$post_prog_ent, $post_prog_arg_lbl, $post_prog_arg_ent);
}
}
######################################################################
+##########
sub locate_exif {
# directly populates $exiftool_path
my $path;
# $ENV{PATH} separator is ; in win and : in linux
my $sep = ($^O eq 'MSWin32' ? ';' : ':');
$path = (
grep{-e -x}map{($_.'\exiftool.bat',$_.'\exiftool')}split $sep,
+$ENV{PATH}
)[0];
if ($path){ print "found exiftool at $path\n";
$exiftool_path = File::Spec->file_name_is_absolute($path) ?
$path : File::Spec->rel2abs($path);
}
else { print "warning 'exiftool' program not found!\n"; }
}
######################################################################
+##########
sub help_me {
if (! Exists($hw)) {
$hw = $mw->Toplevel();
}
# window Exists
else {
$hw->deiconify( ) if $hw->state() eq 'iconic';
$hw->raise( ) if $hw->state() eq 'withdrawn';
$hw->focus;
}
my $chars = 'Courier 16';
$hw->geometry("900x450+0+0");
$hw->optionAdd('*Text.font' => $chars);
$hw->title("help page for $0");
my $txt = $hw->Scrolled('Text',
-scrollbars => 'osoe',
-background => 'blue3',
-foreground => 'gold2',
)->pack(-expand => 1, -fill => 'both');
$txt->Contents(`perldoc $0`);
}
######################################################################
+##########
sub sanitize_dest{
my $dest_cand = shift;
$dest_cand = File::Spec->file_name_is_absolute($dest_cand) ?
$dest_cand :
File::Spec->rel2abs($dest_cand);
+ # nofile
my ($volume,$directories,$file)= File::Spec->splitpath( $dest_ca
+nd, 1 );
my @dirs = File::Spec->splitdir( $directories );
# start with drive c: on win and '' on linux
my $subdir = $volume;
foreach my $dir (@dirs){
$subdir = File::Spec->catdir( $subdir, $dir );
# be sure to not touch root dir
next if $subdir =~/^\w:[\\\/]$|^\/$/i;
unless (-d -e $subdir){
print "WARNING: [$subdir] not found, i'll create it\n";
if (mkdir $subdir){
print "[$subdir] succesfully created\n";
}
else{
print "ERROR creating [$subdir] using '.' as destination
+\n";
# setting the global $dest
return File::Spec->rel2abs('.');
}
}
}
return $subdir;
}
######################################################################
+##########
sub woodpecker_icon{
return <<'EOI'
/* XPM */
static char * picchiorosso[] = {
"32 32 207 2",
" c None",
". c #296D17",
"+ c #256315",
"@ c #1B4A0F",
"# c #112D09",
"$ c #102A09",
"% c #223D0D",
"& c #415F15",
"* c #14360B",
"= c #040B02",
"- c #000100",
"; c #000000",
"> c #490303",
", c #EA0F0A",
"' c #863E10",
") c #163A0C",
"! c #090000",
"~ c #DE0808",
"{ c #F30A0A",
"] c #F20A0A",
"^ c #774110",
"/ c #286C16",
"( c #0F2A08",
"_ c #242626",
": c #D6A2A0",
"< c #F94747",
"[ c #F60E0E",
"} c #C40707",
"| c #270202",
"1 c #1A460E",
"2 c #2F6820",
"3 c #0C0E0C",
"4 c #040404",
"5 c #191918",
"6 c #303130",
"7 c #434343",
"8 c #EFEFEF",
"9 c #FFFFFF",
"0 c #FDD2D1",
"a c #1F0909",
"b c #384D32",
"c c #749B67",
"d c #131414",
"e c #888B86",
"f c #464B45",
"g c #B4B8B2",
"h c #FCFCFC",
"i c #BFC2C2",
"j c #191B1B",
"k c #393A39",
"l c #687066",
"m c #2E711D",
"n c #266715",
"o c #969167",
"p c #916B20",
"q c #495347",
"r c #0F110E",
"s c #CFD1CF",
"t c #F0F0F0",
"u c #20201F",
"v c #878787",
"w c #F1F3F0",
"x c #0E0E0E",
"y c #82907E",
"z c #4E7F40",
"A c #286A17",
"B c #163C0C",
"C c #030A02",
"D c #070502",
"E c #4E3504",
"F c #B3A27C",
"G c #FAFBFC",
"H c #848484",
"I c #454645",
"J c #DEDEDE",
"K c #4E4F4E",
"L c #121312",
"M c #081305",
"N c #0E2507",
"O c #1E5111",
"P c #235E13",
"Q c #040C02",
"R c #030303",
"S c #0D0E11",
"T c #101215",
"U c #242423",
"V c #484948",
"W c #939592",
"X c #BEBEBE",
"Y c #282828",
"Z c #FBFBFB",
"` c #666666",
" . c #12320A",
".. c #276A16",
"+. c #173F0D",
"@. c #091805",
"#. c #73866E",
"$. c #A0B49A",
"%. c #B2C4AD",
"&. c #CBD0CA",
"*. c #C8C8C8",
"=. c #989898",
"-. c #737373",
";. c #0A0A0A",
">. c #FDFDFD",
",. c #464746",
"'. c #050E03",
"). c #1F5211",
"!. c #286A16",
"~. c #225C13",
"{. c #246014",
"]. c #468136",
"^. c #BCD1B7",
"/. c #A6A6A6",
"(. c #090909",
"_. c #D0D0D0",
":. c #DCDCDC",
"<. c #747474",
"[. c #0B0C0B",
"}. c #010501",
"|. c #205712",
"1. c #276816",
"2. c #3F7C2F",
"3. c #DDE8DA",
"4. c #B7B7B7",
"5. c #232322",
"6. c #A6A7A6",
"7. c #686868",
"8. c #060606",
"9. c #010400",
"0. c #0A1D06",
"a. c #266515",
"b. c #B7CEB1",
"c. c #E1E1E1",
"d. c #0B0B0B",
"e. c #111111",
"f. c #151515",
"g. c #A7A7A7",
"h. c #EBEBEB",
"i. c #CED0CD",
"j. c #6A6D69",
"k. c #1B480F",
"l. c #A8C4A1",
"m. c #AAAAAA",
"n. c #505050",
"o. c #969696",
"p. c #141414",
"q. c #E9EAE9",
"r. c #D7D7D7",
"s. c #191919",
"t. c #205512",
"u. c #A1BE99",
"v. c #6B6B6B",
"w. c #1D1D1D",
"x. c #424242",
"y. c #010101",
"z. c #626362",
"A. c #CFD1CE",
"B. c #F1F1F1",
"C. c #080808",
"D. c #5B5B5B",
"E. c #222222",
"F. c #091905",
"G. c #4C853D",
"H. c #6E6E6E",
"I. c #A0A0A0",
"J. c #F8F8F8",
"K. c #2D2D2D",
"L. c #919191",
"M. c #BDBDBD",
"N. c #E6E6E6",
"O. c #D2D2D2",
"P. c #4C6645",
"Q. c #CACACA",
"R. c #656565",
"S. c #020202",
"T. c #565656",
"U. c #C5D7C0",
"V. c #3E772F",
"W. c #F0F3F0",
"X. c #CBCBCB",
"Y. c #F4F4F4",
"Z. c #F6F9F5",
"`. c #518842",
" + c #347523",
".+ c #E5EDE3",
"++ c #777777",
"@+ c #889485",
"#+ c #2F711E",
"$+ c #A1BF9A",
"%+ c #FAFAFA",
"&+ c #1B490F",
"*+ c #F3F6F2",
"=+ c #6E9C62",
"-+ c #FCFDFC",
";+ c #FEFEFE",
">+ c #B0B0B0",
",+ c #232323",
"'+ c #173D0C",
")+ c #E4EDE2",
"!+ c #454545",
"~+ c #0D0D0D",
"{+ c #256415",
"]+ c #8DB184",
"^+ c #DBDBDB",
"/+ c #A3A3A3",
"(+ c #3E5338",
". . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . ",
". . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . ",
". . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . ",
". . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . ",
". . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . ",
". . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . ",
". . . . . . . . . . . . + @ # $ % & . . . . . . . . . . . . . . ",
". . . . . . . . . . . * = - ; ; > , ' . . . . . . . . . . . . . ",
". . . . . . . . . . ) ; ; ; ; ! ~ { ] ^ . . . . . . . . . . . . ",
". . . . . . . . / ( ; ; ; ; _ : < [ } | 1 . . . . . . . . . . . ",
". . . . . . . . 2 3 4 5 6 7 8 9 9 0 a ; b . . . . . . . . . . . ",
". . . . . . . . c d e f g h 9 9 9 i j k l m . . . . . . . . . . ",
". . . . . . . n o p q r s 9 9 9 t u v w x y z A . . . . . . . . ",
". . . . . . B C D E F G 9 9 9 9 H ; I 9 J K L M N O . . . . . . ",
". . . . P Q ; ; R S T U V W X H ; ; Y Z 9 ` ; ; ; ; .... . . . ",
". . / +.C = @.N #.$.%.&.*.=.-.;.; ; 7 >.9 9 ,.; ; ; ; '.).. . . ",
". . !.~.{.. . . . . . ].^.9 9 /.; (._.9 :.<.[.; ; ; ; ; }.|.1.. ",
". . . . . . . . . . . . 2.3.9 4.; 5.6.7.8.; ; ; ; ; ; ; ; 9.0.a.",
". . . . . . . . . . . . . b.c.d.; e.; f.g.h.i.j.(.; ; ; ; ; ; ;.",
". . . . . . . . . . . . . l.m.; n.o.p.q.9 9 9 9 r.s.; ; ; ; ; ;.",
". . . . . . . . . . . . . u.v.w.>.x.y.z.A.>.9 9 9 B.C.8.D.E.F.!.",
". . . . . . . . . . . . . G.H.I.J.K.; ; ;.D.L.M.9 9 N.O.9 9 9 9 ",
". . . . . . . . . . . . . . P.Q.>.R.; ; ; ; ; S.T.J.9 9 9 9 9 9 ",
". . . . . . . . . . . . . . V.W.9 X.S.; ; ; ; ; ; V Y.9 9 9 9 9 ",
". . . . . . . . . . . . . . +.+9 9 ++; ; ; ; ; ; ; ; w.9 9 9 9 ",
". . . . . . . . . . . . . . . $+9 9 %+n.; ; ; ; ; ; ; ; &+. 9 9 ",
". . . . . . . . . . . . . . . . *+9 9 9 7.R ; ; ; ; ; ; ; ; ; ; ",
". . . . . . . . . . . . . . . . =+-+9 9 ;+>+,+; ; ; ; ; ; ; ; ; ",
". . . . . . . . . . . . . . . . +)+9 9 9 9 h.!+~+; ; ; ; ; ; ; ",
". . . . . . . . . . . . . . . . . ]+9 9 9 9 9 >.^+/+(+!.; ; ; ; ",
". . . . . . . . . . . . . . . . . . 9 9 9 9 9 9 >.^+/+(+!.; ; ; ",
". . . . . . . . . . . . . . . . .Discipulus as in perlmonks.org ",};
EOI
}
__DATA__