App-tkiv
view release on metacpan or search on metacpan
#!/pro/bin/perl
use strict;
use warnings;
unless ($^O eq "MSWin32") { # to_background
my $pid = fork;
if ($pid < 0) {
warn "Unable to run in the background, cannot fork: $!\n";
exit $?;
}
$pid and exit 0;
} # to_background
our $VERSION = eval q{use App::tkiv; $App::tkiv::VERSION};
my %Option = (
thumbsize => 80, # in pixels
thumbrows => 5,
thumbposition => "se",
thumbrefresh => 1,
thumbsorting => "default",
thumbsortorder => "ascending",
imageposition => "nw",
imagedir => ".",
slideshowdelay => 1500, # in milliseconds
slideposition => "c",
slidefull => 0,
slidecover => 0,
maxx => 9999,
maxy => 9999,
# smallfont => "-misc-fixed-medium-r-normal--7-70-75-75-c-50-iso10646-1",
smallfont => "{Liberation Mono} 8",
selectionfont => "{Liberation Sans} 5",
selectioncolor => "Yellow",
confirmdelete => 1,
removetarget => 0,
imagefull => 0,
decoration => 1,
showexifinfo => 0,
exifinfocolor => "Blue",
scrollspeed => 3,
titledirs => 0,
titleindex => 0,
lastfirstnext => 0,
dirtreestartpos => 0.,
keys_quit => [qw( Key-q Escape )],
keys_quit_all => [qw( Shift-q Control-q )],
keys_options => [qw( Key-o )],
keys_firstnext => [qw( Key-v )],
keys_firstprev => [qw( asciicircum )],
keys_firstpic => [qw( Key-0 Key-1 Key-a )],
keys_prevpic => [qw( Left Up BackSpace )],
keys_nextpic => [qw( Right Down space )],
keys_lastpic => [qw( Key-9 Key-z )],
keys_firstminimize => [qw( Alt-1 exclam Control-1 )],
keys_fullscreen => [qw( Key-f F11 )],
keys_fitwidth => [qw( Key-b )],
keys_fitheight => [qw( Key-h )],
keys_origsize => [qw( Key-o )],
keys_full_rc => [qw( Key-F )],
keys_full_toggle => [qw( Control-f )],
keys_rotleft => [qw( Key-l )],
keys_rotexifl => [qw( Key-L )],
keys_rotright => [qw( Key-r )],
keys_rotexifr => [qw( Key-R )],
keys_zoomin => [qw( plus )],
keys_zoomout => [qw( minus )],
keys_delete => [qw( Delete )],
keys_slideshow => [qw( Key-w Key-s )],
keys_exif => [qw( Key-i )],
keys_exifinfo => [qw( Shift-I )],
keys_decoration => [qw( Key-d )],
keys_focusthumbs => [qw( Key-t )],
keys_scroll_up => [qw( Alt-Up Control-Up )],
keys_scroll_down => [qw( Alt-Down Control-Down )],
keys_scroll_left => [qw( Alt-Left Control-Left )],
keys_scroll_right => [qw( Alt-Right Control-Right )],
keys_imgpos_nw => [qw( Alt-u )],
keys_imgpos_n => [qw( Alt-i )],
keys_imgpos_ne => [qw( Alt-o )],
keys_imgpos_e => [qw( Alt-l )],
keys_imgpos_se => [qw( Alt-period )],
keys_imgpos_s => [qw( Alt-comma )],
keys_imgpos_sw => [qw( Alt-m )],
keys_imgpos_w => [qw( Alt-j )],
keys_imgpos_c => [qw( Alt-k )],
keys_crop => [qw( Control-y )],
);
$w->bind ($_, sub { $sw->xview (scroll => $u, "units") }) for "<7>", @{$Option{keys_scroll_right}}, "<Alt-Button-5>", "<Control-Button-5>", "<Shift-Button-5>";
} # bind_wheel
my $pxyid = 10000;
sub Tk::PhotoXY {
my ($w, $f, $x, $y, $r, $p) = (@_, 0);
$f && $x && $y or return;
my ($cfh, $cfn) = tempfile ("iv#$$-XXXXXX", DIR => $tmp);
my ($rx, $ry) = $r == 90 || $r == 270 ? ($y, $x) : ($x, $y);
my $geo = "${rx}x${ry}";
my @rot = $r ? ("-rotate", $r) : ();
system "convert", "-size", $geo, "-resize", "$geo+0+0", @rot, $f, "$cfn.jpg";
# convert generates multiple files for animated images
my @cfn = glob "${cfn}*jpg*";
if (@cfn) {
eval { $p = $w->Photo (-file => $cfn[0]) };
unlink @cfn;
}
$p;
} # PhotoXY
my @rm_cfn;
END { -f $_ && unlink $_ for @rm_cfn; }
# Cropping version
sub Tk::PhotoXYXY {
my ($w, $f, $x, $y, $X, $Y, $p) = (@_, 0);
$f && $x && $y or return;
my ($cfh, $cfn) = tempfile ("iv#$$-XXXXXX", DIR => $tmp);
my ($dx, $dy) = ($X - $x, $Y - $y);
my $geo = "${dx}x$dy+$x+$y";
my $q = $f =~ m/'/ ? '"' : "'";
system qq{convert -crop $geo $q$f$q $cfn.jpg};
# convert generates multiple files for animated images
my @cfn = glob "${cfn}*jpg*";
if (@cfn) {
eval { $p = $w->Photo (-file => $cfn[0]) };
my $_fn = shift @cfn;
$selection{file} = $_fn;
push @rm_cfn, $_fn;
@cfn and unlink @cfn;
}
$p;
} # PhotoXYXY
sub show_exifinfo {
my $w = shift or return;
$w->delete ("exifinfo");
$Option{showexifinfo} or return;
my $ei = shift or return;
my $dto = $ei->{DateTimeOriginal} // "";
my $iso = $ei->{ISO} ? "ISO $ei->{ISO}" : "";
my $spd = $ei->{ShutterSpeed} // $ei->{exposureTime} // "";
my $ape = $ei->{Aperture} // $ei->{FNumber};
$ape = $ape ? "F$ape" : "";
my $fln = $ei->{FocalLengthIn35mmFormat} // $ei->{FocalLength} // "";
$w->createText (5, 5,
-anchor => "nw",
-fill => $Option{exifinfocolor},
-font => $Option{smallfont},
-text => join ("\x{00b7}", grep m/\S/, $dto, $iso, $ape, $spd, $fln),
-tags => "exifinfo",
);
if ($dto) {
my $awb = $ei->{WhiteBalance} // "";
my $fls = ($ei->{Flash} // $ei->{FlashFired} // "") =~
m/^(yes|true|on|fired|1)\b/i ? "With flash" : "No flash";
my $pgm = $ei->{ExposureProgram} //
$ei->{ShootingMode} //
$ei->{SceneMode} // "";
my $sct = $ei->{SceneType} // "";
$w->createText (5, 20,
-anchor => "nw",
-fill => $Option{exifinfocolor},
-font => $Option{smallfont},
-text => join ("\x{00b7}", grep m/\S/, $awb, $fls, $pgm, $sct),
-tags => "exifinfo",
);
$w->createText (5, 35,
-anchor => "nw",
-fill => $Option{exifinfocolor},
-font => $Option{smallfont},
-text => join ("\x{00b7}" =>
map { join " " => map { ucfirst lc $_ } split m/\s+/ => $_ }
grep m/\S/, map { $ei->{$_} // "" }
"Make", # Nikon
"Model", # Coolpix S9700
"DeviceType", # Cell Phone
"FileSource", # Digital Camera
),
-tags => "exifinfo",
);
}
} # show_exifinfo
sub show_exif {
my $exif = shift or return;
my $tl = $mw->Toplevel (-title => "Image EXIF info");
$ow = $tl->Scrolled ("Frame",
-scrollbars => "osoe",
-width => 650,
-height => int ($cy * .65))->pack (-expand => 1, -fill => "both");
$ow->Subwidget ("${_}scrollbar")->configure (-width => 6) for qw( x y );
my @exif = sort { lc $a cmp lc $b } keys %$exif;
my $half = int (@exif / 2);
foreach my $row (0 .. ($half - 1)) {
$ow->Label (
-text => $exif[$row],
-anchor => "w",
-fg => "DarkGreen",
-font => $Option{smallfont},
)->grid (-row => $row, -column => 0, -sticky => "news");
$ow->Label (
-text => $exif->{$exif[$row]},
-anchor => "w",
-fg => "DarkBlue",
-font => $Option{smallfont},
)->grid (-row => $row, -column => 1, -sticky => "news");
$row + $half > $#exif and last;
$ow->Label (
-text => $exif[$row + $half],
-anchor => "w",
-fg => "DarkGreen",
-font => $Option{smallfont},
)->grid (-row => $row, -column => 2, -sticky => "news");
$ow->Label (
-text => $exif->{$exif[$row + $half]},
-anchor => "w",
-fg => "DarkBlue",
-font => $Option{smallfont},
)->grid (-row => $row, -column => 3, -sticky => "news");
$row++;
}
# Destroy
foreach my $W ($ow, $tl) {
$W->bind ($_, sub {
if (Exists ($ow)) { $ow->destroy; $ow = undef; }
if (Exists ($tl)) { $tl->destroy; $tl = undef; }
}) for @{$Option{keys_quit}};
$W->bind ($_, \&exit) for @{$Option{keys_quit_all}};
}
} # show_exif
sub options {
my $tl = $mw->Toplevel (-title => "IV options");
$ow = $tl->Frame ()->grid (-sticky => "nsew");
$ow->gridRowconfigure (0, -weight => 1); # allow expansion in both ...
$ow->gridColumnconfigure (0, -weight => 1); # ... X and Y dimensions
my $row = 0;
for ([ "Thumb columns", \$tnx ],
[ "Thumb size", \$tpx ],
[ "Thumb sort method", \$Option{thumbsorting}, qw( default caseless date size random )],
[ "Thumb sort order", \$Option{thumbsortorder}, qw( ascending descending )],
[ "Image position", \$ip, @loc ],
[ "Remove symlink target", \$Option{removetarget} ],
[ "Slideshow", \$sls ],
[ "Slideshow delay", \$def_sls ],
[ "Slideshow position", \$sp, @loc ],
[ "Slideshow img size", \$Option{slidefull}, qw( 0 1 ) ],
[ "Slideshow full screen", \$Option{slidecover}, qw( 0 1 ) ],
) {
my ($label, $var, @val) = @$_;
$ow->Label (
-text => $label,
-anchor => "w",
-fg => "DarkGreen",
)->grid (-row => $row, -column => 0, -sticky => "news");
if (@val) {
my $cmd = sub { 1; };
my $be = $ow->BrowseEntry (
-width => 12,
-borderwidth => 1,
-highlightthickness => 1,
-listwidth => 40,
-variable => $var,
-browsecmd => $cmd,
)->grid (-row => $row, -column => 1, -sticky => "news");
$be->insert ("end", $_) for @val;
}
else {
$ow->Entry (
-textvariable => $var,
-width => 12,
)->grid (-row => $row, -column => 1, -sticky => "news");
}
$row++;
}
$ow->Button (-text => "OK", -fg => "DarkGreen",
-command => sub { $ow->destroy;
$ow = undef;
}
my $ttl = $pr->{phys}{titl};
$Option{titleindex} and $ttl .= " ".($ti + 1)."/$ni";
$iv = $mw->Toplevel (-title => $ttl);
$iv->geometry (loc ($sls ? $sp : $ip, $pr->{$size}{wdth}, $pr->{$size}{hght}));
my $fp = $iv->Canvas (
-width => $pr->{$size}{wdth},
-height => $pr->{$size}{hght},
# left, top, right, bottom
-scrollregion => [ 0, 0, $pr->{$size}{wdth}, $pr->{$size}{hght} ],
xscrollincrement => $Option{scrollspeed},
yscrollincrement => $Option{scrollspeed},
)->pack (@dpo);
$fp->createImage (0, 0, -anchor => "nw",
-image => $pr->{$size}{phot});
show_exifinfo ($fp, $pr->{exif});
# Check if this will always work ...
$fp->CanvasBind ($_, sub { $fp->yview (scroll => -5, "units") })
for "<4>", @{$Option{keys_scroll_up}};
$fp->CanvasBind ($_, sub { $fp->yview (scroll => 5, "units") })
for "<5>", @{$Option{keys_scroll_down}};
$fp->CanvasBind ($_, sub { $fp->xview (scroll => -5, "units") })
for "<Alt-Button-4>", @{$Option{keys_scroll_left}};
$fp->CanvasBind ($_, sub { $fp->xview (scroll => 5, "units") })
for "<Alt-Button-5>", @{$Option{keys_scroll_right}};
$fp->CanvasBind ("<ButtonPress-1>", sub {
my $e = $fp->XEvent or return;
my %ev = map { ( "S$_" => $e->$_ ) } "x", "y";
my $action = 0; # new
if ($selection{Sx} >= 0) {
# I already have a selection, check to see if it
# is being resized
abs ($ev{Sx} - $selection{Sx}) < 3 and $action |= 001;
abs ($ev{Sy} - $selection{Sy}) < 3 and $action |= 002;
abs ($ev{Sx} - $selection{Ex}) < 3 and $action |= 010;
abs ($ev{Sy} - $selection{Ey}) < 3 and $action |= 020;
}
$action or %selection = (%ev, Ex => $ev{Sx}, Ey => $ev{Sy});
$fp->CanvasBind ("<Motion>", sub {
my $m = $fp->XEvent or return;
my ($mx, $my) = ($m->x, $m->y);
$fp->delete ("selection");
$action == 0 and @selection{"Ex", "Ey"} = ($mx, $my);
$action & 001 and $selection{"Sx"} = $mx;
$action & 002 and $selection{"Sy"} = $my;
$action & 010 and $selection{"Ex"} = $mx;
$action & 020 and $selection{"Ey"} = $my;
my @x = sort { $a <=> $b } @selection{qw( Sx Ex )};
my @y = sort { $a <=> $b } @selection{qw( Sy Ey )};
my @s = ($x[1] - $x[0] + 1, $y[1] - $y[0] + 1);
$fp->createRectangle ($x[0], $y[0], $x[1], $y[1],
-outline => $Option{selectioncolor},
-tags => "selection");
$fp->createText ($x[0] + 2, $y[0] + 2,
-anchor => "nw",
-fill => $Option{selectioncolor},
-font => $Option{selectionfont},
-text => "$s[0]x$s[1]",
-tags => "selection",
);
});
});
$fp->CanvasBind ("<ButtonRelease-1>", sub {
if (exists $selection{Sx} and
abs ($selection{Sx} - $selection{Ex}) < 5 ||
abs ($selection{Sy} - $selection{Ey}) < 5) {
$fp->delete ("selection");
reset_selection ();
}
$fp->CanvasBind ("<Motion>", sub {});
});
# indicate this pic in the thumbview
$tn[$_]{wdgt}->configure (-bg => "Gray") for 0 .. $#tn;
$pr->{wdgt}->configure (-bg => "Black");
$fp->update;
ref $pr->{$size}{phot} eq "Tk::Animation" and
$pr->{$size}{phot}->start_animation ();#$pr->{exif}{Animated});
#$iv->focusForce;
$old_iv && Exists ($old_iv) and $old_iv->destroy;
my ($_pic, $_next_pic, $_next_firstnext, $_next_firstprev, $quit);
$_pic = sub {
@tn or return;
$ti = shift;
$sls and $aid = $mw->after ($sls, $_next_pic);
$f11->($vs);
}; # next_pic
$_next_pic = sub {
if ($aid) {
$aid->cancel;
$aid = undef;
}
$ti == $#tn
? $Option{lastfirstnext}
? $_next_firstnext->()
: $_pic->(0)
: $_pic->($ti + 1);
}; # next_pic
$_next_firstnext = sub {
$quit->();
$opt_1 = 2;
dirnext ();
};
$_next_firstprev = sub {
$quit->();
$opt_1 = 2;
dirprev ();
};
# Destroy
$dt->open ($up);
$dt->setmode ($up, "open");
$dt->open ($up);
$dt->xview (moveto => .60);
dtcmd ($up);
} # dirup
sub openupdir {
(my $up = $idir) =~ s:/[^/]+$:: or return;
$dt->chdir ($up);
$dt->open ($up);
$dt->chdir ($idir);
return ($dt->child_entries ($up, 1), $idir);
} # openupdir
sub dirnext {
(my $up = $idir) =~ s:/[^/]+$:: or return;
my @dir = openupdir ();
shift @dir while $dir[0] ne $idir;
@dir > 1 && $dir[0] ne $dir[1] or return;
$dt->close ($idir);
$dt->chdir ($up);
$dt->open ($up);
$dt->chdir ($up = $dir[1]);
$dt->open ($up);
$dt->xview (moveto => .60);
dtcmd ($up);
} # dirnext
sub dirprev {
(my $up = $idir) =~ s:/[^/]+$:: or return;
my @dir = reverse openupdir ();
push @dir, shift @dir;
shift @dir while $dir[0] ne $idir;
@dir > 1 && $dir[0] ne $dir[1] or return;
$dt->close ($idir);
$dt->chdir ($up);
$dt->open ($up);
$dt->chdir ($up = $dir[1]);
$dt->open ($up);
$dt->xview (moveto => .60);
dtcmd ($up);
} # dirprev
$dt->bind ($_, sub {
(my $up = $idir) =~ s:/[^/]+$:: or return;
$dt->open ($up);
$dt->chdir ($idir);
$dt->open ($idir);
$dt->xview (moveto => .60);
dtcmd ($idir);
}) for qw( <greater> );
my @fs = (-font => $Option{smallfont});
my @fsv = (@fs, -foreground => "Maroon");
my @fst = (@fs, -foreground => "Navy");
$df->Label (-textvariable => \$ti, @fsv)->pack (-side => "left");
$df->Label (-text => "#", @fst)->pack (-side => "left");
$df->Label (-textvariable => \$ni, @fsv)->pack (-side => "left");
$df->Label (-text => "T", @fst)->pack (-side => "left");
$df->Label (-textvariable => \$tr, @fsv)->pack (-side => "left");
$df->Label (-text => "O", @fst)->pack (-side => "left");
$df->Label (-textvariable => \$or, @fsv)->pack (-side => "left");
$df->Label (-text => "F", @fst)->pack (-side => "left");
$df->Label (-textvariable => \$fr, @fsv)->pack (-side => "left");
$df->Label (-text => "¤", @fst)->pack (-side => "left");
$df->Label (-textvariable => \$zs, @fsv)->pack (-side => "left");
$df->Label (-text => "*", @fst)->pack (-side => "left");
$df->Label (-textvariable => \$Option{decoration},
@fsv)->pack (-side => "left");
$tn = $mw->Scrolled ("Frame",
-width => $tnx * $tpx + 45,
-height => .65 * $cy,
-scrollbars => "osoe",
)->pack (-anchor => "nw", -side => "right", -expand => 0, -fill => "both");
$tn->Subwidget ("${_}scrollbar")->configure (-width => 6) for qw( x y );
$tg = $tn->Subwidget ("scrolled");
bind_wheel ($mw, $tn, 10);
$tg->gridRowconfigure (0, -weight => 1); # allow expansion in both ...
$tg->gridColumnconfigure (0, -weight => 1); # ... X and Y dimensions
$mw->geometry (loc ($tp, 200 + $tnx * $tpx + 45, .65 * $cy));
foreach my $W ($df, $dt, $tn, $tg, $mw) { # not $mw, would cause double starts
$W->bind ($_ => \&exit) for @{$Option{keys_quit}}, @{$Option{keys_quit_all}};
# First pic
$W->bind ($_, sub {
$f11 or return;
$ti = 0;
$f11->($vs);
}) for @{$Option{keys_firstpic}};
# Last pic
$W->bind ($_, sub {
$f11 or return;
$ti = $#tn;
$f11->($vs);
}) for @{$Option{keys_lastpic}};
# Start Slideshow
$W->bind ($_, sub {
$f11 or return;
$ti < 0 and $ti = 0;
$f11->($Option{slidefull}, $ti, "show");
}) for @{$Option{keys_slideshow}};
}
$mw->bind ($_, \&options) for @{$Option{keys_options}};
dtcmd ($dir);
$dt->update;
$dt->yview (moveto => $Option{dirtreestartpos});
#$dt->focusForce;
( run in 0.873 second using v1.01-cache-2.11-cpan-5735350b133 )