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 )],
);
sub usage {
my ($show_opt) = (@_, 0);
warn "usage: iv.pl [-f] [option=value ...] [dir]\n";
if ($show_opt) {
foreach my $o (sort keys %Option) {
my $v = $o =~ m/^keys_/
? "(".(join" ",@{$Option{$o}}).")"
: $Option{$o};
my $alt = {
imageposition => "\t\t(nw n ne e se s sw w c)",
slideposition => "\t\t(nw n ne e se s sw w c)",
thumbposition => "\t\t(nw n ne e se s sw w c)",
thumbsorting => "\t(default caseless date size random)",
thumbsortorder => "\t(ascending descending)",
}->{$o} || "";
printf STDERR " %-15s %s%s\n", $o, $v, $alt;
}
}
exit 0;
} # usage
# TODO: * save/load from .ivrc buttons on option window
# * Slideshow behaviour: location, dir depth, cycling
# randomness, slide lists, full screen background (no decoration)
# * Slideshow play list
# * Slideshow loop control
# * Image manipulation
# - Crop
# - Save, save as
# * Titles and decoration behaviour
# - adjust height/width of screen-fit images to decoration
# I just cannot get $iv->overrideredirect (1) to work as I want
# * Hide dirs above dt root
# - Allow a set of dirs from the command line
# * use Tk::Animation for animated gif's
# * Menu's ?
# * Auto-sense image load time for slideshows
# * Move onward to App::tkiv (with iv => tkiv link)
# Filter out the irfanview options that I don't support
@ARGV = grep { !m{^/(hide|thumbs?)(=\d+)?$} } @ARGV;
@ARGV == 1 and $ARGV[0] =~ m/^-[h?]$/ and usage (0);
@ARGV == 1 and $ARGV[0] =~ m/^-+(help|info)$/ and usage (1);
use Getopt::Long qw(:config bundling nopermute passthrough);
my $opt_f = 0; # Start with full-screen pics
my $opt_v = 0; # Verbosity / debug
my $opt_s = 0; # Start slideshow immediately
my $opt_1 = 0; # On startup, select first image and minimize thumbnail view
GetOptions (
"v:1" => \$opt_v,
"f" => \$opt_f,
"s" => \$opt_s,
"1" => \$opt_1,
) or usage (0);
use Cwd qw( realpath );
use Tk;
use Tk::JPEG;
use Tk::PNG;
eval "use Tk::TIFF;";
use Tk::Bitmap;
use Tk::Pixmap;
use Tk::Photo;
use Tk::Pane;
use Tk::DirTree;
use Tk::Dialog;
use Tk::Balloon;
use Tk::BrowseEntry;
use Tk::Animation;
use File::Temp qw( tempdir tempfile );
use File::Copy;
#use Data::Peek;
# Time to fetch image dimensions for 3500 images
our $exiftool = 0; # 26.5
our $iinftool = 0; # 4.5
our $imsztool = 0; # 0.2
our $exiftran = 0;
eval {
require Image::ExifTool;
Image::ExifTool->import ("ImageInfo");
$exiftool = Image::ExifTool->new ();
};
-command => sub { $ow->destroy;
$ow = undef;
$tl->destroy;
dtcmd ($idir);
},
)->grid (-row => $row, -column => 0, -sticky => "news");
$ow->Button (-text => "Apply", -fg => "DarkGreen",
-command => sub { dtcmd ($idir); },
)->grid (-row => $row, -column => 1, -sticky => "news");
} # options
my %tsort = (
# [ Name, seq, size, mtime, lc name ]
# 1. numeric part of image name, 2. image name
default => sub { $a->[1] <=> $b->[1] || $a->[0] cmp $b->[0] },
# 2. size
size => sub { $a->[2] <=> $b->[2] },
# 3. date
date => sub { $a->[3] <=> $b->[3] },
# 4. caseless image name
caseless => sub { $a->[4] cmp $b->[4] },
# 5. random
random => sub { $a->[5] <=> $b->[5] },
);
my $refreshing = "";
sub dtcmd {
# trigger $tn to show thumbnails of all pics in current dir
# Expansion also invokes this callback
@_ == 1 or return;
$idir = $_[0] or return ($refreshing = "");
my $Idir = realpath $idir;
#warn "dtcmd (idir = $idir ($Idir))\n";
$refreshing eq $Idir and return;
$refreshing = $Idir;
# Clean up previous pics
$iv && Exists ($iv) and $iv->destroy;
$bg && Exists ($bg) and $bg->destroy;
for (@tn) {
$_ && ref $_ && $_->{wdgt} && Exists ($_->{wdgt}) and
$_->{wdgt}->destroy ();
}
# New dir, reset globals
($tr, $or, $fr, $ti, $vs, $sls, $zs, $f11, @tn) = (0, 0, 0, -1, $opt_f, 0);
(my $ttl = $Idir) =~ s{^$ENV{HOME}}{~};
$ttl =~ s{^~/\.wine/fake_windows/}{:};
utf8::upgrade ($ttl);
$mw->title ($ttl);
my $tb = $tg->Balloon (
-state => "balloon",
-initwait => 1200, # 1.2 ms
-foreground => "Blue4",
-background => "LightYellow2",
);
# Gather all pics in this folder
opendir IDIR, $Idir;
my @img = map { $_->[0] }
sort { $tsort{$Option{thumbsorting}}->() }
map { my $seq = m/(\d+)/ ? $1 : 0;
[ $_, $seq, (stat "$Idir/$_")[7,9], lc $_, rand 1 ] }
grep { my $if = "$Idir/$_";
# Sanity check. Minimal image size 100
my $s = -s $if;
# Skip MacOS working copies
$if =~ s{/\._([^/]+)$}{/$1} && -s $if and $s = 0;
$s and $s > 100;
}
# convert can't deal with .ico files (yet)
# Tk can deal with Tiff/NEF as of 804.027_501 with Tk::TIFF
grep m/\.(jpe?g|gif|x[pb]m|png|bmp|tiff?|nef)$/i => readdir IDIR;
closedir IDIR;
$Option{thumbsortorder} =~ m/^(?:desc|reverse)/ and @img = reverse @img;
#my $t0 = [ gettimeofday ];
my $earlyopennextdir = $Option{lastfirstnext} || $opt_1;
if ($earlyopennextdir && opendir my $dh, "..") {
my @dir = readdir $dh;
@dir > 100 and $earlyopennextdir = 0; # too slow
}
$ni = @img;
$opt_v and warn "$ni images in $idir\n";
foreach my $img (@img) {
my $nt = @tn;
my $pf = "$Idir/$img";
my $ps = -s $pf or next;
$opt_v and warn "Read $pf ($ps) ...\n";
# Read it
my ($exif, $angl, $x, $y, $o) = ({}, 0, 0, 0);
if ($exiftool) {
$exif = ImageInfo ($pf);
#DDumper $exif;
if (ref $exif and exists $exif->{ImageWidth}) {
($x, $y) = ($exif->{ImageWidth}, $exif->{ImageHeight});
my $ori = $exif->{Orientation} || "Horizontal";
delete $exif->{$_} for qw( ThumbnailImage PreviewImage DataDump );
$ori =~ m/\b(-?\d+)\b/ and $angl = $1;
$angl < 0 and $angl += 360;
$exif->{Animated} = 0;
if ($exif->{FileType} eq "GIF" && $iinftool) {
my $info = image_info ($pf);
$exif->{Animated} = $info->{Delay} || 0;
}
}
}
if ($x == 0 and $imsztool) {
my ($w, $h) = imgsize ($pf);
$w and ($x, $y) = ($w, $h);
}
if ($x == 0 and $iinftool) {
( run in 0.481 second using v1.01-cache-2.11-cpan-f56aa216473 )