mapivi.pl 0000775 0000000 0000000 00005551516 13007661042 011424 0 ustar root root #!/usr/bin/perl
# the line above could be the first line for a typical UNIX systems
# you can find perl on your system by using "which perl" in the shell
# to build an exectuable for windows use this PAR call:
# pp -M Tk::DragDrop::Win32Site -o mapivi.exe mapivi.pl
# to build an exectuable for Linux use this PAR call:
# pp -M Tk::DragDrop::XDNDSite -M Tk::DragDrop::SunSite -M PerlIO -M Image::Info -o mapivi.out mapivi.pl
# to check the code against Perl coding standards
# install Perl::Critic module
# execute: "perlcritic -5 mapivi.pl" or: "perlcritic -4 -profile test/perlcriticrc mapivi.pl"
# instead of -5 (list only most severe warnings) you may also use -4, -3, -2, or -1 (list all warnings), see also "perldoc Perl::Critic" or "perlcritic -man"
# include perl packages
use strict;
use Encode::Unicode; # needed according to the PAR FAQ (for perl apps on Microsoft Windows)
use warnings;
#use diagnostics;
# pod (to view the formated document try "perldoc mapivi" in the shell
=head1 NAME
Mapivi - Picture Viewer and Organizer
Mapivi means Martin's Picture Viewer
=head1 DESCRIPTION
JPEG picture viewer / image management system with meta info support
written in Perl/Tk for UNIX, Mac OS X and Windows.
I wrote mapivi just for me, because I needed a image viewer which is
also able to display and edit meta infos of JPEG pictures, like EXIF,
JPEG comments and IPTC/IIM infos.
As hobby photographer I am mostly interested in the EXIF infos (like timestamp,
camera model, focal length, exposure time, aperture, etc.) and the
possibility to add and edit IPTC infos and JPEG comments.
But I also want to rename pictures according to their internal date/time
and to do lossless rotation, lossless cropping and other stuff.
mapivi can be found here:
http://mapivi.de.vu (link to the mapivi site)
or if this won't work:
http://herrmanns-stern.de (real site)
http://sourceforge.net/projects/mapivi (download)
I would be happy to receive some feedback (e.g. on which os mapivi
works), bugfixes, patches or suggestions about mapivi.
Copyright (c) 2002 - 2016 Martin Herrmann
All rights reserved.
Feel free to redistribute. Enjoy!
=head1 USAGE
mapivi [-i ] [file|folder]
to display a certain picture use:
mapivi picture.jpg
mapivi will generate and display all pictures in the folder
as thumbnails. The given picture will be displayed in
original size or zoomed to fit the window (picture frame).
to view a folder containing pictures use:
mapivi ~/pics/
mapivi will generate and display all pictures in the given folder
as thumbnails.
to start mapivi with the import wizard
mapivi -i
=head1 KEYS
mapivi is controlled by the following keys:
see also menu Help->Keys (the list is generated from the source
code and is always actual.)
=over 4
=item Space, Page-Down
Show the next picture in folder
=item BackSpace, Page-Up
Show the previous picture in folder
=item Escape
Iconify Mapivi (Boss-Key :)
=item Cursor-up, -down, -left, -right
Scroll the picture, if it's bigger than the Canvas
=item Shift-Cursor-up, -down, -left, -right
Move to the border of the picture, if it's bigger than the Canvas
=item q
Quit Mapivi
For all other key bindings, see the menu Help->Keys
=back
=head1 MOUSE
Try the right mouse button in the thumbnail picture list for a popup menu to copy, move, rename, rotate or delete pictures, to open a new folder, to add or remove comments or to exit Mapivi.
Use the buttons to add, edit or remove JPG comments, or to display all EXIF infos.
If you hold the mouse over the buttons or labels a help message will pop up (or at least at most of them :).
=cut
##############################################################
# load basic modules
use Env;
use File::Spec;
# determine full path to mapivi script or executable, should be done before e.g. a chdir() takes place
my $mapivi_file = File::Spec->rel2abs($0);
# boolean, if we run on Windows this variable is set to 1
my $EvilOS = 0; $EvilOS = 1 if ($^O =~ m/win/i);
my $MacOSX = 0; # boolean, if we run on Mac OS X this is 1
if ($^O =~ m/darwin/i) { # Mac OS X is not evil, but unfortunately contains the string "win"!
$MacOSX = 1;
$EvilOS = 0;
}
my $home = get_home_path();
die lang('Mapivi can not find a home directory') if (!-d $home);
# this path is used for user specific data, like the search database, the keyword tree, the configuration, trash, etc.
my $user_data_path = get_user_data_path($home);
my $conf_file = "$user_data_path/mapivi_conf"; # the configuration file
my $configFile = "$user_data_path/mapivirc"; # the old configuration file
my $trashdir = "$user_data_path/trash"; # the Mapivi trashcan
my $iptcdir = "$user_data_path/IPTC_templates"; # the IPTC templates folder
my $plugin_user_path = "$user_data_path/PlugIns"; # the mapivi plugin user dir
my $file_Entry_values = "$user_data_path/Entry_values"; # needed to store completions for Tk::MatchEntry
my $thumbDB = "$user_data_path/thumbDB"; # path to thumbnail database (when thumbnails are stored in a central place)
my $searchDBfile = "$user_data_path/SearchDataBase"; # path to the search database file
my $collectionsFile = "$user_data_path/slideshows"; # path to picture collections/slideshows file
# this path is used for Mapivi icons, languages, plugins, html templates etc.
# for Debian and Ubuntu we use /usr/share/mapivi, other UNIX distributions may need other paths
my $program_data_path = '/usr/share/mapivi';
if ($EvilOS) { # in Windows we store the programm data in the same folder as mapivi
$program_data_path = dirname($mapivi_file);
$program_data_path =~ s!\\!\/!g; # replace Windows path delimiter with UNIX style \ -> /
}
my $icon_path = "$program_data_path/icons"; # the icon dir
my $thumbExample = "$icon_path/EmptyThumb.jpg";
my $lang_path = "$program_data_path/languages"; # the localization / languages dir
my $plugin_sys_path = "$program_data_path/PlugIns"; # the mapivi plugin system dir
my $logo = "$program_data_path/pics/logo.jpg";
my $exifdirname = ".exif"; # the subdir to store exif infos
my $thumbdirname = ".thumbs"; # the subdir to store thumbnails
my $xvpicsdirname = ".xvpics"; # a subdir from GIMP we usualy ignore
##############################################################
# load optional module (as soon as possible)
my $splashAvail = (eval {require Tk::Splash}) ? 1 : 0 ;
my $splash;
if ($splashAvail and -f $logo) {
# Splash->Show parameters: $image, $width, $height, $title, $overrideredirect
$splash = Tk::Splash->Show($logo, undef, undef, '', 1);
}
##############################################################
# load modules
use File::Basename;
use POSIX qw(ceil);
use Cwd qw(cwd abs_path);
my $verbose = 0; # boolean (1 = print debug infos, 0 = be quiet)
# set version
my $version = '1.2';
# get version and date from subversion (SVN)
# this works only if you enable subversion's keyword substitution on your machine for this file:
# svn propset svn:keywords "Rev Date" mapivi.pl
my @svnversion = split / /, '$Rev: 356 $';
my $svnrevision = '';
$svnrevision = "($svnversion[1])" if defined $svnversion[1];
my @svndate = split / /, '$Date: 2016-11-06 18:02:25 +0100 (So, 06. Nov 2016) $';
my $version_date = '2012-03-23';
$version_date = $svndate[1] if defined $svndate[1];
$main::VERSION = $version;
my $mapiviURL = "http://mapivi.de.vu";
my $mapiviInfo = "mapivi";
showCopyright();
##############################################################
# load modules
#use Encode qw(is_utf8 encode decode);
use Encode;
#use encoding "utf8"
#use utf8;
use Getopt::Std;
our($opt_i, $opt_v);
$Getopt::Std::STANDARD_HELP_VERSION = 1;
use File::Copy;
use File::Find;
use File::Path; # for rmtree, mkpath
use Text::Wrap;
use List::Util qw/max min/; # core module since Perl 5.8.0
use Tk 800.025; # minimum version >= 800.025
use Tk::JPEG;
use Tk::PNG;
use Tk::HList;
use Tk::ItemStyle;
use Tk::ROText;
use Tk::ProgressBar;
use Tk::IO;
use Tk::ErrorDialog;
use Tk::Balloon;
use Tk::DirTree;
use Tk::Font;
use Tk::Pane;
use Tk::Tiler;
use Tk::NoteBook;
use Tk::FileSelect;
use Storable qw(nstore retrieve dclone);
use Tk::Adjuster;
use Tk::DragDrop;
use Tk::DropSite;
use Tk::Compound; # for icons in the menues
use MIME::Base64; # for get_encode_file(); a workaround for Tk::Photo which can't handle non-ASCII characters
# for debugging
# use Data::Dumper; # and then in the code e.g. print Dumper(\%conf);
##############################################################
# load mapivi specific modules
# the mapivi specific modules may be located in the same dir as mapivi itself, so we add this path to @INC
use FindBin;
use lib "$FindBin::RealBin";
# load mapivi specific modules
use Tk::MhConfig qw(configuration_edit configuration_store configuration_restore);
# this will be used in future to provide a multilanguage mapivi
# keywords: i18n, gettext
#use Locale::TextDomain ('mapivi', $user_data_path."/locale");
#use POSIX qw(locale_h);
#setlocale (LC_MESSAGES, '');
##############################################################
# load non standard modules, they may be located below the mapivi program folder
use Image::ExifTool;
use Image::Info qw(image_info dim);
use Image::MetaData::JPEG;
# disable warnings from this module
$Image::MetaData::JPEG::show_warnings = 0; # todo: use metadatawarn to switch this
my $metadataVersionNeeded = 0.14;
my $metadataVersion = $Image::MetaData::JPEG::VERSION;
$metadataVersion =~ s/[a-zA-Z]//g;
die langf("Aborting, because Mapivi needs at least version $metadataVersionNeeded of perl module Image::MetaData::JPEG!\n(installed version: $metadataVersion)\n") if ($metadataVersion < $metadataVersionNeeded);
use Time::Local; # timelocal()
#use Tk::Date; # not in the Tk distro
# This should prevent opening DOS boxes on windows when doing background tasks, but does not work. ToDo
#my $win32Avail = (eval "require Win32") ? 1 : 0;
#SetChildShowWindow() if ($EvilOS and $win32Avail);
##############################################################
# load optional modules
# seems not to work so I comment it out for a future test
#my $win32FOAvail = (eval "require Win32::FileOp") ? 1 : 0;
my $win32FOAvail = 0;
my $resizeAvail = (eval {require Tk::ResizeButton}) ? 1 : 0;
use constant Win32ProcAvail => eval { require Win32::Process; 1 };
#use constant Win32DriveInfoAvail => eval { require Win32::DriveInfo; 1 };
use constant MatchEntryAvail => eval { require Tk::MatchEntry; 1 };
use constant ProcBackgroundAvail => eval { require Proc::Background; 1 };
# 2009-12-22: the next lines may be used to enable the Gtk2 FileChooserDialog
# this works in a small example, but here mapivi dies with a X Window System error
#my $gtk2_avail = (eval {require Gtk2}) ? 1 : 0 ;
my $gtk2_avail = 0;
Gtk2->init if ($gtk2_avail);
#use Time::HiRes qw(gettimeofday tv_interval); # needed just for debugging/optimizing
#my $hiresstart;
##############################################################
# constants
use constant WITH_PATH => 1;
use constant JUST_FILE => 0;
use constant LONG => 1;
use constant SHORT => 0;
use constant MICRO => 2;
use constant WRAP => 1;
use constant NO_WRAP => 0;
use constant FORMAT => 1;
use constant NO_FORMAT => 0;
use constant NUMERIC => 1;
use constant STRING => 0;
use constant WAIT => 1;
use constant NO_WAIT => 0;
use constant TOUCH => 1;
use constant NO_TOUCH => 0;
use constant OVERWRITE => 1;
use constant OVERWRITEALL => 2;
use constant ASK_OVERWRITE => 0;
use constant ASK => 1;
use constant NO_ASK => 0;
use constant PREVIEW => 1;
use constant NO_PREVIEW => 0;
use constant SHOW => 1;
use constant NO_SHOW => 0;
use constant COPY => 0;
use constant MOVE => 1;
use constant RENAME => 2;
use constant BACKUP => 3;
use constant TRASH => 0;
use constant REMOVE => 1;
use constant OK => 1;
use constant CANCEL => 0;
use constant CANCELALL => -1;
use constant ADD => 1;
use constant RESET => 0;
use constant PIXEL => 0;
use constant ASPECT_RATIO => 1;
use constant RELATIVE => 2;
use constant SINGLE => 0;
use constant MULTIPLE => 1;
use constant UPDATE => 1;
use constant FOLDER => 0; # value for $act_modus
use constant LOCATION => 1; # value for $act_modus
use constant DATE => 2; # value for $act_modus
use constant KEYWORDCLOUD => 3; # value for $act_modus
use constant KEYWORD => 4; # value for $act_modus
use constant SEARCH => 5; # value for $act_modus
use constant COLLECTION => 6; # value for $act_modus
use constant NO_CHECK_JPEG => 0;
use constant CHECK_JPEG => 1;
use constant OPEN => 1; # tree collapse (fold)
use constant CLOSE => 0; # tree unfold
use constant FLAG_RESET => 0b00000000;
use constant FLAG_RED => 0b00000001;
use constant FLAG_GREEN => 0b00000010;
use constant FLAG_BLUE => 0b00000100;
use constant START => 0;
use constant SETTINGS => 1;
use constant FIT => 0; # pic zoom
use constant FILL => 1; # pic zoom
use constant NORMAL => 0; # window size
use constant FULLSCREEN => 1; # window fullscreen
##############################################################
# globals (yes, I know there are to many globals, I'm working on it ...)
my @dirHist; # folder history - stores the last folders visited
my @cachedPics; # a list of all cached pictures
my @savedselection;
my @savedselection2;
# search database: hash to store all the data of all pictures in the visited folders (comments, EXIF, IPTC)
my %searchDB;
# location hash, will be filled on demand and should only be accessed from function get_locations
my %locations;
# flag indicating that the %locations hash needs to be filled (updated) from the %searchDB
my $locations_need_update = 1;
# date/time hash, will be filled on demand and should only be accessed from function get_dates
my %dates;
# flag indicating that the %dates hash needs to be filled (updated) from the %searchDB
my $dates_need_update = 1;
# folder checklist: hash to store properties of folders (key: dir value: hash SORT, META, PRIO, COMM)
my %dirProperties;
# hash to store all loaded photo objects (real size or zoomed) key = path/file name, value = photo object
my %photos;
# hash to store all loaded thumbnail photo objects key = path/file name, value = photo object
my %thumbs;
my %searchthumbs;# hash containing all thumbnails of the search dialog, for memory clean up
my %thumbDBhash; # store the thumb dirs for one session: dir -> thumbdir
my %dirHotlist; # often visited dirs
# minimum set of the hot dirs
foreach my $dir ("/", $home, cwd()) {
$dirHotlist{$dir} = 1 unless (defined $dirHotlist{$dir});
}
# hash of all slideshows
# is stored on exit and retrieved on start
# A slideshow (collection, album) is a manual sorted list of pictures,
# like a music playlist
# Perl data structure: hash of hash of scalars and lists (HoHoL :)
# key1=Folder, key2=Slideshow key3=file, picturelist,
my %slideshows = (
'Vacation' => {
'2013-Paris' => {
'file' => 'C:/_data/Bilder/temp/slideshow-paris.gqv',
'pics' => ['C:/_data/Bilder/test/a.png', 'C:/_data/Bilder/test/b.png', 'C:/_data/Bilder/test/c.jpg', 'C:/_data/Bilder/test/d.jpg'],
},
'2014-Berlin' => {
'file' => undef,
'pics' => ['C:/_data/Bilder/test/a.png', 'C:/_data/Bilder/test/b.png', 'C:/_data/Bilder/test/c.jpg', 'C:/_data/Bilder/test/d.jpg'],
},
},
'Family' => {
'Simpsons' => {
'file' => 'C:/_data/Bilder/temp/slideshowSimpson.gqv',
'pics' => ['C:/_data/Bilder/test/a.png', 'C:/_data/Bilder/test/b.png', 'C:/_data/Bilder/test/c.jpg', 'C:/_data/Bilder/test/d.jpg'],
},
'Einsteins' => {
'file' => 'C:/_data/Bilder/temp/slideshow-OneStone.gqv',
'pics' => ['C:/_data/Bilder/test/a.png', 'C:/_data/Bilder/test/b.png', 'C:/_data/Bilder/test/c.jpg', 'C:/_data/Bilder/test/d.jpg'],
},
},
'BestOf' => {
'2014' => {
'file' => 'C:/_data/Bilder/temp/slideshowSimpson.gqv',
'pics' => ['C:/_data/Bilder/test/a.png', 'C:/_data/Bilder/test/b.png', 'C:/_data/Bilder/test/c.jpg', 'C:/_data/Bilder/test/d.jpg'],
},
},
'Other' => { },
);
# hash of hash example
#my %modules = (
#'Carp' => { 'version' => $Carp::VERSION,
# 'license' => 'Perl Artistic License or GNU GPL' },
#'File::Basename' => { 'version' => $File::Basename::VERSION,
my %quickSortHash;
my %quickSortHashSize;
my %quickSortHashPixel;
my %quickSortHashBitsPixel;
my $quickSortSwitch = 0;
my $actpic = ''; # the path and file name of the actual picture
my $act_modus = FOLDER; # FOLDER, LOCATION, DATE, KEYWORDCLOUD, KEYWORD, SEARCH or COLLECTION
my $actdir = ''; # the actual folder - valid if $act_modus == FOLDER
my @act_location = (); # the actual location (Country, Privince/State, City, Sublocation) - valid if $act_modus == LOCATION
my @act_date = (); # the actual location (Year, Month, Day, Hour, Minute) - valid if $act_modus == DATE
my @act_keywords = (); # the actual keywords (any number) - valid if $act_modus == KEYWORDCLOUD
my @act_keywords_ex = (); # the actual exclude keywords (any number) - valid if $act_modus == KEYWORDCLOUD
my @act_collection = (); # the actual collection (folder and name of %slideshows) - valid if $act_modus == COLLECTION; todo: hierarchy still unclear
my $widthheight = '';
my $loadtime = '';
my $size = '';
my $zoomFactorStr = '';
my $nrof = '';
my $userinfo = '';
my $otherFiles = '';
my $proccount = 0;
my $nrToConvert = 0;
my $maxCommentLength = 2**16 - 3; # a comment block may have max 64kB
my $global_log = "Mapivi $version log file:";
# file suffixes
my @video_suffix = qw(.avi .mp4 .mpg .mpeg .mov);
my @xmp_suffix = qw(.XMP);
my @wav_suffix = qw(.WAV);
my @raw_suffix = qw(.NEF .CRW .CR2 .DNG .NRW); # update also sub getPics()!!
my @raw_suffix_lc; # lower case raw suffixes
push @raw_suffix_lc, lc($_) foreach (@raw_suffix);
# picture formats supported by Tk::Photo (standard Tk distribution)
# xbm works, but takes ages (who needs xbm???) and tiff doesn't work
# xcf works for thumbs, but makes problems with layers
my $nonJPEGsuffixes = "gif|png|xpm|bmp";
my $cameraJunkSuffixes = "ctg"; # uninteresting files created by cameras
my $copyright_year = (localtime(time()))[5] + 1900; # the actual year, for the copyright notice
my $HTMLPicDir = "pics"; # this is the name of the subdir for pics when building html pages
my $HTMLThumbDir = "thumbs"; # this is the name of the subdir for thumbs when building HTML pages
my $slideshow = 0; # start/stop flag for slideshow
my $showPicInAction = 0; # bool = 1 while loading picture
my %winapps; # used for sub findApp()
my $clocktimer;
my $time; # used to show the clock or memory usage in the top bar
my $date; # the date is shown as balloon info
my $clockL; # clock/memory label widget
my $scsw;
my $wizW;
my $impW;
my $interpW;
my $fuzzybw; # fuzzy border dialod window
my $ll_b_w; # lossless border dialog window
my $ll_r_w; # lossless relative border dialog window
my $ll_a_w; # lossless aspect ratio border dialog window
my $ll_w_w; # lossless drop picture (watermark) dialog window
my $bpw; # border preview window
my $indexW; # montage /index print dialog window
my $passportW; # passport print dialog window
my $ow; # options window, see sub options()
my $sw; # the search window, see searchMetaInfo()
my $dpw; # the dir properties window, see showDirProperties()
my $dsw; # the dir size window
my $ltw; # the light table window for slideshows
my $ddw; # dirDiffWindow widget
my $catw; # the IPTC categories window, see editIPTCCategories()
my $locw; # the location window, see search_by_location()
my $keycw; # the comment keywords window, see editCommentKeywords()
my $dupw; # the duplicate search window, see sub finddups()
my $filterW; # the filter window
my $menubar; # handle for menubar of main window
my $balloon; # balloon handle
my $dirMenu; # context menu for dirs
my $thumbMenu; # context menu for thumbnails
my $picMenu; # context menu for picture
my $copyCommentSource; # global variable of sub copyComment()
my ($idx, $idy); # coordinates of actual item when clicked on or moved
my ($width, $height);
my %nonJPEGdirNoAskAgain; # hash to store the dirs with non-JPEG files not to convert (valid for one session)
my $cleanDirNoAsk = 0; # needed in sub cleanDir()
my $cleanDirLevel = 0; # needed in sub cleanDir()
#my $loc_search = 1; # location window: search or add location on double click
# some example hierarchical categories
my @precats = sort qw(Nature Nature/Flower Nature/Landscape Nature/Macro Nature/Animal Nature/Animal/Fish Nature/Animal/Cat Nature/Animal/Insect Nature/Animal/Insect/Ant People People/Portrait People/Wedding Architecture Architecture/Tower Architecture/Bridge Architecture/Church Technology Technology/Car Technology/Train Technology/Computer);
# overwrite them, when some stored categories are available
@precats = readArrayFromFile("$user_data_path/categories") if (-f "$user_data_path/categories");
uniqueArray(\@precats); # remove double entries
foreach (@precats) { $_ =~ s|^/||; } # cut leading slash
@precats = qw(Nature) unless (@precats); # add a starting point if array is empty
# some example hierarchical keywords
my @prekeys = qw(Family Family/Einstein Family/Einstein/Albert Family/Einstein/Hermann Family/Einstein/Pauline Family/Planck Family/Planck/Max Family/Planck/Johann Family/Planck/Marie Family/Planck/Karl Family/Planck/Grete Family/Planck/Emma Family/Planck/Erwin Family/Planck/Hermann Friend Friend/Bundy Friend/Bundy/Al Friend/Bundy/Bud Friend/Bundy/Kelly Friend/Bundy/Peggy);
# overwrite them, when some stored keywords are available
@prekeys = readArrayFromFile("$user_data_path/keywords") if (-f "$user_data_path/keywords");
uniqueArray(\@prekeys); # remove double entries
foreach (@prekeys) { $_ =~ s|^/||; } # cut leading slash
@prekeys = qw(Family) unless (@prekeys); # add a starting point if array is empty
# global hash for new keywords found in displayed pictures
my %new_keywords;
# global hash to store keywords, which should be ignored (e.g. nature.animal.dog)
my %ignore_keywords;
# hot keywords, list of keywords which are often used, maintained by the user
my %hot_keywords = ('Family/Einstein/Pauline' => 1, 'Family/Planck/Max' => 1, 'Family/Planck/Johann' => 1);
# try to get the saved hot keywords
if (-f "$user_data_path/keywords_hot") {
my $hashRef = retrieve("$user_data_path/keywords_hot");
warn langf("could not retrieve %s",'keywords_hot') unless defined $hashRef;
%hot_keywords = %{$hashRef};
}
# add mapivi program path to PATH
# this allows to locate external programs like jpegtran in the mapivi folder
# which makes packaging easier
$ENV{PATH} .= ";$FindBin::Bin";
# external programs used by mapivi
my %exprogs = qw/convert 0 composite 0 jhead 0 jpegtran 0 mogrify 0 montage 0 xwd 0 identify 0 thunderbird 0 mozilla-thunderbird 0 exiftool 0/;
# short comment about the usage of the external programs
my %exprogscom = (
'convert' => lang('Build thumbnails'),
'composite' => lang('Combine pictures e.g. thumbnails with a background'),
'jhead' => lang('Handle EXIF infos and embedded thumbnail pictures'),
'jpegtran' => lang('Do lossless rotation of pictures'),
'mogrify' => lang('Change the size/quality of pictures'),
'montage' => lang("Combine pictures to e.g. index prints"),
'xwd' => lang("Make a screenshot of a window or desktop"),
'identify' => lang("Describe the format and characteristics of a picture"),
'thunderbird' => lang("Send pictures via email"),
'mozilla-thunderbird' => lang("Send pictures via email"),
'exiftool' => lang("Read/write meta information in image files"),
);
# where to find the external programs (resources)
my %exprogsres = (
"convert" => "Image Magick http://www.imagemagick.org",
"composite" => "Image Magick http://www.imagemagick.org",
"jhead" => "http://www.sentex.net/~mwandel/jhead/",
"jpegtran" => "libjpeg http://www.ijg.org",
"mogrify" => "Image Magick http://www.imagemagick.org",
"montage" => "Image Magick http://www.imagemagick.org",
"identify" => "Image Magick http://www.imagemagick.org",
"thunderbird" => "http://www.mozilla.org/projects/thunderbird/",
"mozilla-thunderbird" => "http://www.mozilla.org/projects/thunderbird/",
"exiftool" => "http://owl.phy.queensu.ca/~phil/exiftool/",
);
# hash to replace (german) umlaute by corresponding letters
my %umlaute = qw(ä ae Ä Ae ö oe Ö Oe ü ue Ü Ue ß ss);
my $umlaute = join '', keys(%umlaute);
# stolen from Image::ExifTool (thanks to Phil Harvey)
my %iptcCharset = (
"\x1b%G" => 'UTF8',
# don't translate these (at least until we handle ISO 2022 shift codes)
# because the sets are only designated and not invoked
# "\x1b,A" => 'Latin', # G0 = ISO 8859-1 (similar to Latin1, but codes 0x80-0x9f are missing)
# "\x1b-A" => 'Latin', # G1 "
# "\x1b.A" => 'Latin', # G2
# "\x1b/A" => 'Latin', # G3
);
# hash to replace (german) umlaute by corresponding HTML-tags
my %umlauteHTML = qw(ä ä Ä Ä ö ö Ö Ö ü ü Ü Ü ß ß);
my $umlauteHTML = join '', keys(%umlauteHTML);
# hash to escape special HTML characters
my %htmlChars = (
"<" => "<",
">" => ">",
"&" => "&",
"\"" => """,
"'" => "'",
);
my $htmlChars = join '', keys(%htmlChars);
# mapivi configuration hash / tool options
my %conf;
my @conf_tab_order; # defines the order of the tabs in the configuration_edit dialog
configuration_set_default();
# preset for channel mixer for black and white conversion
# hash of lists HoL; list is red, green , blue = RGB
my %channel_mixer = (
'Filter Yellow' => [30, 70, 20],
'Filter Orange' => [78, 22, 0],
'Filter Red' => [75, 0, 25],
'Filter Red II' => [150,-25,-25],
'Filter Red 25a' => [200, 0,-100],
'Filter Green' => [20, 60, 40],
'Normal 1' => [30, 59, 11],
'Normal 2' => [80, 15, 5],
'Normal 3' => [70, 20, 10],
'Normal 4' => [80, 20,-20],
'Normal 5' => [65, 25, 10],
'Contrast High' => [40, 34, 60],
'Contrast Normal' => [43, 33, 30],
);
# old config hash -> new solution see configuration_set_default()
# insert here all default configurations
# these configurations will be overwritten by $configFile
# at startup
my %config = (
"Geometry" => "790x560+1+1", # fit on a 800x600 screen
"SearchGeometry" => "790x560+1+1", # fit on a 800x600 screen
"KeyGeometry" => "250x500+50+50", # fit on a 800x600 screen
"LocGeometry" => "250x500+50+50", # fit on a 800x600 screen
"LtwGeometry" => "700x500+10+10", # fit on a 800x600 screen
"FontSize" => 12,
"FontFamily" => "itc avant garde",
"PropFontSize" => 12,
"PropFontFamily" => "helvetica",
"ColorSel" => "gray40",
"ColorSelBut" => "red4",
"ColorSelFG" => "gray85",
"ColorName" => "gray85",
"ColorComm" => "gray85",
"ColorIPTC" => "gray85",
"ColorEXIF" => "gray85",
"ColorFile" => "gray85",
"ColorDir" => "gray85",
"ColorThumbBG" => "gray60",
"ColorProgress" => "gray85",
"ColorPicker" => "#efefef", # last color selected with color picker
"Copyright" => "copyright (c) $copyright_year Herrmann",
"Comment" => "This picture was taken in south africa ...",
"MaxProcs" => 1,
"MaxCachedPics" => 3,
"NrOfRuns" => 0, # count how often mapivi was started
"ShowPic" => 1, # boolean (1 = show pic, 0 = do not show pic)
"ThumbCapt" => "none", # thumbnail caption
"ThumbCaptFontSize" => 10,
"ShowNavFrame" => 1, # boolean (1 = show naviagtion frame, 0 = hide)
"ShowInfoFrame" => 1, # boolean (1 = show info frame, 0 = hide)
"ShowThumbFrame" => 1, # boolean (1 = show thumb frame, 0 = hide)
"ShowPicFrame" => 1, # boolean (1 = show pic frame, 0 = hide)
"ShowComment" => 1, # boolean (1 = show comment, 0 = hide comment in thumbnail view)
"ShowCommentField"=> 0, # boolean (1 = show comment, 0 = hide comment in picture view)
"ShowIPTCFrame" => 0, # boolean (1 = show IPTC headline, caption, 0 = hide IPTC frame in picture view)
"ShowEXIF" => 1, # boolean (1 = show EXIF, 0 = hide EXIF in thumbnail view)
"ShowIPTC" => 1, # boolean (1 = show IPTC, 0 = hide IPTC in thumbnail view)
"ShowFile" => 1, # boolean (1 = show Size, 0 = hide Size in thumbnail view)
"ShowDirectory" => 1, # boolean (1 = show directory, 0 = hide dir in thumbnail view)
"ShowMenu" => 1, # boolean (1 = show menu, 0 = hide the menu bar)
"ShowHiddenDirs" => 0, # boolean (1 = show hidden dirs (starting with .), 0 = hide them)
"PicQuality" => 95, # quality of jpg picture (in %)
"PicSharpen" => 5, # sharpness of picture
"PicBlur" => 0, # blur the pictur
"PicGamma" => 1.0,# gamma value of picture
"PicBrightness" => 100,# Brightnes of picture (in %)
"PicSaturation" => 100,# Saturation of picture (in %)
"PicHue" => 100,# Hue of picture (in %)
"PicStrip" => 0, # boolean (1 = strip all meta info when resizing pic)
"ThumbQuality" => 85, # quality of thumbnail jpg picture
"SortBy" => "name",
"SortReverse" => 0,
"LastDir" => $home,
"FileNameFormat" => "%y%m%d-%h%M%s", # the actual file name format when renaming
"FileNameFormatDef"=> "%y%m%d-%h%M%s", # the default file name format when renaming
"ThumbSharpen" => 1,
"ThumbSize" => 100,
"ThumbBorder" => 4,
"HTMLaddComment" => 1,
"HTMLaddEXIF" => 1,
"HTMLaddIPTC" => 1,
"HTMLcols" => 2,
"HTMLTargetDir" => $home,
"HTMLGalleryIndex"=> "../galleries.html",
"HTMLGalleryTitle"=> "My gallery",
"HTMLHomepage" => "../../index.shtml",
"HTMLTemplate" => "$program_data_path/html/light.html",
"HTMLFooter" => "© Martin Herrmann <Martin-Herrmann\@gmx.de>",
"HTMLBGcolor" => "white",
"HTMLPicSize" => 600,
"HTMLPicSharpen" => 1,
"HTMLPicCopyright"=> 0, # bool - add a visible copyright info into the picture
"HTMLPicQuality" => 80, # quality of html jpg pictures
"HTMLPicEXIF" => 1, # bool - 1 = copy the EXIF infos to the converted HTML pics
"HTMLnoPicChange" => 0, # bool - 1 = no pic changes (no resize etc ...)
"AutoZoom" => 1, # boolean - zoom big pictures to fill the canvas
"UseEXIFThumb" => 0, # boolean - use EXIF Thumbnails if available
"AskGenerateThumb"=> 1, # ask before generating thumbnails
"AskDeleteThumb" => 1, # ask before deleting thumbnails
"AskMakeDir" => 1, # ask before makeing a directory (e.g. .thumbs or .exif)
"MaxTrashSize" => 50, # MB - a warning will appear if the trash contains more than this
"BitsPixel" => 0, # boolean - show bits per pixel info
"AspectRatio" => 1, # boolean - show image aspect ratio e.g. 4:3 or 3:2
"NameComment" => 0, # boolean - 1 = add file name to comment, when importing pics
"NameComRmSuffix" => 1, # boolean - 1 = remove file suffix when adding filename to comment
"SaveDatabase" => 1, # boolean - 1 = save dir info to a file
"UseThumbShadow" => 0,
"MakeBackup" => 1, # make a backup of the original file, before appling a filter
"PicListFile" => "$home/filelist",
"XMLFile" => "$home/IPTCinfo.xml",
"indexRows" => 2, # indexPrint
"indexCols" => 2, # indexPrint
"indexPicX" => 500, # indexPrint
"indexPicY" => 500, # indexPrint
"indexDisX" => 10, # indexPrint
"indexDisY" => 10, # indexPrint
"indexBG" => "white", # indexPrint background color
"indexLabel" => 1, # indexPrint
"indexLabelStr" => "%f (%wx%h, %b)", # indexPrint
"WarnBeforeResize"=> 1, # warn before using mogrify in resize
"IPTCoverwrite" => 0, # overwrite IPTC attributes, when editing multiple pictures
"IPTCmergeCatKey" => 1, # merge categories and keywords, when editing multiple pictures
"IPTCdateEXIF" => 0, # use EXIF date as creation date
"IPTCtimeEXIF" => 0, # use EXIF time as creation time
"IPTCbylineEXIF" => 0, # use EXIF owner as ByLine
"IPTCaddMapivi" => 0, # add Mapivi infos to IPTC
"IPTC_action" => 'UPDATE', # ADD UPDATE or REPLACE
"CheckForNonJPEGs"=> 0, # check if there are non JPEGs in the dir and ask to convert them
"ShowPicInfo" => 1, # show a balloon info box with EXIF, comment, ... for the actual picture
"SearchPattern" => '', # the search pattern
"SearchExPattern" => '', # the search exclude pattern
"SearchCom" => 1, # search in the picture comments
"SearchExif" => 1, # search in the picture EXIF info
"SearchIptc" => 1, # search in the picture IPTC info
"SearchKeys" => 1, # search in the picture keywords
"SearchName" => 1, # search in the picture file name
"SearchDir" => 1, # search in the picture path
"SearchCase" => 0, # search case sensitive
"SearchWord" => 0, # 1 = search only complete words 0 = match also parts
"SearchType" => 'exactly', # search type: "exactly", "all" or "any"
"SearchOnlyInDir" => 0, # search only in dirs matching the actual/selected dir
"SearchPixelOn" => 0, # search for pictures with a certain pixel size
"SearchPixel" => 0, #
"SearchPixelRel" => '<=', # <=, ==, >=
"SearchPopOn" => 0, # search for pic with a certain number of views
"SearchPopRel" => 0, # <=, ==, >=
"SearchPop" => 0, # search for pic with a certein numer of views
"SearchJoin" => 0, # join comment, EXIF, IPTC and filename before searching
"SearchDate" => 0, # search pics by date
"SearchDateStart" => "01.01.1970", # start date
"SearchDateEnd" => "25.08.2012", # end date
"SearchMore" => 0, # show more search options in search window
"SearchDBOnlyNew" => 0, # add only new pics when building DB
"CopyPosition" => 'SouthEast', # position of the visible copyright info
"CopyX" => 20, # x offset of the visible copyright info
"CopyY" => 20, # Y offset of the visible copyright info
"CopyAdd" => 0, # bool - add a visible copyright info
"CopyFontFamily" => "Courier", # font family of the embedded copyright info
"CopyFontSize" => 12, # font size of the embedded copyright info
"CopyFontColFG" => "white", # foreground color of the embedded copyright info font
"CopyFontColBG" => "black", # background color of the embedded copyright info font
"CopyFontShadow" => 1, # bool - add a shadow to the copyright text
"CopyrightLogo" => "$program_data_path/icons/MapiviIcon.gif",
"CopyTextOrLogo" => "text",
"BorderWidth1x" => 10, # border 1 width in x direction
"BorderWidth1y" => 10, # border 1 width in y direction
"BorderColor1" => "white", # border 1 color
"BorderWidth2x" => 0, # border 2 width in x direction
"BorderWidth2y" => 0, # border 2 width in y direction
"BorderColor2" => "black", # border 2 color
"BorderWidth3x" => 0, # border 3 width in x direction
"BorderWidth3y" => 0, # border 3 width in y direction
"BorderColor3" => "white", # border 3 color
"BorderWidth4x" => 0, # border 4 width in x direction
"BorderWidth4y" => 0, # border 4 width in y direction
"BorderColor4" => "gray80",# border 4 color
"BorderAdd" => 0, # bool - add a border
"DropShadow" => 0, # bool - add a drop shadow
"DropShadowWidth" => 5, # the width of the drop shadow
"DropShadowBlur" => 3, # the blur sigma factor of the drop shadow
"DropShadowBGColor" => "white", # the background color of the drop shadow
"jpegtranTrim" => 0, # bool - use the -trim switch of jpegtran
"SlideShowTime" => 4, # pause between picture loading im sec
"CropAspect" => 3/2, # 0 for no aspect ratio, 3/2 for 3:2 1 for 1:1 4/3 for 4:3
"CropGrid" => 1, # bool show 1/3 crop grid
"AspectSloppyFactor" => 2.0, # delta factor for aspect ratio calculation in %
"FilterDeco" => 0, # add a border or a text to the pictures when filtering
"FilterPrevSize" => 200, # filter preview size (100% zoom crop of the picture)
"EXIFshowApp" => 1, # show App*-Info and MakerNotes and ColorComponents in EXIF info
"Layout" => 0, # layout of the dir, thumb and picture frame
"Layout0dirX" => 25, # default percentual width of the different layouts
"Layout0thumbX" => 30, # ""
"Layout1dirX" => 20, # ""
"Layout3thumbX" => 20, # ""
"Layout5dirX" => 20, # ""
"CommentHeight" => 2, # height of the comment text frame above the picture
"Gamma" => 1.0, # the gamma value, when displaying pictures
"ShowFileDate" => 0, # show the file date in the size coloumn
"Unsharp" => 0, # bool unsharp mask operation on/off
"UnsharpRadius" => 0, # unsharp mask radius (blur)
"UnsharpSigma" => 1.0, # unsharp mask sigma (blur)
"UnsharpAmount" => 1.0, # unsharp mask amount
"UnsharpThreshold"=> 0.05,# unsharp mask threshold
"ResizeFilter" => "Lanczos",
"RenameBackup" => 1, # bool, if 1 a backup file will be renamed if the file is renamed
"ThumbMaxLimit" => 200, # maximum number of displayed thumbnails
"Level" => 0, # level a picture
"LevelBlack" => 8, # level a picture black point (%)
"LevelWhite" => 92, # level a picture white point (%)
"LevelGamma" => 1.0, # level a picture mid point (gamma value)
"indexBorder" => 0, # bool add a border around the index print
"indexBorderWidth"=> 50,
"indexBorderColor"=> 'white',
"indexInnerBorder" => 0, # bool add a border around the each picture
"indexInnerBorderWidth"=> 2,
"indexInnerBorderColor"=> 'black',
"indexFontSize" => 10, # the font size of the index labels (0 = automatic)
"CheckForLinks" => 1, # bool - check if a file is a link before processing it
"ColorAdj" => 0, # bool - do some color adjustments when filtering a pic
"LineLimit" => 8, # max nr of lines in the thumbnail table e.g. for comments
"LineLength" => 30, # length of one line in the thumbnail table e.g. for comments
"ExtBGApp" => "wmsetbg -a", # name of external app to set desktop background (with options)
"ConvertUmlaut" => 1, # convert german umlaute (e.g. ä -> ae etc.)
"onlyASCII" => 1, # convert Umlaute and remove non printable (non-ASCII) chars
"ImportSource" => "/mnt/usb/DCIM/DIMG",
"ImportSubdirs" => 0, # bool - import also from all subdirs
"ImportTargetFix" => "$home/pictures",
"ImportTargetVar" => "2012/02/14_Birthday_Sam",
"ImportRotate" => 1,
"ImportRename" => 1,
"ImportDeleteCameraJunk" => 0,
"ImportDelete" => 1,
"ImportShowPics" => 1,
"ImportAddCom" => 0,
"ImportAddComment"=> "(c) $copyright_year Martin Herrmann",
"ImportAddIPTC" => 0, # bool
"ImportAddIPTCDateTime" => 0, # bool
"ImportAddIPTCByLine" => 0, # bool
"ImportIPTCTempl" => 'template.iptc2',
"ImportMore" => 0, # bool - show additional import options in wizard
"ImportMarkLocked"=> 0, # bool - add a high rating to locked (= write protected) pictures during import
"Borderwidth" => 1, # border width of GUI elements (widgets)
"PrintBaseDir" => "$home/pictures/print",
"PrintVarDir" => "3_times_13x18",
"PrintTimes" => "1",
"PrintTimesStr" => "times",
"PrintSize" => "10x15",
"CenterThumb" => 0, # move the thumbnails up or down, so that the next e.g. previous thumb is also visible
"BeepWhenLooping" => 1, # play a beep when looping to the first e.g. last picture
"SlowButMoreFeatures" => 0, # enable some features slowing down mapivi
"setEXIFDateAskAgain" => 0, # show/don't show ask dialog
"EXIFDateAbs" => "2012:03:20-18:51:45",
"EXIFPlusMin" => "+", # used in setEXIFdate
"EXIFAbsRel" => 'abs', # used in setEXIFdate
"EXIFyears" => 0, # used in setEXIFdate
"EXIFdays" => 0, # used in setEXIFdate
"EXIFhours" => 0, # used in setEXIFdate
"EXIFmin" => 0, # used in setEXIFdate
"EXIFsec" => 0, # used in setEXIFdate
"RotateThumb" => 1, # bool - rotate thumb when rotating the pic
"ToggleBorder" => 0, # bool - switch window decoration on/off in fullscreen mode
"CentralThumbDB" => 0, # bool - 1 = central thumb DB, 0 = decentral .thumbs dirs
"IPTCLastPad" => "cap", # remember the NoteBook page on the IPTC dialog
"OptionsLastPad" => "gen", # remember the NoteBook page on the IPTC dialog
"MetadataWarn" => 0, # print a warning to stdout if some strange metadata is found (e.g. in EXIF)
"dirDiffDirA" => $home,
"dirDiffDirB" => $home,
"dirDiffSize" => 1,
"dirDiffPixel" => 1,
"dirDiffComment" => 1,
"dirDiffEXIF" => 1,
"dirDiffIPTC" => 1,
"MailPicNoChange" => 0,
"MailPicMaxLength"=> 800,
"MailPicQuality" => 75,
"winDirRequesterAskAgain" => 1,
"FuzzyBorderRelative"=> 1, # 1 = Border width in %, 0 = Absolute in pixels
"FuzzyBorderWidth"=> 10, # % or pixels depending on FuzzyBorderRelative
"FuzzyBorderBlur" => 10,
"FuzzyBorderColor"=> 'black',
"ShowInfoInCanvas"=> 1,
"llBorderWidthX" => 16,
"llBorderWidthY" => 16,
"llBorderWidthIX" => 1,
"llBorderWidthIY" => 1,
"llBorderColor" => 'white',
"llBorderColorI" => 'black',
"supportOtherPictureFormats" => 0,
"CategoriesAll" => 2, # category mode 0= last, 1=all, 2=join
"KeywordsAll" => 2, # keyword mode 0= last, 1=all, 2=join
"Version" => '000',
"ShowUnfinishedDirs" => 1,
"ShowFinishedDirs" => 1,
"trackPopularity" => 1,
"ChannelRed" => 100,
"ChannelGreen" => 100,
"ChannelBlue" => 100,
"ChannelDeco" => 0,
"ChannelBright" => 1,
'SlideShowDir' => $home, # settings for slideshows
'relative_path' => 1, # settings for xnview slideshows
'xnview_loop' => 1, # settings for xnview slideshows
'xnview_fullscreen' => 1, # settings for xnview slideshows
'xnview_filename' => 0, # settings for xnview slideshows
'xnview_random' => 0, # settings for xnview slideshows
'xnview_mouse' => 0, # settings for xnview slideshows
'xnview_title' => 0, # settings for xnview slideshows
'PicWinBalloon' => 1, # boolean -1 show balloon info in pic window
'IPTCProfessional'=> 1, # boolean - 1 = professional IPTC, 0 = simple dialog
'CheckNewKeywords'=> 1,
'KeywordMore' => 0, # boolean 1 = show more options in keyword search window
'KeywordExclude' => '', # space separated list of keywords to exclude
'KeywordLimit' => 0, # boolean 1 = limit number of displayed keywords
'KeywordDate' => 0, # boolean 1 = limit to a date range
'KeywordStart' => 1070254800, # start date (UNIX time)
'KeywordEnd' => 1170254800, # end date (UNIX time)
'UrgencyChangeWarning' => 1, # boolean 1 = show a warning when urgency changed
'ActPic' => '', # the last picture shown
'SelectLastPic' => 1, # Select last shown pic after startup
'AutoImport' => 1, # boolean = 1 start import at Mapivi wizard if memory card is inserted (ImportSource)
'llWatermarkX' => 16, # lossless watermark x position
'llWatermarkY' => -16, # lossless watermark y position
'llWatermarkFile' => "$icon_path/EmptyThumb.jpg", # lossless watermark file name
'AspectBorderN' => 3, # lossless aspect ratio border
'AspectBorderM' => 2, # lossless aspect ratio border
'RelativeBorderX' => 10, # lossless relative border
'RelativeBorderY' => 10, # lossless relative border
'RelativeBorderIX' => 0.1, # lossless relative border
'RelativeBorderIY' => 0.1, # lossless relative border
'RelativeBorderEqual'=> 1, # boolean lossless relative border
'XMP_file_operations'=> 1, # boolean XMP sidecar files follow picture file operations
'WAV_file_operations'=> 1, # boolean WAV audio files follow picture file operations
'RAW_file_operations'=> 0, # boolean RAW files follow picture file operations
'LocationMode' => 'UPDATE', # UPDATE or REPLACE - mode for writing IPTC location info
'AskDeleteHighRating'=> 1, # boolean - ask before deleting high rated pictures
'AskDeleteHighRatingLevel'=> 3, # Urgency (Rating) - ask before deleting high rated pictures
'Language' => 'en', # language localization, needs a corresponding translation file e.g. mapivi-lang-de for german (de)
'ColorCloud' => 'red', # color of the most prominent keywords in the keyword cloud
);
# some platform specific default settings
# for windows
#if ($EvilOS) {
# $config{ExtViewer} = 'C:\Program Files\IrfanView\iview_32.exe';
# $config{ExtEdior} = 'gimp-win-remote gimp-2.2.exe';
#}
# for Mac OS X
#if ($MacOSX) {
# $config{ExtViewer} = "macosx-preview";
# $config{ExtViewerMulti} = 1;
#}
my @IPTCAttributes = (
"Urgency",
"Keywords",
"Headline",
"Caption/Abstract",
"Country/PrimaryLocationName",
"Country/PrimaryLocationCode",
"Province/State",
"City",
"SubLocation",
"Writer/Editor",
"ObjectName",
"CopyrightNotice",
"Category",
"Source",
"EditStatus",
"OriginatingProgram",
"ProgramVersion",
"EditorialUpdate",
"ObjectCycle",
"ByLine",
"ByLineTitle",
"FixtureIdentifier",
"ContentLocationName",
"ContentLocationCode",
"ReleaseDate",
"ReleaseTime",
"OriginalTransmissionReference",
"ExpirationDate",
"ExpirationTime",
"Credit",
"SpecialInstructions",
"ActionAdvised",
"Contact",
#"ReferenceService", # only usefull for multiple objects
#"ReferenceDate", # only usefull for multiple objects
#"ReferenceNumber", # only usefull for multiple objects
"DateCreated",
"TimeCreated",
"ImageType",
"ImageOrientation",
"DigitalCreationDate",
"DigitalCreationTime",
"LanguageIdentifier",
#"RecordVersion", # binary
"ObjectTypeReference",
"ObjectAttributeReference",
"SubjectReference",
"SupplementalCategory",
#"RasterizedCaption", # binary
# Audio... and ObjDataPreview... left out by now ...
);
my %iptcHelp = (
'ByLine' => lang("Contains name of the creator of the objectdata, e.g. writer, photographer or graphic artist. Examples: Robert Capa, Ernest Hemingway, Pablo Picasso (max. 32 chars)"),
'ByLineTitle' => lang("A ByLineTitle is the title of the creator or creators of an objectdata. Where used, a by-line title should follow the ByLine it modifies. Examples: Staff Photographer, Corresponsal, Envoye Special (max. 32 chars)"),
'Caption/Abstract' => lang("The Caption field is the text that accompanies the photo, containing the who, what, when, where and why information (max. 2000 chars)"),
'CaptionWriter' => lang("The Caption Writer field lists the initials of all the people who wrote or edited the caption, header fields or image file. This includes toning and pixel editing"),
'Category' => lang("Identifies the subject of the objectdata in the opinion of the provider. A list of categories will be maintained by a regional registry, where available, otherwise by the provider. Note: Use of this DataSet is Deprecated. It is likely that this DataSet will not be included in further versions of the IIM. The Category field lists codes that aid in a more detailed search. (max. 3 chars)"),
'SubLocation' => lang("Identifies the location within a city. Examples: Capitol Hill, Maple Leaf Gardens, Strandgateparken (max. 32 chars)"),
'City' => lang("The City field lists where the photo was originally made. For file photos, do not use the transmission point's city (max. 32 chars)"),
'Country/PrimaryLocationCode' => lang("The Country field lists the three-letter country code where the photo was originally made. For file photos, do not put the transmission points country. Examples: USA (United States), GER (Germany), FRA (France), XUN (United Nations) (max. 3 chars)"),
'Country/PrimaryLocationName' => lang("Provides full, publishable, name of the country/primary location where the intellectual property of the objectdata was created, according to guidelines of the provider. (max. 64 chars)"),
'DateCreated' => lang("The Create Date field is the date the photo was originally made. For file photos, use the date the photo was originally made, if known. If the complete date is not known, leaf the field blank. The field will not accept a partial date. (8 chars CCYYMMDD)"),
'TimeCreated' => lang("Represented in the form HHMMSS+HHMM (or -HHMM) to designate the time the intellectual content of the objectdata current source material was created rather than the creation of the physical representation. Follows ISO 8601 standard. Where the time cannot be precisely determined, the closest approximation should be used. Example: 133015+0100 indicates that the object intellectual content was created at 1:30 p.m. and 15 seconds Frankfurt time, one hour ahead of UTC. (11 chars HHMMSS+HHMM)"),
'Credit' => lang("Identifies the provider of the objectdata, not necessarily the owner/creator. (The Credit field is the name of the service transmitting the photo) (max. 32 chars)"),
'Headline' => lang("The Headline field lists keywords to aid in a more detailed search for a photo. Example: Lindbergh Lands In Paris (max. 256 chars)"),
'SpecialInstructions' => lang("The Instructions field lists special notations that apply uniquely to a photo, such as file photo, correction, advance or outs Examples: SECOND OF FOUR STORIES, 3 Pictures follow, Argentina OUT (max. 256 chars)"),
'ObjectName' => lang("Used as a shorthand reference for the object. Changes to existing data, such as updated stories or new crops on photos, should be identified in Edit Status. Examples: Wall St., Ferry Sinks. The Object Name field lists the story slug associated with a photo. For photos without a story, Associated Press photographers or photo editors will make up a logical slug to aid in a search and note it as a stand alone photo in the INSTRUCTIONS field of the NAA/IPTC header. If a related story moves on Data-Stream, the photo will be retransmitted with the appropriate OBJECT NAME to match the story. (max. 64 chars)"),
'Source' => lang("Identifies the original owner of the intellectual content of the objectdata. This could be an agency, a member of an agency or an individual. (The Source field lists who is the original provider of a photo, such as: AP, an AP member, pool photo provider or handout photo provider.) (max. 32 chars)"),
'Province/State' => lang("The State field lists the state where the photo was originally made. Use U.S. postal code abbreviations. For file photos, do not use the transmission point's state. Examples: WA, Sussex, Baden-Wuerttenberg (max. 32 chars)"),
'SupplementalCategory' => lang("The Supplemental Categories field lists codes that aid in a more detailed search for a photo."),
'OriginalTransmissionReference' => lang("A code representing the location of original transmission according to practices of the provider. Examples: BER-5, PAR-12-11-01. (The Trans Reference field lists a call letter/number combination associated with a photo. It includes an originating transmit points call letters and picture number from that point's sequence of offerings for a given day. Example: NY105.) (max. 32 chars)"),
'Urgency' => lang("Priority 0 meaning None, 1 meaning High to 8 meaning Low"),
'CopyrightNotice' => lang("Contains any necessary copyright notice. (max. 128 chars)"),
'ExpirationTime' => lang("Designates in the form HHMMSS+HHMM (or -HHMM) the latest time the provider or owner intends the objectdata to be used. Follows ISO 8601 standard. Example: 090000-0500 indicates an objectdata that should not be used after 0900 in New York (five hours behind UTC)."),
'ExpirationDate' => lang("Designates in the form CCYYMMDD the latest date the provider or owner intends the objectdata to be used. Follows ISO 8601 standard. Example: 19940317 indicates an objectdata that should not be used after 17 March 1994."),
'ReleaseTime' => lang("Designates in the form HHMMSS+HHMM (or -HHMM) the earliest time the provider intends the object to be used. Follows ISO 8601 standard. Example: 090000-0500 indicates object for use after 0900 in New York (five hours behind UTC)"),
'ReleaseDate' => lang("Designates in the form CCYYMMDD the earliest date the provider intends the object to be used. Follows ISO 8601 standard. Example: 19890317 indicates data for release on 17 March 1989. (8 chars)"),
'FixtureIdentifier' => lang("Identifies objectdata that recurs often and predictably. Enables users to immediately find or recall such an object. Example: EUROWEATHER"),
'EditStatus' => lang("Status of the objectdata, according to the practice of the provider. Examples: Lead, CORRECTION (max. 64 chars)"),
'Writer/Editor' => lang("Identification of the name of the person involved in the writing, editing or correcting the objectdata or caption/abstract. (max. 32 chars)"),
'LanguageIdentifier' => lang("Describes the major national language of the object, according to the 2-letter codes of ISO 639:1988. Does not define or imply
any coded character set, but is used for internal routing, e.g. to various editorial desks. Example: en (english), de (german) (2 or 3 chars)"),
'ObjectCycle' => lang("Where: a = morning, p = evening, b = both. Virtually only used in North America. (1 char)"),
'Contact' => lang("Identifies the person or organisation which can provide further background information on the objectdata. (max. 128 chars)")
);
# store all values which were entered in the labeled entry widgets
# key = label of entry, value = reference to array containing all unique values
my %entryHistory;
my @allcolors = qw/black gray10 gray20 gray30 gray40 gray50 gray60 gray70 gray80 gray85 gray90
gray95 white snow2 snow3 snow4 seashell1 seashell2 seashell3 seashell4
AntiqueWhite1 AntiqueWhite2 AntiqueWhite3 AntiqueWhite4 bisque1
bisque2 bisque3 bisque4 PeachPuff1 PeachPuff2 PeachPuff3 PeachPuff4
NavajoWhite1 NavajoWhite2 NavajoWhite3 NavajoWhite4 LemonChiffon1
LemonChiffon2 LemonChiffon3 LemonChiffon4 cornsilk1 cornsilk2
cornsilk3 cornsilk4 ivory1 ivory2 ivory3 ivory4 honeydew1 honeydew2
honeydew3 honeydew4 LavenderBlush1 LavenderBlush2 LavenderBlush3
LavenderBlush4 MistyRose1 MistyRose2 MistyRose3 MistyRose4 azure1
azure2 azure3 azure4 SlateBlue1 SlateBlue2 SlateBlue3 SlateBlue4
RoyalBlue1 RoyalBlue2 RoyalBlue3 RoyalBlue4 blue1 blue2 blue3 blue4
DodgerBlue1 DodgerBlue2 DodgerBlue3 DodgerBlue4 SteelBlue1 SteelBlue2
SteelBlue3 SteelBlue4 DeepSkyBlue1 DeepSkyBlue2 DeepSkyBlue3
DeepSkyBlue4 SkyBlue1 SkyBlue2 SkyBlue3 SkyBlue4 LightSkyBlue1
LightSkyBlue2 LightSkyBlue3 LightSkyBlue4 SlateGray1 SlateGray2
SlateGray3 SlateGray4 LightSteelBlue1 LightSteelBlue2 LightSteelBlue3
LightSteelBlue4 LightBlue1 LightBlue2 LightBlue3 LightBlue4 LightCyan1
LightCyan2 LightCyan3 LightCyan4 PaleTurquoise1 PaleTurquoise2
PaleTurquoise3 PaleTurquoise4 CadetBlue1 CadetBlue2 CadetBlue3
CadetBlue4 turquoise1 turquoise2 turquoise3 turquoise4 cyan1 cyan2
cyan3 cyan4 DarkSlateGray1 DarkSlateGray2 DarkSlateGray3
DarkSlateGray4 aquamarine1 aquamarine2 aquamarine3 aquamarine4
DarkSeaGreen1 DarkSeaGreen2 DarkSeaGreen3 DarkSeaGreen4 SeaGreen1
SeaGreen2 SeaGreen3 SeaGreen4 PaleGreen1 PaleGreen2 PaleGreen3
PaleGreen4 SpringGreen1 SpringGreen2 SpringGreen3 SpringGreen4 green1
green2 green3 green4 chartreuse1 chartreuse2 chartreuse3 chartreuse4
OliveDrab1 OliveDrab2 OliveDrab3 OliveDrab4 DarkOliveGreen1
DarkOliveGreen2 DarkOliveGreen3 DarkOliveGreen4 khaki1 khaki2 khaki3
khaki4 LightGoldenrod1 LightGoldenrod2 LightGoldenrod3 LightGoldenrod4
LightYellow1 LightYellow2 LightYellow3 LightYellow4 yellow1 yellow2
yellow3 yellow4 gold1 gold2 gold3 gold4 goldenrod1 goldenrod2
goldenrod3 goldenrod4 DarkGoldenrod1 DarkGoldenrod2 DarkGoldenrod3
DarkGoldenrod4 RosyBrown1 RosyBrown2 RosyBrown3 RosyBrown4 IndianRed1
IndianRed2 IndianRed3 IndianRed4 sienna1 sienna2 sienna3 sienna4
burlywood1 burlywood2 burlywood3 burlywood4 wheat1 wheat2 wheat3
wheat4 tan1 tan2 tan3 tan4 chocolate1 chocolate2 chocolate3 chocolate4
firebrick1 firebrick2 firebrick3 firebrick4 brown1 brown2 brown3
brown4 salmon1 salmon2 salmon3 salmon4 LightSalmon1 LightSalmon2
LightSalmon3 LightSalmon4 orange1 orange2 orange3 orange4 DarkOrange1
DarkOrange2 DarkOrange3 DarkOrange4 coral1 coral2 coral3 coral4
tomato1 tomato2 tomato3 tomato4 OrangeRed1 OrangeRed2 OrangeRed3
OrangeRed4 red1 red2 red3 red4 DeepPink1 DeepPink2 DeepPink3 DeepPink4
HotPink1 HotPink2 HotPink3 HotPink4 pink1 pink2 pink3 pink4 LightPink1
LightPink2 LightPink3 LightPink4 PaleVioletRed1 PaleVioletRed2
PaleVioletRed3 PaleVioletRed4 maroon1 maroon2 maroon3 maroon4
VioletRed1 VioletRed2 VioletRed3 VioletRed4 magenta1 magenta2 magenta3
magenta4 orchid1 orchid2 orchid3 orchid4 plum1 plum2 plum3 plum4
MediumOrchid1 MediumOrchid2 MediumOrchid3 MediumOrchid4 DarkOrchid1
DarkOrchid2 DarkOrchid3 DarkOrchid4 purple1 purple2 purple3 purple4
MediumPurple1 MediumPurple2 MediumPurple3 MediumPurple4 thistle1
thistle2 thistle3 thistle4/;
# get the configurations from the rc file if the configdir exists (old configuration)
readConfig($configFile, \%config) if (-d $user_data_path);
# get the configurations from file (new configuration)
{
my ($ok, $err) = configuration_restore($conf_file, \%conf);
warn $err if (not $ok);
}
$actpic = $config{ActPic};
# todo: generate a template from all lang() and langf() calls within mapivi
my %messages;
# Warning: no lang() or langf() call before the language_load call! (They will be useless)
language_load($config{Language});
# Warning! The keys of the %statistic_data_longnames hash have to be same as in the %searchDB hash!!!
my %statistic_data_longnames = (
'COM' => lang("comment"),
'EXIF' => lang("EXIF data"),
'IPTC' => lang("IPTC data"),
'URG' => lang("rating"),
'KEYS' => lang("keywords"),
);
# used as '[empty]' string in IPTC location info
my $empty_str = '['.lang("empty").']';
# At startup the menu should always be visible
$config{ShowMenu} = 1;
# I consider it safer to reset this option after a restart, else the user may lose an orignial picture
$config{MakeBackup} = 1;
# check at startup if a new Mapivi version is available
check_version($version);
# check if this is the first start of a new Mapivi version
mapiviUpdate() if (($config{Version} eq '000') or ($version ne $config{Version}));
$config{Version} = $version;
processARGV(); # process the command line arguments as early as possible to give a fast feedback
my $layoutOld = $config{Layout}; # this must be done after readConfig!
# for zoom and subsample of Tk::Photo objects
# the higher the zoom value the longer the time to zoom
# subsample is quite fast, so the first number (zoom) should not be bigger than 4
# the second (subsample) may be bigger
my @frac;
if ($config{SlowButMoreFeatures}) {
@frac = (10,1, 6,1, 4,1, 3,1, 2,1, 3,2, 4,3, 1,1, 4,5, 3,4, 2,3, 3,5, 4,7, 5,9, 1,2, 3,7, 2,5, 3,8, 4,11, 1,3, 2,7, 1,4, 2,9, 1,5, 1,6, 1,7, 1,8, 1,10, 1,12, 1,16, 1,25, 1,50);
}
else {
@frac = (10,1, 6,1, 4,1, 3,1, 2,1, 3,2, 4,3, 1,1, 4,5, 3,4, 2,3, 1,2, 1,3, 1,4, 1,5, 1,6, 1,7, 1,8, 1,10, 1,12, 1,16, 1,25, 1,50);
}
# open main window
my $top = MainWindow->new;
# hide it, while building up
$top->withdraw;
# store session start time
$top->{sessioninfo}{starttime} = time();
# store name in top hash (used in Tk::MhConfig.pm)
$top->{tool_name} = 'Mapivi';
# process Gtk2 events if Gtk2 is available
if ($gtk2_avail) {
$top->repeat(10, sub{
Gtk2->main_iteration while Gtk2->events_pending;
});
}
# set the window size
checkGeometry(\$config{Geometry});
$top->geometry($config{Geometry});
# add a window and icon picture
my $icon_data = <Photo(-data => $icon_data);
#my $mapiviiconfile = "$program_data_path/icons/MapiviIcon.gif";
#$mapiviiconfile = "$program_data_path/icons/MapiviIcon32.gif" if $EvilOS;
$top->idletasks if $EvilOS; # this line is crucial (at least on windows)
$top->iconimage($mapiviicon) if $mapiviicon;
my $dragAndDrop1 = "$program_data_path/icons/MiniPic.jpg";
my $dragAndDrop2 = "$program_data_path/icons/MiniPicMulti.jpg";
my $dragAndDropIcon1;
$dragAndDropIcon1 = $top->Photo(-file => $dragAndDrop1) if (-f $dragAndDrop1);
my $dragAndDropIcon2;
$dragAndDropIcon2 = $top->Photo(-file => $dragAndDrop2) if (-f $dragAndDrop2);
# button bitmap needed for color buttons
my $mcbut = pack("b8" x 8,
".......",
".......",
".......",
".......",
".......",
".......",
".......",
".......");
$top->DefineBitmap('mcbut' => 8, 8, $mcbut);
# button bitmap needed for + buttons
my $plusbut = pack("b5" x 5,
"..1..",
"..1..",
"11111",
"..1..",
"..1..",);
$top->DefineBitmap('plusbut' => 5, 5, $plusbut);
# button bitmap needed for - buttons
my $minusbut = pack("b5" x 5,
".....",
".....",
"11111",
".....",
".....",);
$top->DefineBitmap('minusbut' => 5, 5, $minusbut);
# pseudo transpartent bitmap for cropDialog
my $transbits = pack("b4" x 4,
"11..",
"11..",
"..11",
"..11");
$top->DefineBitmap('transp' => 4, 4, $transbits);
# pseudo transpartent bitmap for cropDialog
my $transbits2 = pack("b1" x 3,
"1",
"1",
".");
$top->DefineBitmap('transp2' => 1, 3, $transbits2);
# pseudo transpartent bitmap for cropDialog
my $transbits3 = pack("b1" x 3,
"1",
".",
"1");
$top->DefineBitmap('transp3' => 1, 3, $transbits3);
# set title and icon
$top->title("Mapivi $version $svnrevision");
$top->iconname("Mapivi");
# set options
my $ScW = 10;
$ScW = 14 if $EvilOS; # the small scrollbars look ugly under windows
for (qw(Scale Scrollbar)) {
$top->optionAdd("*$_.width", $ScW, 'userDefault');
}
# override -takefocus for frames and scrollbars
$top->optionAdd('*Frame.TakeFocus','0');
$top->optionAdd('*Scrollbar.TakeFocus','0');
$top->optionAdd('*ResizeButton.TakeFocus','0');
# change menu style to compact
$top->optionAdd('*Menu.borderWidth' => 1);
$top->optionAdd('*Menu.activeBorderWidth' => 0);
$top->optionAdd('*Menu.borderWidth' => 1);
$top->optionAdd('*selectForeground', $config{ColorSelFG}, 'userDefault');
$top->optionAdd('*selectBackground', $config{ColorSel}, 'userDefault');
$top->optionAdd("*highlightColor", $config{ColorSel}, 'userDefault');
$top->optionAdd("*highlightBackground", $conf{color_hl_bg}{value}, 'userDefault');
$top->optionAdd("*background", $conf{color_bg}{value}, 'userDefault');
$top->optionAdd("*activeBackground", $conf{color_act_bg}{value},'userDefault');
# must be after the *background optionAdd call
$top->optionAdd("*Menu.background", $conf{color_menu_bg}{value}, 'userDefault');
for (qw(foreground)) {
$top->optionAdd("*$_", $conf{color_fg}{value}, 'userDefault');
}
$top->optionAdd('*Button.foreground' => $conf{color_fg}{value});
$top->optionAdd('*Button.padY' => 0);
$top->optionAdd('*Radiobutton.padY' => 0);
$top->optionAdd('*ROText.foreground' => $conf{color_fg}{value});
$top->optionAdd('*Optionmenu.foreground' => $conf{color_fg}{value});
$top->optionAdd('*DirTree.foreground' => $conf{color_fg}{value});
$top->optionAdd('*HList.foreground' => $conf{color_fg}{value});
# must be after the *foreground and *background optionAdd call
$top->optionAdd("*Menu.background", $conf{color_menu_bg}{value}, 'userDefault');
$top->optionAdd("*Menu.foreground", $conf{color_menu_fg}{value}, 'userDefault');
for (qw(Scale Scrollbar Adjuster)) {
$top->optionAdd("*$_.troughColor", $conf{color_entry}{value}, 'userDefault');
}
$top->optionAdd("*ProgressBar.troughColor", $conf{color_bg}{value}, 'userDefault');
$top->optionAdd("*Label.background", $conf{color_bg}{value}, 'userDefault');
for (qw(Entry NumEntry Listbox KListbox K2Listbox TixHList HList Text
BrowseEntry.Entry NoteBook)) {
$top->optionAdd("*$_.background", $conf{color_entry}{value}, 'userDefault');
}
for (qw(Button Checkbutton Radiobutton Menubutton
FlatCheckbox FireButton Menu)) {
$top->optionAdd("*$_.cursor", "hand2", 'userDefault');
}
$top->optionAdd("*Radiobutton.selectColor", $config{ColorSelBut}, 'userDefault');
$top->optionAdd("*Checkbutton.selectColor", $config{ColorSelBut}, 'userDefault');
$top->optionAdd("*Menu.selectColor", $config{ColorSelBut}, 'userDefault');
my $font = $top->Font(-family => $config{FontFamily},
-size => $config{FontSize},
#-weight => "normal,-slant,roman,-underline,0,-overstrike,0
);
my $small_font = $top->Font(-family => $config{FontFamily}, -size => 8);
my $font_big = $top->Font(-family => $config{FontFamily}, -size => 20);
$top->optionAdd("*font", $font, 'userDefault');
# slick scrollbars
$top->optionAdd('*Scrollbar.borderWidth' => $config{Borderwidth});
$top->optionAdd('*Adjuster.borderWidth' => $config{Borderwidth});
$top->optionAdd('*Button.borderWidth' => $config{Borderwidth});
$top->optionAdd('*ResizeButton.borderWidth' => $config{Borderwidth});
$top->optionAdd('*Entry.borderWidth' => $config{Borderwidth});
$top->optionAdd('*Scale.borderWidth' => $config{Borderwidth});
$top->optionAdd('*Slider.borderWidth' => $config{Borderwidth});
$top->optionAdd('*NoteBook.borderWidth' => $config{Borderwidth});
$top->optionAdd('*Frame.borderWidth' => $config{Borderwidth});
$top->optionAdd('*NoteBook.Frame.borderWidth' => 0);
$top->optionAdd('*checkbutton.borderWidth' => $config{Borderwidth});
$top->optionAdd('*Checkbutton.borderWidth' => $config{Borderwidth});
$top->optionAdd('*Radiobutton.borderWidth' => $config{Borderwidth});
$top->optionAdd('*radiobutton.borderWidth' => $config{Borderwidth});
$top->optionAdd('*separator.borderWidth' => $config{Borderwidth});
$top->optionAdd('*Menu.borderWidth' => $config{Borderwidth});
$top->optionAdd('*Cascade.borderWidth' => $config{Borderwidth});
$top->optionAdd('*Label.borderWidth' => $config{Borderwidth});
$top->optionAdd('*Canvas.borderWidth' => $config{Borderwidth});
$top->optionAdd('*ROText.borderWidth' => $config{Borderwidth});
$top->optionAdd('*Optionmenu.borderWidth' => $config{Borderwidth});
$top->optionAdd('*DirTree.borderWidth' => $config{Borderwidth});
$top->optionAdd('*HList.borderWidth' => $config{Borderwidth});
# call quitMain when the window is closed by the window manager
$top->protocol("WM_DELETE_WINDOW" => sub { quitMain(); });
# init stuff
$balloon = $top->Balloon(-bg => $config{ColorSel}, -initwait => 1000);
$balloon->Subwidget('message')->configure(-justify => 'left');
$top->fontCreate(qw/C_big -family courier -size 14 -weight bold/);
#createMenubar();
my $infoF = $top->Frame(-relief => 'raised');
# $subF contains the 3 frames: navigation frame ($nav_F), thumbnails ($thumbF) and picture ($mainF)
my $subF = $top->Frame();
my $nav_F = $subF->Frame();
my $dirA = $subF->Adjuster();
my $thumbF = $subF->Frame();
my $thumbA = $subF->Adjuster();
my $mainF = $subF->Frame();
my $dirtree; # is defined in add_nav_frame()
my $comF = $mainF->Frame(-relief => 'raised');
my $comBF = $comF->Frame()->pack(-side => 'left', -expand => 1, -fill => 'both', -anchor=> 'nw', -padx => 0, -pady => 0);
my $iptcF = $mainF->Frame(-relief => 'raised');
my $nrofL = $infoF->Label(-justify => 'left', -textvariable => \$nrof, -relief => 'sunken', -anchor => 'w', -foreground => $conf{color_menu_fg}{value})->pack(-side => 'left', -expand => 0, -fill => 'y');
$balloon->attach($nrofL, -msg => lang("x/y (z, s) = first selected picture is number x\nfrom y pictures in the actual folder\nz pictures are selected\ns is the file size of all selected pictures"));
my $dirtreedir;
my $actdirF = $thumbF->Frame()->pack(-expand => 1, -fill => 'x', -padx => 2, -pady => 1);
if ($conf{filter_pics_button}{value}) {
$actdirF->{Filter} = $actdirF->Checkbutton(-variable => \$conf{filter_pics}{value})->pack(-side => 'left', -anchor=>'w', -padx => 0);
$actdirF->{Filter}->configure(-textvariable => \$actdirF->{Filter}->{excluded_pics});
$actdirF->{Filter}->{excluded_pics} = 0;
$balloon->attach($actdirF->{Filter}, -postcommand => sub {$actdirF->{Filter}->{msg} = lang("If enabled this function will filter the pictures using a keyword list.\nPictures containing the following keywords are not shown:\n$conf{filter_pics_keywords}{value}\nUse the right mouse button over the check button to edit this list.\nThe displayed number (currently $actdirF->{Filter}->{excluded_pics}) indicates the number of excluded pictures.")}, -msg => \$actdirF->{Filter}->{msg});
$actdirF->{Filter}->bind('', sub {
my $exclude_keys = $conf{filter_pics_keywords}{value};
my $rc = myEntryDialog(lang("Edit keywords"), lang("Please edit the list of keywords to exclude.\nSeparate different keywords with a space."), \$exclude_keys);
if ($rc eq 'OK') {
$conf{filter_pics_keywords}{value} = $exclude_keys;
}
});
}
else {
# if the button is not enabled we should not filter
$conf{filter_pics}{value} = 0;
}
my $act_nav_label = '';
my $act_nav_L = $actdirF->Label(-textvariable => \$act_nav_label, -width => 10, -anchor => 'e', -relief => 'sunken', -bd => $config{Borderwidth}, -foreground => $conf{color_menu_fg}{value})->pack(-side => 'left', -expand => 1, -fill => 'x');
$balloon->attach($act_nav_L, -msg => lang("Actual view as chosen in the navigation frame.\nClick opens folder selection dialog."));
$act_nav_L->bind('', sub { openDir(); } );
# add three folder check buttons to mark the folder state (sorted, meta-info, prio/ratings)
$actdirF->{folder_check_buttons} = $actdirF->Frame()->pack(-side => 'left', -expand => 0, -fill => 'x', -padx => 2, -pady => 1);
my $otherFilesL = $actdirF->{folder_check_buttons}->Button(-textvariable => \$otherFiles, -command => sub {showNonJPEGS();}, -relief => 'sunken', -bd => $config{Borderwidth}, -foreground => $conf{color_menu_fg}{value}, -padx => 1, -pady => 0)->pack(-side => 'left');
$balloon->attach($otherFilesL, -msg => lang('Number of hidden files in actual folder')."\n".lang('Click to see hidden files'));
my $dirPropSORT = 0;
my $dirPropMETA = 0;
my $dirPropPRIO = 0;
$actdirF->{cbSORT} = $actdirF->{folder_check_buttons}->Checkbutton(-variable => \$dirPropSORT, -command => sub { $dirProperties{$actdir}{SORT} = $dirPropSORT; })->pack(-side => 'left', -anchor=>'w', -padx => 0);
$actdirF->{cbMETA} = $actdirF->{folder_check_buttons}->Checkbutton(-variable => \$dirPropMETA, -command => sub { $dirProperties{$actdir}{META} = $dirPropMETA; })->pack(-side => 'left', -anchor=>'w', -padx => 0);
$actdirF->{cbPRIO} = $actdirF->{folder_check_buttons}->Checkbutton(-variable => \$dirPropPRIO, -command => sub { $dirProperties{$actdir}{PRIO} = $dirPropPRIO; })->pack(-side => 'left', -anchor=>'w', -padx => 0);
{
my $common_info = lang("\n\nThis button is intended to be used as\npersonal markers for the folder status.\nSee also Menu: ").lang("File")."->".lang("Folder checklist ...");
$balloon->attach($actdirF->{cbSORT}, -msg => langf("You may use this marker e.g. to\nmark this folder as sorted out.%s",$common_info));
$balloon->attach($actdirF->{cbMETA}, -msg => langf("You may use this marker e.g. to\nmark this folder, if all meta information is added.%s",$common_info));
$balloon->attach($actdirF->{cbPRIO}, -msg => langf("You may use this marker e.g. to\nmark this folder, if all pictures are rated.%s",$common_info));
}
my %mapivi_icons = define_icons();
my $picLB;
# main canvas used to show pictures
my $c = $mainF->Scrolled('Canvas',
-scrollbars => 'osoe',
-width => 2000,
-height => 2000,
-relief => 'flat',
-borderwidth => 0,
-highlightthickness => 0,
-bg => $conf{color_bg_canvas}{value},
);
$c->configure(-scrollregion => [0, 0, 100, 100]);
# some canvas settings
$c->{thumb_distance} = 5; # in pixels
$c->{thumb_size} = $config{'ThumbSize'}; # in pixels
my $whL = $infoF->Label(-textvariable => \$widthheight, -relief => 'sunken', -foreground => $conf{color_menu_fg}{value})->pack(-side => 'left', -expand => 0, -fill => 'y');
$balloon->attach($whL, -msg => lang("Width and height of actual picture in pixels"));
my $sizeL = $infoF->Label(-textvariable => \$size, -relief => 'sunken', -foreground => $conf{color_menu_fg}{value})->pack(-side => 'left', -fill => 'y');
$balloon->attach($sizeL, -msg => lang("File size of actual picture in kByte"));
# zoom info
my $zoomL = $infoF->Label(-textvariable => \$zoomFactorStr, -relief => 'sunken', -foreground => $conf{color_menu_fg}{value})->pack(-side => 'left', -fill => 'y');
$balloon->attach($zoomL, -msg => lang("Zoom factor of actual picture"));
# picture rating
my $rating_but;
{
my $rating = 3;
$rating_but = rating_button($infoF, sub {setIPTCurgency($picLB, $rating);}, lang("Rating (IPTC urgency) of actual picture\nTo change click on stars or use keys Ctrl-5 .. -1 or Ctrl-F1, -F2, ... -F8"), 'left', 'y', \$rating);
}
# log info
my $userInfoL = $infoF->Label(-textvariable => \$userinfo, -relief => 'sunken', -foreground => $conf{color_menu_fg}{value})->pack(-side => 'left', -fill => 'both', -expand => 1);
$balloon->attach($userInfoL, -msg => lang("Mapivi log information\nHint: Click to see complete log history."));
$userInfoL->bind('', sub { showText(lang("Mapivi log"), $global_log, NO_WAIT); } );
# color picker
my $colorPickerInfo = $infoF->Label(-text => ' ', -background => $config{ColorPicker}, -relief => 'sunken')->pack(-side => 'left', -fill => 'both', -expand => 0);
$balloon->attach($colorPickerInfo, -msg => lang("Color picker: last color picked by clicking\non the picture in the main window.\nPlease click to clear."));
$colorPickerInfo->bind('', sub {
$config{ColorPicker} = $conf{color_bg}{value};
$colorPickerInfo->configure(-background => $config{ColorPicker}); });
# thumbnail generator
my $nrTCL = $infoF->Label(-textvariable => \$nrToConvert, -relief => 'sunken', -foreground => $conf{color_menu_fg}{value})->pack(-side => 'left', -expand => 0, -fill => 'y');
$balloon->attach($nrTCL, -msg => lang("Number of thumbnails to generate/refresh"));
my $progressBar =
$infoF->ProgressBar(-takefocus => 0,
-borderwidth => 1,
-relief => 'sunken',
-width => (2*$config{FontSize}), # try to guess the height of the labels
-length => 30,
-padx => 0,
-pady => 0,
-variable => \$proccount,
-colors => [0 => $config{ColorProgress}],
-resolution => 1,
-blocks => $config{MaxProcs},
-anchor => 'w',
-from => 0,
-to => $config{MaxProcs}
)->pack(-side => 'left', -fill => 'both', -expand => 0, -padx => 0, -pady => 0);
$balloon->attach($progressBar, -msg => lang("Number of background processes\n(generating thumbnail pictures)"));
# clock or memory usage label
$clockL = $infoF->Label(-textvariable => \$time, -relief => 'sunken', -foreground => $conf{color_menu_fg}{value})->pack(-side => 'left', -fill => 'y');
$balloon->attach($clockL, -msg => \$date);
$clockL->bind('', sub { toggle(\$conf{clock_or_memory}{value}); showTimeOrMemory(); } );
# show thumbnails button
my $thumbscanvasbut = $infoF->Button(-image => $mapivi_icons{'Image'}, -command => sub {my @pics = $picLB->info('children');show_canvas_thumbs($c, \@pics);})->pack(-side => 'left', -fill => 'both', -expand => 0);
$balloon->attach($thumbscanvasbut, -msg => lang('Show thumbnails in picture frame'));
# JPEG comment box
my $commentText = $comF->Scrolled('ROText',
-scrollbars => 'oe',
-wrap => 'word',
-width => 200,
-height => $config{CommentHeight},
)->pack(-side => 'left', -fill => 'both', -expand => 1, -padx => 0, -pady => 0);
$balloon->attach($commentText, -msg => lang("Comment(s) of displayed picture"));
$picLB = makeThumbListbox($thumbF);
focus_on_enter($picLB);
# IPTC headline and caption edit box
my $titleF = $iptcF->Frame()->pack(-fill => 'both', -expand => 1);
my $capF = $iptcF->Frame()->pack(-fill => 'both', -expand => 1);
my $titleText;
my $captionText;
$titleF->Label(-text => 'Headline')->pack(-side => 'left', -fill => 'both');
$titleText = $titleF->Scrolled('Text',
-scrollbars => '',
-wrap => 'word',
-width => 20,
-height => 1,
)->pack(-side => 'left', -fill => 'both', -expand => 1);
$capF->Label(-text => 'Caption ')->pack(-side => 'left', -fill => 'both');
$captionText = $capF->Scrolled('Text',
-scrollbars => 'oe',
-wrap => 'word',
-width => 20,
-height => $config{CommentHeight},
)->pack(-side => 'left', -fill => 'both', -expand => 1);
{
my $common_text = lang("Add or edit text and then save it by pressing the save button.\nPress F4 to show or hide this box.");
$balloon->attach($titleText, -msg => lang("IPTC headline (title) of displayed picture.\n").$common_text);
$balloon->attach($captionText, -msg => lang("IPTC caption of displayed picture.\n").$common_text);
}
my $saveB = $capF->Button(-image => compound_menu($top, lang('Save'), 'media-floppy.png', 0),
-command => sub {
my $title = $titleText->get(0.1, 'end');
$title =~ s/\n+$//; # cut off trailing newline(s)
my $caption = $captionText->get(0.1, 'end');
$caption =~ s/\n+$//; # cut off trailing newline(s)
my $iptc = { 'Headline' => $title,
'Caption/Abstract' => $caption };
my @list;
my @sellist = getSelection($picLB);
if (!isInList($actpic, \@sellist)) {
my $selp = langf("%d pic(s)", scalar(@sellist));
my $actp = lang('actual');
my $cancel = lang('Cancel');
my $rc = $top->Dialog( -text => langf("The selection (%s) does not contain the actual picture (%s).",$selp, basename($actpic))."\n".lang("Add headline and caption to:"),
-title => lang("Add to selection or to actual picture?"),
-width => 50,
-buttons => [$selp, $actp, $cancel])->Show();
return if ($rc eq $cancel);
@list = @sellist if ($rc eq $selp);
@list = ($actpic) if ($rc eq $actp);
} elsif (scalar(@sellist) > 1) {
my $selp = scalar(@sellist).' selected';
my $actp = 'actual';
my $cancel = 'Cancel';
my $rc = $top->Dialog( -text => lang('Add headline and caption to:'),
-title => lang('Add to selection or to actual picture?'),
-width => 50,
-buttons => [$selp, $actp, $cancel])->Show();
return if ($rc eq $cancel);
@list = @sellist if ($rc eq $selp);
@list = ($actpic) if ($rc eq $actp);
} else {
@list = ($actpic);
}
applyIPTC($picLB, $iptc, \@list);
}
)->pack(-side => 'left', -fill => 'both');
$balloon->attach($saveB, -msg => lang("Save the IPTC headline and caption to the file and database.\nPlease press this button after adding or editing."));
#$captionText->Subwidget("scrolled")->bindtags([]);
#$captionText->Subwidget("scrolled")->bind('', sub {});
#->Subwidget("scrolled")
# item styles for the thumbnail view
my $thumbCaptionFont = $top->Font(-family => $config{FontFamily}, -size => $config{ThumbCaptFontSize});
# if changes are made here, other places may need an update too (see e.g. line containg "my $fileS2")
my $thumbS = $picLB->ItemStyle('imagetext', -anchor => 'w', -textanchor => 's', -foreground=>$conf{color_fg}{value}, -background=>$conf{color_bg}{value}, -font => $thumbCaptionFont);
my $fileS = $picLB->ItemStyle('image', -anchor=>'w', -foreground=>$config{ColorFile}, -background=>$conf{color_bg}{value});
my $iptcS = $picLB->ItemStyle('text', -anchor=>'nw', -foreground=>$config{ColorIPTC}, -background=>$conf{color_bg}{value});
my $comS = $picLB->ItemStyle('text', -anchor=>'nw', -foreground=>$config{ColorComm}, -background=>$conf{color_bg2}{value});
my $exifS = $picLB->ItemStyle('text', -anchor=>'nw', -foreground=>$config{ColorEXIF}, -background=>$conf{color_bg2}{value});
my $dirS = $picLB->ItemStyle('text', -anchor=>'nw', -foreground=>$config{ColorDir}, -background=>$conf{color_bg2}{value});
toggleHeaders();
# mouse and button bindings
# key-desc,double click,show picture in own window
$picLB->bind('', sub {
return if (!$picLB->info('children'));
showPicInOwnWin(getNearestItem($picLB)); } ); # does not always work ???
# key-desc,MiddleMouseButton,show picture in own window
$picLB->bind('', sub {
return if (!$picLB->info('children'));
showPicInOwnWin(getNearestItem($picLB));
} );
# experimental stuff
#$top->bind('', sub { print "Mouse Press But 4\n"; } );
#$top->bind('', sub { print "Mouse Press But 5\n"; } );
# this has to be done after the %keywords and %hot_keywords have been read in
add_nav_frame($nav_F);
# Drag-and-drop
# Define the source for drags.
# Picture drags are started while pressing left mouse button and moving the mouse
my $token;
# key-desc,LeftBut,(LeftMouseButton) drag and drop pictures to a folder
$token = $picLB->DragDrop
(-event => '', # drawback: no selection by dragging possible, but intuitive
#(-event => '', # drawback: difficult to use
-sitetypes => 'Local',
-startcommand => sub { dragFromPicLB($token) },
);
# Define the target for picture drops.
$dirtree->DropSite
(-droptypes => 'Local',
-dropcommand => sub { dropToDirTree(); },
);
# keyword tree drag and drop
{
my $keyword_token;
# key-desc,LeftBut,(LeftMouseButton) drag and drop keywords to picture
# drag from keyword tree
$keyword_token = $nav_F->{key_frame}->{tree}->DragDrop
(-event => '',
-sitetypes => 'Local',
-startcommand => sub { drag_keyword($nav_F->{key_frame}->{tree}, $keyword_token) },
);
# keyword clipboard (hotlist) drag and drop
$keyword_token = $nav_F->{key_frame}->{hot}->DragDrop
(-event => '',
-sitetypes => 'Local',
-startcommand => sub { drag_keyword($nav_F->{key_frame}->{hot}, $keyword_token); },
);
# Define the targets for keyword drops
# drop to canvas - actual picture
$c->DropSite
(-droptypes => 'Local',
-dropcommand => sub { print "drop site canvas tree\n"; drop_keyword($c, $keyword_token); },
);
# # drop to picLB - selected pictures in thumbnail list
$picLB->DropSite
(-droptypes => 'Local',
-dropcommand => sub { drop_keyword($picLB, $keyword_token); },
);
# drop to the keyword hotlist
$nav_F->{key_frame}->{hot}->DropSite
(-droptypes => 'Local',
-dropcommand => sub { drop_keyword($nav_F->{key_frame}->{hot}, $keyword_token); },
);
}
$picLB->bind('', sub {
# save button press coordinates to distinguish picture selection from picture dragging
($picLB->{lastx}, $picLB->{lasty}) = ($Tk::event->x(), $Tk::event->y());
#print "press: $picLB->{lastx}, $picLB->{lasty}\n";
# if mouse is pressed over an already selected item it may be a drag, so we ignore the press
#my @selection = $picLB->info('selection');
#if (isInList(getNearestItem($picLB), \@selection)) {
# print "pic is in list ignoring press\n";
# Tk->break;
# return;
#}
# saved here for undo function
@savedselection2 = @savedselection;
@savedselection = $picLB->info('selection');
} );
$picLB->bind('', sub { showSelectedPic(); } );
$picLB->bind('', sub {
if ($slideshow == 1) { $slideshow = 0; slideshow(); } # switch slideshow off
$thumbMenu->Popup(-popover => 'cursor', -popanchor => 'nw');
} );
# key-desc,Return,display the selected picture
$picLB->bind('', sub { showSelectedPic(); } );
$c->CanvasBind('', sub {
if ($slideshow == 1) { $slideshow = 0; slideshow(); } # switch slideshow off
$picMenu->Popup(-popover => "cursor", -popanchor => "nw");
} );
# we can't bind all keys to the complete window ($top) as we have e.g. the IPTC Caption entry which should get all key events
addWindowKeyBindings($dirtree, $picLB);
addWindowKeyBindings($nav_F->{loc_frame}, $picLB);
addWindowKeyBindings($nav_F->{date_frame}, $picLB);
addWindowKeyBindings($nav_F->{key_frame}, $picLB);
addWindowKeyBindings($nav_F->{cloud_frame}, $picLB);
addWindowKeyBindings($nav_F->{search_frame}, $picLB);
addWindowKeyBindings($picLB, $picLB);
addWindowKeyBindings($c, $picLB);
# 2011-03-30: attempt to remove problem that mapivi sometimes doesn't respond to key input in fullscreen- or only-picture-mode
# but this doesn't solve the problem, binding to $mainF doesn't help either
#addWindowKeyBindings($c->Subwidget('canvas'), $picLB);
addCommonKeyBindings($dirtree, $picLB);
addCommonKeyBindings($nav_F->{loc_frame}, $picLB);
addCommonKeyBindings($nav_F->{date_frame}, $picLB);
addCommonKeyBindings($nav_F->{key_frame}, $picLB);
addCommonKeyBindings($nav_F->{cloud_frame}, $picLB);
addCommonKeyBindings($nav_F->{search_frame}, $picLB);
addCommonKeyBindings($picLB, $picLB);
addCommonKeyBindings($c, $picLB);
$c->CanvasBind('', sub {
return unless defined $actpic;
return unless (-f $actpic);
log_it("Opening $actpic in new window");
showPicInOwnWin($actpic);
} );
# key-desc,d,display picture in own window
$picLB->bind('', sub {
my @sellist = getSelection($picLB);
return unless checkSelection($top, 1, 0, \@sellist, lang("picture(s)"));
show_multiple_pics(\@sellist, 0);
} );
$dirtree->bind('', sub {
my $dir = getRightDir();
my @list = getPics($dir, WITH_PATH, NO_CHECK_JPEG);
sortPics($config{SortBy}, $config{SortReverse}, \@list);
showThumbList(\@list, $dir); });
$dirtree->bind('', sub {
$dirtree->selectionClear();
$dirtree->selectionSet(getNearestItem($dirtree));
my $dir = getRightDir();
my @list = getPics($dir, WITH_PATH, NO_CHECK_JPEG);
sortPics($config{SortBy}, $config{SortReverse}, \@list);
showThumbList(\@list, $dir); });
# window resize event
#~ $top->bind("" => sub { print "top:Expose\n"; });
#~ $top->bind("" => sub {
#~ print "top:Configure\n";
# only if dock is selected
#return unless ($config{KeywordDialogDock});
# and the keyword dialog is open
#return unless (Exists($keyw));
#dock_keyword_dialog();
#});
# just a test for autosave (2012-01):
#$top->bind("" => sub { print "top:FocusIn\n"; });
#$top->bind("" => sub { print "top:FocusOut\n"; });
# support drag and drop from extern
# this enables dropping pictures and folders on the mapivi window
# 2009-10-22: Drag and drops from extern to Mapivi works under Windows XP but crashes under Ubuntu
# so it is now diabled for non-windows systems
if ($EvilOS) {
$dirtree->DropSite
(#-entercommand => sub { print "DragAndDrop - Entercommand\n";},
-dropcommand => [\&dragAndDropExtern, $dirtree],
-droptypes => 'Win32'
);
$picLB->DropSite
(-dropcommand => [\&dragAndDropExtern, $picLB],
-droptypes => 'Win32'
);
$c->DropSite
(-dropcommand => [\&dragAndDropExtern, $c],
-droptypes => 'Win32'
);
}
startup();
# show all types of images supported by Tk::Image
#my @types = $top->imageTypes;printlist(@types);
# Perl/Tk-Mainloop
$top->MainLoop;
# override the Motion sub of listbox (extended selection mode)
# seems not to help with the drag and drop problem
#sub Tk::HList::Motion {
#sub Tk::Listbox::Motion {
# return;
#}
##############################################################
# fill the conf hash with default values
##############################################################
sub configuration_set_default {
# this defines the order of the tabs in the configuration_edit dialog:
@conf_tab_order = qw(Main Metadata Thumbnails Tools Files Colors Extra);
# if an option should not been shown in the edit dialog use 'tab' => 'no'
# HINT!!!!!!
# when you change something here it may be overwritten with the content of the user setting
# so you may need to delete $conf_file ($user_data_path/mapivi_conf) first!
# or press the reset all options button in the options window
%conf = (
# Main tab #########
'folder_preview'
=> { 'value' => 1,
'kind' => 'bool',
'long' => lang('Folder preview'),
'tab' => 'Main',
'frame' => lang('Navigation'),
'info' => lang('Shows an animated folder preview using a thumbnail slideshow'),
'ord' => 2},
'show_canvas_thumbs'
=> { 'value' => 1,
'kind' => 'bool',
'long' => lang('Show thumbnails in picture frame'),
'tab' => 'Main',
'frame' => lang('Navigation'),
'info' => lang('Shows thumbnails in picture frame in square layout'),
'ord' => 4},
'filter_pics_button'
=> { 'value' => 0,
'kind' => 'bool',
'long' => 'Filter Pictures Button',
'tab' => 'Main',
'frame' => 'Navigation',
'info' => lang('Show filter by keywords button in thumbnail frame (needs restart).'),
'ord' => 6},
'show_clock'
=> { 'value' => 1,
'kind' => 'bool',
'long' => lang('Display a clock in the status bar'),
'tab' => 'Main',
'frame' => 'Display',
'ord' => 7},
'show_coordinates'
=> { 'value' => 0,
'kind' => 'bool',
'long' => "Display the coordinates of the mouse cursor in the status bar",
'tab' => 'Main',
'frame' => 'Display',
'ord' => 8},
'check_version_online'
=> { 'value' => 1,
'kind' => 'bool',
'long' => lang('Check for Mapivi updates'),
'tab' => 'Main',
'frame' => 'Behavior',
'info' => lang("Check at startup if a new Mapivi version is available.\nNeeds a internet connection."),
'ord' => 10},
'show_statistic'
=> { 'value' => 0,
'kind' => 'bool',
'long' => lang('Show database statistic on exit'),
'tab' => 'Main',
'frame' => 'Behavior',
'info' => lang("Show a statistic about the search database when Mapivi is closed."),
'ord' => 15},
# Metadata tab #########
'xmp_rating'
=> { 'value' => 1,
'kind' => 'bool',
'long' => 'Store rating in XMP',
'tab' => 'Metadata',
'info' => lang("Store picture rating not only in IPTC urgency, but also in XMP rating tag")."\n".convert_iptc_to_xmp_text(),
'ord' => 2},
'exif_plus'
=> { 'value' => 1,
'kind' => 'bool',
'long' => 'Display additional EXIF data',
'tab' => 'Metadata',
'info' => lang("Display detailed EXIF data like contrast, artist, white balance, focus distance, picture number, lens, ..."),
'ord' => 4},
'add_tool_info'
=> { 'value' => 0,
'kind' => 'bool',
'long' => 'Add tool information to processed pictures as JPEG comment',
'tab' => 'Metadata',
'info' => langf("If this is enabled Mapivi will add a JPEG comment\nto pictures which are created or processed by Mapivi.\nExample comment: \"Picture lossless cropped by Mapivi $version\""),
'ord' => 6},
# Thumbnails tab #########
# Tools tab #########
'external_pic_viewer'
=> { 'value' => 'display',
'kind' => 'file',
'long' => 'Picture viewer',
'tab' => 'Tools',
'frame' => 'Picture viewer',
'info' => lang("Enter the command to start the external picture viewer here.\nYou may also add options.\nExamles: \"gqview -f\", \"gthumb --fullscreen\", \"C:\\Program Files\\IrfanView\\iview_32.exe\""),
'ord' => 2},
'external_pic_viewer_multi'
=> { 'value' => 0,
'kind' => 'bool',
'long' => 'Viewer can handle multiple files',
'tab' => 'Tools',
'frame' => 'Picture viewer',
'info' => 'If the external picture viewer is able to handle multiple files enable this.
Example:
You have selected 3 pictures.
If this option is enabled one viewer will be started like this:
"viewer pic1.jpg pic2.jpg pic3.jpg",
if not 3 viewers will be started like this:
"viewer pic1.jpg" "viewer pic2.jpg" "viewer pic3.jpg".',
'ord' => 3},
'external_pic_editor'
=> { 'value' => 'gimp-remote',
'kind' => 'file',
'long' => 'Picture editor',
'tab' => 'Tools',
'info' => lang("Enter the command to start the external picture editor here.\nYou may also add options.\nExamples: \"gimp-remote\" for UNIX\n, \"gimp-win-remote gimp-2.6.exe\" for Windows and GIMP > 2.0\n, \"gimp-win-remote\" for Windows and GIMP <= 2.0"),
'ord' => 4},
'external_raw_editor'
=> { 'value' => 'darktable',
'kind' => 'file',
'long' => 'RAW editor',
'tab' => 'Tools',
'info' => lang("Enter the command to start the external RAW picture editor here.\nYou may also add options.\nExamples: \"darktable\" for UNIX.\nLeave field empty if the picture editor should be used for all kind of pictures."),
'ord' => 6},
'external_mail_tool'
=> { 'value' => 'thunderbird',
'kind' => 'file',
'long' => 'Mail tool',
'tab' => 'Tools',
'info' => lang("Enter the command to start the external mail tool here.\nExamles: \"thunderbird\", \"mozilla-thunderbird\", \"evolution\", \"icedove\", or\n\"C:\\Program Files\\Microsoft Office\\OFFICE11\\OUTLOOK.EXE\""),
'ord' => 7},
'web_browser'
=> { 'value' => 'firefox',
'kind' => 'file',
'long' => 'External web browser',
'tab' => 'Tools',
'info' => lang("Enter the command to start the external web browser here.\nExamples: \"firefox\""),
'ord' => 8},
'video_player'
=> { 'value' => 'vlc',
'kind' => 'file',
'long' => 'Video player',
'tab' => 'Tools',
'info' => lang("Enter the command to start an external video player.\nExamples: \"vlc\""),
'ord' => 10},
# Files tab #########
'media_folder_path'
=> { 'value' => '/media',
'kind' => 'dir',
'long' => 'Path to base folder for removable devices',
'tab' => 'Files',
'info' => lang("Enter the path to the folder used by the OS to mount removable devices,\nlike USB sticks or external HDD etc.\nFor Ubuntu use \"/media\"."),
'ord' => 2},
# Colors tab #########
'color_fg'
=> { 'value' => 'gray85',
'kind' => 'color',
'long' => 'Font color',
'tab' => 'Colors',
'ord' => 1},
'color_bg'
=> { 'value' => 'gray30',
'kind' => 'color',
'long' => 'Background color',
'tab' => 'Colors',
'ord' => 2},
'color_bg2'
=> { 'value' => 'gray30',
'kind' => 'color',
'long' => 'Background color 2',
'tab' => 'Colors',
'ord' => 3},
'color_bg_canvas'
=> { 'value' => 'gray30',
'kind' => 'color',
'long' => 'Canvas background color',
'tab' => 'Colors',
'ord' => 4},
'color_menu_bg'
=> { 'value' => 'gray40',
'kind' => 'color',
'long' => 'Menu background color',
'tab' => 'Colors',
'ord' => 10},
'color_hl_bg'
=> { 'value' => 'gray60',
'kind' => 'color',
'long' => 'Highlight background color',
'tab' => 'Colors',
'ord' => 15},
'color_act_bg'
=> { 'value' => 'gray60',
'kind' => 'color',
'long' => 'Active background color',
'tab' => 'Colors',
'ord' => 15},
'color_menu_fg'
=> { 'value' => 'gray90',
'kind' => 'color',
'long' => 'Menu font color',
'tab' => 'Colors',
'ord' => 20},
'color_entry'
=> { 'value' => 'gray60',
'kind' => 'color',
'long' => 'Entry color',
'tab' => 'Colors',
'ord' => 30},
# Extra tab #########
'origs_folder_name'
=> { 'value' => 'originals',
'kind' => 'string',
'long' => 'Folder name for originals',
'tab' => 'Extra',
'info' => lang("Name of sub folder to store original pictures"),
'ord' => 8},
# no tab - options not shown in the configuration editor #########
'filter_pics'
=> { 'value' => 0,
'kind' => 'bool',
'long' => 'Filter Pictures',
'tab' => 'no',
'info' => lang("If enabled this function will filter the pictures using a keyword list.")},
'filter_pics_keywords'
=> { 'value' => "Person.Family Bird Flower",
'kind' => 'string',
'tab' => 'no',
'info' => lang("filter pics by exclude keyword list (space separated string)"),
},
'import_source'
=> { 'value' => "/mnt/usb/DCIM/DIMG",
'kind' => 'dir',
'long' => lang('Import source'),
'tab' => 'no',
'info' => lang("Path to picture import folder")},
'iptc_geometry'
=> { 'value' => '800x600+1+1',
'kind' => 'string',
'long' => 'IPTC dialog window geometry',
'tab' => 'no'},
'search_rating_on'
=> { 'value' => 0,
'kind' => 'bool',
'long' => lang('Search rating constraint on/off'),
'tab' => lang('no')},
'search_rating_max'
=> { 'value' => 1,
'kind' => 'int',
'long' => lang('Search rating constraint maximum (also used for navigation rating)'),
'tab' => 'no'},
'search_rating_min'
=> { 'value' => 4,
'kind' => 'int',
'long' => lang('Search rating constraint minimum (also used for navigation rating)'),
'tab' => 'no'},
'nav_rating_on'
=> { 'value' => 0,
'kind' => 'bool',
'long' => lang('Navigation rating constraint on/off'),
'tab' => 'no'},
'search_format_on'
=> { 'value' => 0,
'kind' => 'bool',
'long' => lang('Search for pictures with a certain aspect ratio on/off'),
'tab' => 'no'},
'search_format'
=> { 'value' => 'landscape',
'kind' => 'string',
'long' => lang('Search for pictures with a certain aspect ratio'),
'tab' => 'no'},
'search_format_pano'
=> { 'value' => 0,
'kind' => 'bool',
'long' => lang('Search for pictures with a certain aspect ratio of 2 >= 1 (panorama format)'),
'tab' => 'no'},
'logo_text'
=> { 'value' => 'Mapivi',
'kind' => 'string',
'tab' => 'no'},
'logo_font'
=> { 'value' => 'Times_New-Roman',
'kind' => 'string',
'tab' => 'no'},
'logo_font_size'
=> { 'value' => 72,
'kind' => 'int',
'tab' => 'no'},
'logo_font_color'
=> { 'value' => 'black',
'kind' => 'string',
'tab' => 'no'},
'logo_shadow'
=> { 'value' => 1,
'kind' => 'bool',
'tab' => 'no'},
'logo_shadow_color'
=> { 'value' => 'gray50',
'kind' => 'string',
'tab' => 'no'},
'slideshow_random'
=> { 'value' => 1,
'kind' => 'bool',
'tab' => 'no'},
'slideshow_number_limit'
=> { 'value' => 0,
'kind' => 'bool',
'tab' => 'no'},
'slideshow_number'
=> { 'value' => 2,
'kind' => 'int',
'tab' => 'no'},
'slideshow_keywords_exclude'
=> { 'value' => 'dog cat landscape',
'kind' => 'string',
'tab' => 'no'},
'slideshow_keywords_include'
=> { 'value' => 'portrait',
'kind' => 'string',
'tab' => 'no'},
'slideshow_folders_exclude'
=> { 'value' => 'originals backup',
'kind' => 'string',
'tab' => 'no'},
'slideshow_pop_exclude'
=> { 'value' => 1,
'kind' => 'bool',
'tab' => 'no'},
'slideshow_pop_level'
=> { 'value' => 10,
'kind' => 'int',
'tab' => 'no'},
'slideshow_norating_exclude'
=> { 'value' => 0,
'kind' => 'bool',
'tab' => 'no'},
'slideshow_rating_exclude'
=> { 'value' => 1,
'kind' => 'bool',
'tab' => 'no'},
'slideshow_rating_level'
=> { 'value' => 4,
'kind' => 'int',
'tab' => 'no'},
'zoom_fit_fill'
=> { 'value' => FIT,
'kind' => 'int',
'tab' => 'no'},
'show_micro_meta'
=> { 'value' => 1,
'kind' => 'bool',
'tab' => 'no'},
'font_size_big'
=> { 'value' => 24,
'kind' => 'int',
'tab' => 'no'},
'animation' # move picture on canvas in show_multiple_pics()
=> { 'value' => 1,
'kind' => 'bool',
'tab' => 'no'},
'animation_steps'
=> { 'value' => 20,
'kind' => 'int',
'tab' => 'no'},
'animation_duration'
=> { 'value' => 0.25,
'kind' => 'float',
'tab' => 'no'},
'import_rotate_deg' # rotate pics when importing by this value
=> { 'value' => 'auto',
'kind' => 'string',
'tab' => 'no'},
'import_iptc_headline' # add IPTC headline when importing pics
=> { 'value' => 0,
'kind' => 'bool',
'tab' => 'no'},
'import_iptc_headline_content' # IPTC headline string
=> { 'value' => 'Event Headline',
'kind' => 'string',
'tab' => 'no'},
'clock_or_memory' # show 0=clock or 1=memory usage in top bar
=> { 'value' => 0,
'kind' => 'bool',
'tab' => 'no'},
);
# some platform specific default settings
# for windows
if ($EvilOS) {
$conf{external_pic_viewer}{value} = 'C:\Program Files\IrfanView\iview_32.exe';
$conf{external_pic_editor}{value} = 'gimp-win-remote gimp-2.6.exe';
$conf{web_browser}{tab} = 'no'; # not needed because we use "start"
}
# for Mac OS X
if ($MacOSX) {
$conf{external_pic_viewer}{value} = 'macosx-preview';
$conf{external_pic_viewer_multi}{value} = 1;
}
}
##############################################################
# search and return a list of existing languages (e.g. ('de', 'en', 'fr'))
# in the given directory
##############################################################
sub languages_find {
my $path = shift;
my @languages;
foreach my $file (getFiles($path)) {
# check if the filename matches mapivi-lang-XX (XX is in ISO 639-1 format, see e.g. http://en.wikipedia.org/wiki/Iso_639-1 or http://de.wiktionary.org/wiki/Hilfe:Sprachcodes)
if ($file =~ m|^mapivi-lang-(.+)$|) {
# store the language
push @languages, $1;
}
}
return @languages;
}
##############################################################
# the language files can be edited with any text editor and
# define the hash %messages. In this hash the keys are the
# English strings as written in the mapivi.pl code to be translated
# and the values are the translated strings
##############################################################
sub language_load {
my $fh;
my $language = shift;
# special treatment for en = english
if ($language eq 'en') {
# as Mapivi is written in english we need no language file and reset the messages hash
undef %messages;
return;
}
my $file = "$lang_path/mapivi-lang-$language";
#use utf8;
if (!open($fh, '<', $file)) {
warn langf("Open language file: Couldn't open $file: $!");
return;
}
my @lines = <$fh>;
close($file);
# execute language file to define %messages hash
# executing code is always dangerous, but we trust it here.
# "no critic" disables perlcritic for this line
eval "@lines"; ## no critic (ProhibitStringyEval);
warn langf("Failed to evaluate language file $file:\n$@\n") if ($@);
return;
}
##############################################################
# check at startup if a new Mapivi version is available
# this is done by trying to open a text file on the mapivi web page and comparing the version number
##############################################################
# todo: this could maybe also be used to track the number of users/session???
sub check_version {
return if (not $conf{check_version_online}{value});
my $version = shift;
use LWP::Simple;
my $actual_version = get('http://mapivi.sourceforge.net/actual_version.txt');
if (defined $actual_version) {
if ($actual_version+0 > $version+0) { # force numeric context (+0)
print langf(" A newer version of Mapivi is available (V%s), see http://mapivi.sourceforge.net/\n", $actual_version);
}
elsif ($actual_version+0 == $version+0) { # force numeric context (+0)
print langf(" Mapivi %s is up-to-date!\n", $version);
}
}
else {
print lang(" Could not check actual Mapivi version. No internet connection.\n");
}
}
##############################################################
# Scan Mapivi code for lang() and langf() calls
##############################################################
sub language_scan {
my $file;
# open the file mapivi
if (!open($file, '<', $0)) {
warn langf("Could not open $0 for read access!: $!");
return;
}
my @lines = <$file>; # read the complete file into the array lines
close $file;
# make a copy of the existing messages to find out unused (outdated) messages
my %tmp_messages = %{ dclone(\%messages) };
my $found = "%messages = (\n";
my $not_found = "%messages = (\n";
#my @messages;
my $line_nr = 0;
foreach my $line (@lines) {
$line_nr++;
$line =~ s/\s+$//; # cut trailing whitespace
$line =~ s/^\s+//; # cut leading whitespace
# look for lines containing "lang()" .*? -> the question mark switches to ungreedy matching
if ($line =~ m/.*lang\(["'](.*?)["']\).*/) {
#push @messages, $line;
print langf("Found: $line\n $1\n");
if (exists $messages{$1}) {
print langf(" Found in hash: $messages{$1}\n");
$found .= "\"$1\" => \"$messages{$1}\",\t\t\t# line $line_nr\n";
# delete each key in the temp hash when it is used at least once
delete $tmp_messages{$1} if (exists $tmp_messages{$1});
}
else {
print lang(" Not found in hash\n");
$not_found .= "\"$1\" => \"\",\t\t\t# line $line_nr\n";
}
}
}
my $unused = "%messages = (\n";
foreach (keys %tmp_messages) {
$unused .= "\"$_\" => \"$tmp_messages{$_}\",\n";
}
showText(langf("Existing and used tranlations in language: $config{Language}"), $found, NO_WAIT);
showText(langf("Missing translations for language: $config{Language}"), $not_found, NO_WAIT);
showText(langf("Existing but unused translations in language: $config{Language}"), $unused, NO_WAIT);
return;
}
##############################################################
# Return a language dependent version of $msg.
# based on M() from Msg.pm from Slaven Rezic (BBBike)
##############################################################
sub lang {
my $msg = shift;
$msg = $messages{$msg} if (exists $messages{$msg});
return $msg;
}
##############################################################
# Return a language dependent version of $msg.
# based on Mfmt() from Msg.pm from Slaven Rezic (BBBike)
##############################################################
sub langf {
return sprintf lang(shift), @_;
}
##############################################################
##############################################################
sub log_it {
my $text = shift;
# do not store picture coordinates
if ($text !~ m/^coordinates: .*/) {
my $time_stamp = getDateTimeISOString(time());
# save to global log
$global_log .= "\n$time_stamp: $text";
# show in log window if it is opened
if (Exists($top->{log_box})) {
$top->{log_box}->insert('end', "\n$time_stamp: $text"); # insert new text at end after timestamp
$top->{log_box}->see('end');
}
}
if (Exists($userInfoL)) {
$userinfo = $text;
}
else { # fallback solution during startup, the userInfoL label may not be available
print "log_it: $text\n";
}
return;
}
##############################################################
# find the users home directory
##############################################################
sub get_home_path {
my $home = glob("~");
if ($EvilOS) {
$home = $ENV{"USERPROFILE"};
$home = $ENV{HOME} if ((not -d $home) and (defined $ENV{HOME}));
$home = $ENV{HOMEDRIVE}.$ENV{HOMEPATH} if ((not -d $home) and (defined $ENV{HOMEDRIVE} and defined $ENV{HOMEPATH}));
$home = "C:/" if (!-d $home);
$home =~ s!\\!\/!g; # replace Windows path delimiter with UNIX style \ -> /
}
return $home;
}
##############################################################
# determine the path to store the user data
##############################################################
sub get_user_data_path {
my $home = shift;
my $user_data_path = "$home/.mapivi";
if ($EvilOS and defined $ENV{APPDATA}) {
# for windows we use this path
$user_data_path = $ENV{APPDATA}."/Mapivi";
}
# if the environment variable MAPIVIUSERDATAPATH is set to an existing folder
# Mapivi will use this folder to store all configuration files
# This feature may e.g. be used to separate private and business pictures or to keep different keyword trees
# usage in Linux with bash shell:
# set the env variable: export MAPIVIUSERDATAPATH=/home/username/.mapivi-private
# to check the variable: echo $MAPIVIUSERDATAPATH
# usage in Windows with DOS box:
# set the env variable: set MAPIVIUSERDATAPATH=C:\temp\mapivi-office
# to check the variable: echo %MAPIVIUSERDATAPATH%
if (defined $ENV{MAPIVIUSERDATAPATH} and $ENV{MAPIVIUSERDATAPATH} ne '') {
if (-d $ENV{MAPIVIUSERDATAPATH}) {
$user_data_path = $ENV{MAPIVIUSERDATAPATH};
print langf(" Mapivi info: Using folder:\n \"$user_data_path\"\n as set in environment variable MAPIVIUSERDATAPATH.\n");
}
else {
print langf(" Mapivi info: Environment variable MAPIVIUSERDATAPATH is set to\n \"$ENV{MAPIVIUSERDATAPATH}\".\n This folder does not exist, please create it before starting Mapivi.\n Mapivi will now use the default folder:\n \"$user_data_path\".\n");
}
}
$user_data_path =~ s!\\!\/!g; # replace Windows path delimiter with UNIX style \ -> /
return $user_data_path;
}
##############################################################
# stillBusy - block some keys, untill loading of pictures is finished
##############################################################
sub stillBusy {
if ($showPicInAction) {
beep();
log_it(lang('Busy (loading pic), please retry later'));
return 1;
}
return 0;
}
##############################################################
# show short information in borderless window
# window will close itself after given time
##############################################################
sub info_window {
my $w = shift; # parent widget ref
my $text = shift; # text to display in window
my $timeout = shift; # optional, time in ms
return if not $w;
eval { $w->ismapped }; # check if widget is available w/o causing error message
return if ($@);
return if ((not defined $text) or ($text eq ''));
$timeout = 1000 if (not $timeout); # default timeout is 1 second
# open info window
my $win = $w->Toplevel(-bg => 'gray');
$win->Label(-text => $text, -fg => 'black', -bg => 'white', -bd => 2)->pack(-side => 'top', -padx => 2, -pady => 2);
# no window decoration/border
$win->overrideredirect(1);
# center window above widget
$win->Popup(-popover => $w, -overanchor => 'c', -popanchor => 'c');
# close window after $timeout msec
my $timer;
$timer = $w->after($timeout, sub {
$win->destroy() if Exists($win);
$timer->cancel if ($timer);
});
return;
}
##############################################################
##############################################################
sub folder_preview_start {
return if (not $conf{folder_preview}{value});
my $top = shift; # parent widget ref
my $folder = shift; # folder with pictures to preview
return unless -d $folder;
my @pics = getPics($folder, WITH_PATH, NO_CHECK_JPEG);
filter_pics(\@pics, $conf{filter_pics_keywords}{value});
return unless (@pics);
# show best rated pictures first
sortPics('urgency', 0, \@pics);
# open preview window
my $win = $top->Toplevel();
$win->Label(-text => scalar @pics." ".lang('Pictures'))->pack(-side => 'top', -padx => 0, -pady => 0);
$win->{CANVAS} = $win->Canvas(-width => $config{ThumbSize},
-height => $config{ThumbSize})->pack(-side => 'top', -padx => 0, -pady => 0);
# no window decoration/border
$win->overrideredirect(1);
# store window reference in top for cancel function
$top->{FOLDER_PREVIEW_WIN} = $win;
$win->{FOLDER_PREVIEW_PICS} = \@pics;
$win->{PIC_INDEX} = 0; # start with index 0 in list
$win->Popup(-popover => 'cursor');
# move window 100 pixels to the right
my $geo = $win->geometry;
my ($w, $h, $x, $y) = splitGeometry($geo);
$x += 100;
$win->geometry($w . 'x' . $h . "+" . $x . "+" . $y);
# preview first picture/thumbnail
folder_preview_next($win);
my $update_period = 500; #[msec]
# after $update_period msec show next thumbnail ..
$top->{FOLDER_PREVIEW_TIMER} = $top->repeat($update_period, sub {
folder_preview_next($win);
});
return;
}
##############################################################
##############################################################
sub folder_preview_next {
my $win = shift;
my @pics = @{$win->{FOLDER_PREVIEW_PICS}};
my $index = $win->{PIC_INDEX};
my $dpic = $pics[$index];
if (-f $dpic) {
my $thumb = getThumbFileName($dpic);
if (-f $thumb) {
my $photo = $top->Photo(-file => $thumb, -gamma => $config{Gamma});
$win->{CANVAS}->createImage(0,0, -image => $photo, -anchor => 'nw');
}
}
$index++;
# repeat when finished with all pictures
$index = 0 if ($index >= @pics);
$win->{PIC_INDEX} = $index;
return;
}
##############################################################
##############################################################
sub folder_preview_cancel {
# todo: delete photo object after usage!!!
# but this doesn't work - gives an "error: image image457 doesn't exists ,..."
#if (defined $folder_preview_photo) { $folder_preview_photo->delete; print "cancel:: folder_preview_photo defined \n";}
$top->{FOLDER_PREVIEW_WIN}->destroy() if Exists($top->{FOLDER_PREVIEW_WIN});
$top->{FOLDER_PREVIEW_TIMER}->cancel if ($top->{FOLDER_PREVIEW_TIMER});
return;
}
##############################################################
##############################################################
sub add_nav_frame {
my $w = shift;
# rating constraint frame
# Warning: must be defined in front of the NoteBook, else it won't be visible!!!!
my $r_frame = $w->Frame(-bd => 0)->pack(-expand => 1, -side => 'bottom', -fill =>'x', -padx => 0, -pady => 0);
$w->{rating_frame} = add_rating_constraint($r_frame);
# navigation frame
my $nav_tab =
$w->NoteBook(-width => 40,
-background => $conf{color_bg}{value}, # background of active page (including its tab)
-inactivebackground => $conf{color_entry}{value}, # tabs of inactive pages
-backpagecolor => $conf{color_bg}{value}, # background behind notebook
-tabpadx => 0, -tabpady => 0
)->pack(-expand => 1, -fill => 'both', -padx => 3, -pady => 3);
$w->{nav_tab} = $nav_tab;
####################
# folder navigation
$w->{dir_frame} = $nav_tab->add('dir', -image => $mapivi_icons{'Folder'}, -raisecmd => sub {
$w->{rating_frame}->packForget if ($w->{rating_frame}->ismapped);
$r_frame->configure(-height => 0);
log_it(lang("Navigation by folders"));});
$dirtree = add_dir_tree($w->{dir_frame});
focus_on_enter($dirtree);
# folder preview with thumbnail animation - attached to the dirtree
$balloon->attach($dirtree, -balloonposition => 'mouse',
-motioncommand => sub {folder_preview_cancel(); return 0;},
-cancelcommand => sub {folder_preview_cancel(); return 0;},
-postcommand => sub {my $folder = getNearestItem($dirtree); folder_preview_start($top, $folder); return 0;}, -msg => "Nav dirtree balloon");
####################
# keyword tree navigation + add + edit
$w->{key_frame} = $nav_tab->add('key', -image => $mapivi_icons{'Keyword'}, -raisecmd => sub {
$w->{rating_frame}->pack(-in => $r_frame, -fill =>'x', -padx => 3, -pady => 1) if (!$w->{rating_frame}->ismapped);
log_it(lang('Navigation by keyword'));});
add_key_tree($w->{key_frame}, $picLB);
####################
# keyword cloud navigation
$w->{cloud_frame} = $nav_tab->add('cloud', -image => $mapivi_icons{'Keyword-Cloud'}, -raisecmd => sub {
$w->{rating_frame}->pack(-in => $r_frame, -fill =>'x', -padx => 3, -pady => 1) if (!$w->{rating_frame}->ismapped);
log_it(lang('Navigation by keyword cloud'));
add_key_cloud($w->{cloud_frame}, $picLB) unless (Exists($w->{cloud_frame}->{canvas}));});
####################
# picture searching
$w->{search_frame} = $nav_tab->add('search', -image => $mapivi_icons{'Search'}, -raisecmd => sub {
$w->{rating_frame}->pack(-in => $r_frame, -fill =>'x', -padx => 3, -pady => 1) if (!$w->{rating_frame}->ismapped);
log_it(lang('Picture search'));
my $keys = keys %searchDB;
$w->{search_frame}->{labelw}->configure(-text => langf("%d pictures in database", $keys));});
add_search_frame($w->{search_frame});
####################
# location navigation + add
$w->{loc_frame} = $nav_tab->add('loc', -image => $mapivi_icons{'Location'},
-raisecmd => sub {
$w->{rating_frame}->pack(-in => $r_frame, -fill =>'x', -padx => 3, -pady => 1) if (!$w->{rating_frame}->ismapped);
log_it(lang('Navigation by location'));
if (!$w->{loc_frame}->{tree}->info('children')){
# get all location info from the database (IPTC tags: country, state, city and sublocation) including pictures
my %loc_hash = get_locations(UPDATE);
insert_in_tree(LOCATION, $w->{loc_frame}->{tree}, \%loc_hash);
}
});
add_location_tree($w->{loc_frame}, $picLB);
####################
# date navigation
$w->{date_frame} = $nav_tab->add('date', -image => $mapivi_icons{'Date'},
-raisecmd => sub {
$w->{rating_frame}->pack(-in => $r_frame, -fill =>'x', -padx => 3, -pady => 1) if (!$w->{rating_frame}->ismapped);
log_it(lang('Navigation by date'));
if (!$w->{date_frame}->{tree}->info('children')){
# get all dates from the database, if not already done
my %date_hash = get_dates(UPDATE);
insert_in_tree(DATE, $w->{date_frame}->{tree}, \%date_hash);
}
});
add_date_tree($w->{date_frame}, $picLB);
####################
# picture collections / slideshow navigation
$w->{collection_frame} = $nav_tab->add('collection', -image => $mapivi_icons{'Image'},
-raisecmd => sub {
$w->{rating_frame}->packForget if ($w->{rating_frame}->ismapped);
log_it(lang('Navigation by picture collection'));
if (!$w->{collection_frame}->{tree}->info('children')){
insert_collections_in_tree($w->{collection_frame}->{tree}, \%slideshows);
}
});
add_collection_tree($w->{collection_frame}, $picLB);
# Set the initial folder
exists &Tk::DirTree::chdir ? $dirtree->chdir($actdir) : $dirtree->set_dir($actdir);
$dirtree->bind('', sub {
$dirMenu->Popup(-popover => 'cursor', -popanchor => 'nw');
} );
my $dtr = $dirtree->Subwidget('scrolled');
# change the binding order of the dirtree
$dtr->bindtags([$dtr,ref $dtr,$dtr->toplevel,'all']);
# stop the execution of the space key
$dtr->bind('', sub { Tk->break; });
}
##############################################################
# define some icons
##############################################################
sub define_icons {
# mapping of icon names to file names
my %files = (
'Folder' => 'folder-big.png',
'Keyword' => 'dialog-password-big.png', #'preferences-desktop-font-big.png',
'Location' => 'internet-web-browser-big.png',
'Keyword-Cloud' => 'weather-overcast-big.png',
'Date' => 'office-calendar-big.png',
'Search' => 'system-search-big.png',
'Update' => 'view-refresh-big.png',
'UpdateS' => 'view-refresh.png',
'Back' => 'go-previous.png',
'GoPrevious' => 'go-previous-big.png',
'GoFirst' => 'go-first-big.png',
'GoLast' => 'go-last-big.png',
'GoUp' => 'go-up-big.png',
'GoTop' => 'go-top-big.png',
'GoBottom' => 'go-bottom-big.png',
'MediaStop' => 'media-playback-stop-big.png',
'Clear' => 'edit-clear.png',
'Show' => 'edit-redo.png',
'Rating1' => 'rating-1.png',
'Rating2' => 'rating-2.png',
'Rating3' => 'rating-3.png',
'Rating4' => 'rating-4.png',
'Rating5' => 'rating-5.png',
'Rating6' => 'rating-6.png',
'Rating7' => 'rating-7.png',
'Rating8' => 'rating-8.png',
'Rating0' => 'rating-0.png',
'Stop' => 'process-stop.png',
'Help' => 'help-browser22.png',
'Plus' => 'list-add.png',
'PlusBig' => 'list-add-big.png',
'Minus' => 'list-remove.png',
'Frame-bw' => 'frame-bw.png',
'Frame-wb' => 'frame-wb.png',
'Frame-bwp' => 'frame-bwp.png',
'Frame-wbp' => 'frame-wbp.png',
'EmptyThumb' => 'EmptyThumb.jpg',
'Preferences' => 'preferences-system.png',
'FlagRed' => 'media-record16-red.png',
'FlagGreen' => 'media-record16-green.png',
'FlagBlue' => 'media-record16-blue.png',
'Image' => 'image-x-generic22.png',
'Editor' => 'accessories-text-editor22.png',
'Trash' => 'user-trash22.png',
'Save' => 'media-floppy-big.png',
#'Fullscreen' => 'view-fullscreen-big.png',
#'Slideshow' => 'x-office-presentation-big.png',
);
my %icons;
my $error = '';
foreach my $name (keys %files) {
my $icon_file = "$icon_path/$files{$name}";
if (-f $icon_file) {
$icons{$name} = $top->Photo(-file => $icon_file);
}
else {
$error .= langf("File %s used as %s icon is missing.\n", $icon_file, $name);
}
}
if ($error ne '') {
print langf("Errors during Mapivi startup:\n%s\n\nPlease copy the needed icons to %s and restart Mapivi.\n", $error, $icon_path);
die;
}
return %icons;
}
##############################################################
# makeThumbListbox - create a scrolled HList for thumbnail display
##############################################################
sub makeThumbListbox {
my $widget = shift;
my $lb = $widget->Scrolled('HList',
-header => 1,
-separator => ';', # todo here we hope that ; will never be in a folder or file name
-pady => 0,
-columns => 6,
-scrollbars => 'osoe',
-selectmode => 'extended',
-background => $conf{color_bg}{value},
-width => 30,
-height => 200,
)->pack(-expand => 1, -fill => 'both');
my $colNr = 0;
if ($resizeAvail) {
my $thumbH = $lb->ResizeButton(-text => 'Thumbnail',
-relief => 'flat', -pady => 0,-anchor => 'w',
-widget => \$lb, -column => $colNr);
$lb->{thumbcol} = $colNr;
$lb->header('create', $colNr++, -itemtype => 'window', -widget => $thumbH, -headerbackground => $conf{color_entry}{value});
my $sizeH = $lb->ResizeButton(-text => lang('File'),
-relief => 'flat', -pady => 0,-anchor => 'w',
-command => sub {
return unless ($lb == $picLB);
if ($config{SortBy} eq 'name') {
toggle(\$config{SortReverse});
} else {
$config{SortReverse} = 0;
}
$config{SortBy} = 'name';
updateThumbsPlus(); },
-widget => \$lb, -column => $colNr);
$lb->{filecol} = $colNr;
$lb->header('create', $colNr++, -itemtype => 'window', -widget => $sizeH, -headerbackground => $conf{color_entry}{value});
my $iptcH = $lb->ResizeButton(-text => 'IPTC',
-relief => 'flat', -pady => 0,-anchor => 'w',
-command => sub {
return unless ($lb == $picLB);
if ($config{SortBy} eq 'urgency') {
toggle(\$config{SortReverse});
} else {
$config{SortReverse} = 0;
}
$config{SortBy} = 'urgency';
updateThumbsPlus(); },
-widget => \$lb, -column => $colNr);
$lb->{iptccol} = $colNr;
$lb->header('create', $colNr++, -itemtype => 'window', -widget => $iptcH, -headerbackground => $conf{color_entry}{value});
my $comH = $lb->ResizeButton(-text => lang('Comments'),
-relief => 'flat', -pady => 0,-anchor => 'w',
-widget => \$lb, -column => $colNr);
$lb->{comcol} = $colNr;
$lb->header('create', $colNr++, -itemtype => 'window', -widget => $comH, -headerbackground => $conf{color_entry}{value});
my $exifH = $lb->ResizeButton(-text => 'EXIF',
-relief => 'flat', -pady => 0,-anchor => 'w',
-command => sub {
return unless ($lb == $picLB);
$config{SortBy} = 'exifdate';
toggle(\$config{SortReverse});
updateThumbsPlus(); },
-widget => \$lb, -column => $colNr);
$lb->{exifcol} = $colNr;
$lb->header('create', $colNr++, -itemtype => 'window', -widget => $exifH, -headerbackground => $conf{color_entry}{value});
my $dirH = $lb->ResizeButton(-text => lang('Folder'),
-relief => 'flat', -pady => 0,-anchor => 'w',
-command => sub {
return unless ($lb == $picLB);
if ($config{SortBy} eq 'name') {
toggle(\$config{SortReverse});
} else {
$config{SortReverse} = 0;
}
$config{SortBy} = 'name';
updateThumbsPlus(); },
-widget => \$lb, -column => $colNr);
$lb->{dircol} = $colNr;
$lb->header('create', $colNr, -itemtype => 'window', -widget => $dirH, -headerbackground => $conf{color_entry}{value});
}
else { # no resizeAvail
$lb->{thumbcol} = $colNr;
$lb->header('create', $colNr++, -text => 'Thumbnail', -headerbackground => $conf{color_entry}{value});
#$lb->{namecol} = $colNr;
#$lb->header('create', $colNr++, -text => 'Name', -headerbackground => $conf{color_entry}{value});
$lb->{filecol} = $colNr;
$lb->header('create', $colNr++, -text => lang('File'), -headerbackground => $conf{color_entry}{value});
$lb->{iptccol} = $colNr;
$lb->header('create', $colNr++, -text => 'IPTC', -headerbackground => $conf{color_entry}{value});
$lb->{comcol} = $colNr;
$lb->header('create', $colNr++, -text => lang('Comments'), -headerbackground => $conf{color_entry}{value});
$lb->{exifcol} = $colNr;
$lb->header('create', $colNr++, -text => 'EXIF', -headerbackground => $conf{color_entry}{value});
$lb->{dircol} = $colNr;
$lb->header('create', $colNr, -text => lang('Folder'), -headerbackground => $conf{color_entry}{value});
}
return $lb;
}
##############################################################
# addWindowKeyBindings - add key shortcuts to a widget
##############################################################
sub addWindowKeyBindings {
my $bind_w = shift; # widget to bind keys to
my $lb_w = shift; # thumbnail listbox to use
# key-desc,b,show backup or original picture (if available)
$bind_w->bind('', sub { showBackup(); });
# key-desc,w,show window list
$bind_w->bind('', sub { showWindowList(); });
#$bind_w->bind('', sub { rebuildThumbs(); } );
# key-desc,Ctrl-s,advanced search in database
$bind_w->bind('', sub { searchMetaInfo(); } );
# key-desc,Ctrl-f,find pictures (advanced search in database)
$bind_w->bind('', sub { searchMetaInfo(); } );
# key-desc,k,search by keyword (tag cloud)
$bind_w->bind('', sub { keyword_browse(); } );
# key-desc,o,open a new folder
$bind_w->bind('', sub { openDir(); } );
# key-desc,h,show hot folders
$bind_w->bind('', sub { $dirMenu->Popup(-popover => "cursor", -popanchor => "nw"); } );
# key-desc,u,update (# and Image)
$bind_w->bind('', sub { updateThumbsPlus(); } );
# key-desc,m,open folder of current picture
$bind_w->bind('', sub { open_pic_folder($picLB); } );
# key-desc,F05,smart update (add new and remove deleted images)
$bind_w->bind('', sub { smart_update(); } );
# key-desc,U,update image
$bind_w->bind('', sub {
deleteCachedPics($actpic);
showPic($actpic);
} );
# layouts
# key-desc,Ctrl-l,toggle layout of folder thumbnail and picture frame
$bind_w->bind('', sub { $config{Layout}++; layout(1); } );
# key-desc,F01,toggle show menu bar
$bind_w->bind('', sub { toggle(\$config{ShowMenu}); showHideFrames(); } );
# key-desc,F02,toggle show status bar
$bind_w->bind('', sub { toggle(\$config{ShowInfoFrame}); showHideFrames(); } );
# key-desc,F03,toggle overlay information (EXIF, IPTC, ...)
$bind_w->bind('', sub { toggle(\$config{ShowInfoInCanvas}); showImageInfoCanvas($actpic); } );
# key-desc,F04,toggle show comment box
$bind_w->bind('', sub { toggle(\$config{ShowIPTCFrame}); showHideFrames(); } );
# key-desc,F06,layout 0: folders-thumbnails-picture (25-30-45)
$bind_w->bind('', sub { $config{Layout} = 0 ; layout(1);} );
# key-desc,F07,layout 1: folders-thumbnails (20-80-0)
$bind_w->bind('', sub { $config{Layout} = 1 ; layout(1);} );
# key-desc,F08,layout 2: thumbnails (0-100-0)
$bind_w->bind('', sub { $config{Layout} = 2 ; layout(1);} );
# key-desc,F09,layout 3: thumbnails-picture (0-50-50)
$bind_w->bind('', sub { $config{Layout} = 3 ; layout(1);} );
# key-desc,F10,layout 4: picture (0-0-100)
$bind_w->bind('', sub { $config{Layout} = 4 ; layout(1); Tk->break; # stop default binding of this key
} );
# key-desc,F11,fullscreen mode
$bind_w->bind('', sub { fullscreen($top); });
# key-desc,Delete,delete selected pictures to trash
$bind_w->bind('', sub { deletePics($lb_w, TRASH); } );
# key-desc,Shift-Delete,remove selected pictures
$bind_w->bind('', sub { deletePics($lb_w, REMOVE); } );
# key-desc,Ctrl-q,quit mapivi
$bind_w->bind('', sub { quitMain(); } );
# key-desc,Ctrl-r,smart rename selected pictures (e.g to EXIF date)
$bind_w->bind('', sub { renameSmart($lb_w); } );
# key-desc,F12,quit mapivi
$bind_w->bind('', sub { quitMain(); } );
# show picture, EXIF, Comment and IPTC info
# key-desc,c,display JPEG comment
$bind_w->bind('', sub { showComment(); } );
# key-desc,Ctrl-t,display embedded EXIF thumbnail
$bind_w->bind('', sub { showEXIFThumb(); } );
# key-desc,Ctrl-v,toggle verbose output
$bind_w->bind('', sub { toggle(\$verbose); log_it("verbose switched to $verbose");} );
# key-desc,Ctrl-c,crop (lossless)
$bind_w->bind('', sub { crop($lb_w); } );
# key-desc,Ctrl-b,add border and/or copyright
$bind_w->bind('', sub { losslessBorder(PIXEL); } );
# key-desc,Ctrl-d,change EXIF date/time
$bind_w->bind('', sub { setEXIFDate(); } );
# key-desc,Q,change size/quality
$bind_w->bind('', sub { changeSizeQuality(); } );
# key-desc,Ctrl-o,open options dialog
$bind_w->bind('', sub { options_edit(); } );
# key-desc,Ctrl-m,move pictures to originals sub folder
$bind_w->bind('', sub { copy_move_to_origs($lb_w, MOVE); } );
# key-desc,Ctrl-e,edit picture in external edior (e.g. GIMP)
$bind_w->bind('', sub { edit_pic($lb_w); } );
# key-desc,H,display picture histogram
$bind_w->bind('', sub { showHistogram($lb_w); });
# key-desc,9,rotate picture(s) 90 degrees clockwise
$bind_w->bind('', sub { rotate(90); });
# key-desc,8,rotate picture(s) 180 degrees clockwise
$bind_w->bind('', sub { rotate(180); });
# key-desc,7,rotate picture(s) 270 degrees clockwise
$bind_w->bind('', sub { rotate(270); });
# key-desc,0,auto rotate picture(s) (EXIF orientation)
$bind_w->bind('', sub { rotate("auto"); });
# key-desc,Escape,iconify the main window/close any other window
$bind_w->bind('', sub { $top->iconify; } );
# thumbnail navigation
# key-desc,Space,display the next picture
$bind_w->bind('', sub {
return if (stillBusy()); # block, until last picture is loaded
if ($slideshow == 1) { $slideshow = 0; slideshow(); } # switch slideshow off
showPic(nextPic($actpic));
} );
# key-desc,S,display the next selected picture
$bind_w->bind('', sub {
return if (stillBusy()); # block, until last picture is loaded
if ($slideshow == 1) { $slideshow = 0; slideshow(); } # switch slideshow off
my @sellist = $lb_w->info('selection');
showPic(nextSelectedPic($actpic));
reselect($lb_w, @sellist);
} );
# key-desc,Page-Down,display the next picture
$bind_w->bind('', sub {
return if (stillBusy()); # block, until last picture is loaded
if ($slideshow == 1) { $slideshow = 0; slideshow(); } # switch slideshow off
showPic(nextPic($actpic));} );
# key-desc,Backspace,display the previous picture
$bind_w->bind('', sub {
return if (stillBusy()); # block, until last picture is loaded
if ($slideshow == 1) { $slideshow = 0; slideshow(); } # switch slideshow off
showPic(prevPic($actpic));} );
# key-desc,Page-Up,display the previous picture
$bind_w->bind('', sub {
return if (stillBusy()); # block, until last picture is loaded
if ($slideshow == 1) { $slideshow = 0; slideshow(); } # switch slideshow off
showPic(prevPic($actpic));} );
# key-desc,Home,display the first picture
$bind_w->bind('', sub {
return if (stillBusy()); # block, until last picture is loaded
if ($slideshow == 1) { $slideshow = 0; slideshow(); } # switch slideshow off
my @childs = $lb_w->info('children');
return unless (@childs);
showPic($childs[0]); } );
# key-desc,End,display the last picture
$bind_w->bind('', sub {
return if (stillBusy()); # block, until last picture is loaded
if ($slideshow == 1) { $slideshow = 0; slideshow(); } # switch slideshow off
my @childs = $lb_w->info('children');
return unless (@childs);
showPic($childs[-1]);
});
# key-desc,Ctrl-g,set GPS coordinates
$bind_w->bind('', sub { gps_set($lb_w); } );
# key-desc,s,start/stop slideshow
$bind_w->bind('', sub {
if ($slideshow == 0) { $slideshow = 1; } else { $slideshow = 0; }
slideshow();
} );
# key-desc,-,zoom out or faster slideshow
$bind_w->bind('', sub {
if ($slideshow) {
$config{SlideShowTime}-- if ($config{SlideShowTime} >= 1);
log_it("slideshow time: ".$config{SlideShowTime}." sec");
}
else {
zoomStep(-1);
}
} );
# key-desc,+,zoom in or slideshow slower
$bind_w->bind('', sub {
if ($slideshow) {
$config{SlideShowTime}++ if ($config{SlideShowTime} < 30);
log_it("slideshow time: ".$config{SlideShowTime}." sec");
}
else {
zoomStep(1);
}
});
# key-desc,Ctrl-h,display picture in original size (100% zoom)
$bind_w->bind('', sub { zoom100(); });
# key-desc,z,display picture in original size (100% zoom)
$bind_w->bind('', sub { zoom100(); });
# key-desc,Alt-1,display picture in original size (100% zoom)
$bind_w->bind('', sub { zoom100(); });
# key-desc,f,fit picture in canvas (auto zoom)
$bind_w->bind('', sub { $conf{zoom_fit_fill}{value} = FIT; fitPicture(); });
# key-desc,Alt-3,fit picture in canvas (auto zoom)
$bind_w->bind('', sub { $conf{zoom_fit_fill}{value} = FIT; fitPicture(); });
# key-desc,Alt-2,fill picture in canvas (auto zoom)
$bind_w->bind('', sub { $conf{zoom_fit_fill}{value} = FILL; fitPicture(); });
}
##############################################################
# addCommonKeyBindings - add key shortcuts to a widget
##############################################################
sub addCommonKeyBindings {
my $bind_w = shift; # widget to bind keys to
my $lb_w = shift; # thumbnail listbox to use
# key-desc,a,add JPEG comment
$bind_w->bind('', sub { addComment($lb_w); } );
# key-desc,j,edit JPEG comment
$bind_w->bind('', sub { editComment($lb_w); } );
# key-desc,v,open picture in external viewer
$bind_w->bind('', sub { openPicInViewer($lb_w); } );
# key-desc,r,rename selected pictures
$bind_w->bind('', sub { renamePic($lb_w); } );
# key-desc,e,display embedded EXIF data
$bind_w->bind('', sub { displayEXIFData($lb_w); } );
# key-desc,x,display embedded XMP data
$bind_w->bind('', sub { xmp_show($lb_w); } );
# key-desc,Ctrl-a,select all pictures
$bind_w->bind('', sub { selectAll($lb_w); } );
# key-desc,i,display IPTC data
$bind_w->bind('', sub { displayIPTCData($lb_w); } );
# key-desc,Alt-c,copy EXIF and IPTC data
$bind_w->bind('', sub { copyIPTC(); copyEXIFData(); } );
# key-desc,Alt-v,paste IPTC data
$bind_w->bind('', sub { pasteIPTC(); } );
# key-desc,Ctrl-i,edit IPTC data
$bind_w->bind('', sub { editIPTC($lb_w); } );
# key-desc,Ctrl-p,copy to print
$bind_w->bind('', sub { copyToPrint($lb_w); } );
# key-desc,l,add selected thumbnails to collection (light table)
$bind_w->bind('', sub { light_table_add_from_lb($lb_w); } );
# key-desc,Ctrl-t,Show thumbnails in picture frame
$bind_w->bind('', sub { my @pics = $picLB->info('children'); show_canvas_thumbs($c, \@pics);} );
# these buttons fit to the rating with IPTC urgency
# key-desc,Ctrl-F01,set IPTC urgency to 1 - high
$bind_w->bind('', sub { setIPTCurgency($lb_w, 1); } );
# key-desc,Ctrl-F02,set IPTC urgency to 2
$bind_w->bind('', sub { setIPTCurgency($lb_w, 2); } );
# key-desc,Ctrl-F03,set IPTC urgency to 3
$bind_w->bind('', sub { setIPTCurgency($lb_w, 3); } );
# key-desc,Ctrl-F04,set IPTC urgency to 4
$bind_w->bind('', sub { setIPTCurgency($lb_w, 4); } );
# key-desc,Ctrl-F05,set IPTC urgency to 5 - normal
$bind_w->bind('', sub { setIPTCurgency($lb_w, 5); } );
# key-desc,Ctrl-F06,set IPTC urgency to 6
$bind_w->bind('', sub { setIPTCurgency($lb_w, 6); } );
# key-desc,Ctrl-F07,set IPTC urgency to 7
$bind_w->bind('', sub { setIPTCurgency($lb_w, 7); } );
# key-desc,Ctrl-F08,set IPTC urgency to 8 - low
$bind_w->bind('', sub { setIPTCurgency($lb_w, 8); } );
# key-desc,Ctrl-F09,set IPTC urgency to 0 - none
$bind_w->bind('', sub { setIPTCurgency($lb_w, 0); } );
# key-desc,Ctrl-F10,remove IPTC urgency flag
$bind_w->bind('', sub { setIPTCurgency($lb_w, 9); } );
# additional rating buttons 1 = 1 star to 5 = 5 stars
# these buttons fit to the rating with stars
# key-desc,5, set 5 star rating (IPTC urgency to 1 - high)
$bind_w->bind('', sub { setIPTCurgency($lb_w, 1); } );
# key-desc,4, set 4 star rating (IPTC urgency to 2)
$bind_w->bind('', sub { setIPTCurgency($lb_w, 2); } );
# key-desc,3, set 3 star rating (IPTC urgency to 3)
$bind_w->bind('', sub { setIPTCurgency($lb_w, 3); } );
# key-desc,2, set 2 star rating (IPTC urgency to 4)
$bind_w->bind('', sub { setIPTCurgency($lb_w, 4); } );
# key-desc,1, set 1 star rating (IPTC urgency to 5 - normal)
$bind_w->bind('', sub { setIPTCurgency($lb_w, 5); } );
# key-desc,R, toggle red flag
$bind_w->bind('', sub { flag_toggle($lb_w, FLAG_RED); } );
# key-desc,G, toggle green flag
$bind_w->bind('', sub { flag_toggle($lb_w, FLAG_GREEN); } );
# key-desc,B, toggle blue flag
$bind_w->bind('', sub { flag_toggle($lb_w, FLAG_BLUE); } );
}
##############################################################
##############################################################
sub session_info {
my $pics_nr = keys(%searchDB);
my $start_nr = $top->{sessioninfo}{startpics};
my $diff = $pics_nr - $start_nr;
my $start_time = localtime($top->{sessioninfo}{starttime});
my $duration = time() - $top->{sessioninfo}{starttime};
#print "start of session $start_nr\nNow: $pics_nr\n";
log_it("Session: Start: $start_time; Pics in database: $pics_nr, at start: $start_nr, diff: $diff");
}
##############################################################
# startup - process all stuff needed to set up mapivi
##############################################################
sub startup {
print lang("Sub startup ...\n") if $verbose;
$picLB->focus;
if ($config{NrOfRuns} == 0) {
print lang("First run ...\n") if $verbose;
make_mapivi_folders();
}
$config{NrOfRuns}++;
gratulation() if (($config{NrOfRuns} % 1000 == 0) and ($config{NrOfRuns} > 0)); # modulo
# create menus
createMenubar();
createDirMenu();
createThumbMenu();
createPicMenu();
checkSystem();
startStopClock();
# try to get the saved database (meta info hash)
if ($config{SaveDatabase} and -f $searchDBfile) {
my $hashRef = retrieve($searchDBfile);
if (defined $hashRef) {
%searchDB = %{$hashRef};
}
else {
warn langf("Could not retrieve %s","searchDB ($searchDBfile)");
}
}
# store number of pictures in DB at session start
$top->{sessioninfo}{startpics} = keys(%searchDB);
# try to get the saved hotlist folders
if (-f "$user_data_path/hotlist") {
my $hashRef = retrieve("$user_data_path/hotlist");
if (defined $hashRef) {
%dirHotlist = %{$hashRef};
}
else {
warn langf("Could not retrieve %s","hotlist");
}
}
# try to get the saved folder properties
if (-f "$user_data_path/dirProperties") {
my $hashRef = retrieve("$user_data_path/dirProperties");
if (defined $hashRef) {
%dirProperties = %{$hashRef};
}
else {
warn langf("Could not retrieve %s","dirProperties");
}
}
# add additional folder properties (may be usefull when merging two Mapivi installations)
if (-f "$user_data_path/dirProperties.add") {
my $hashRef = retrieve("$user_data_path/dirProperties.add");
if (defined $hashRef) {
print lang("Found additional dirProperties. Merging information ...\n");
foreach my $dir (keys %{$hashRef}) {
foreach my $key (keys %{$hashRef->{$dir}}) {
$dirProperties{$dir}{$key} = $hashRef->{$dir}->{$key};
}
#$dirProperties{$dir} = dclone($hashRef->$dir);
print " adding $dir\n";
}
print lang("Merging finished. Added ".keys(%{$hashRef})." folders.\nYou may now delete or rename $user_data_path/dirProperties.add\nto prevent merging during the next start of Mapivi\n");
}
}
# try to get the saved ignore keywords
if (-f "$user_data_path/keywords_ignore") {
my $hashRef = retrieve("$user_data_path/keywords_ignore");
if (defined $hashRef) {
%ignore_keywords = %{$hashRef};
}
else {
warn langf("Could not retrieve %s","keywords_ignore");
}
}
# try to get the saved slideshows
if (-f "$user_data_path/slideshows") {
my $hashRef = retrieve("$user_data_path/slideshows");
if (defined $hashRef) {
%slideshows = %{$hashRef};
}
else {
warn langf("Could not retrieve %s","slideshows");
}
}
if (MatchEntryAvail) {
# try to get the saved entry values
if (-f $file_Entry_values) {
my $hashRef = retrieve($file_Entry_values);
if (defined $hashRef) {
%entryHistory = %{$hashRef};
}
else {
warn langf("Could not retrieve %s",$file_Entry_values);
}
}
}
updateDirMenu();
layout(0);
# remove splash screen
$splash->Destroy if $splash;
# show main window
$top->deiconify;
$top->raise;
setDirProperties();
updateThumbs();
setAdjusterPos();
my $tmp = $config{ShowPic};
$config{ShowPic} = 0;
showPic($actpic) if ($config{SelectLastPic} and (defined $actpic) and ($actpic ne '') and (dirname($actpic) eq $actdir));
$config{ShowPic} = $tmp;
selectDirInTree($actdir);
checkTrash();
# if command line option -i is set or a memory card is inserted we start the import wizard
importWizard() if (($opt_i) or ($config{AutoImport} and (-d $config{ImportSource})));
if ($EvilOS) {
warn "Win32::Process module not available\n" unless (Win32ProcAvail);
}
$top->update();
# display the number of pics in the database in the canvas
log_it($top->{sessioninfo}{startpics}.' '.lang("pictures"));
#show_text_in_canvas($c, $top->{sessioninfo}{startpics}."\n".lang("pictures"));
}
##############################################################
##############################################################
sub show_text_in_canvas {
my $c = shift; # canvas widget ref
my $text = shift;
my $font = $c->Font(-family => $config{FontFamily}, -size => 50, -weight => 'bold');
my $id = $c->createText( int($c->width/2), int($c->height/2), -font => $font, -text => $text,
-anchor => 'c', -justify => 'center', -fill => $conf{color_fg}{value}, -tags => ['TEXT']);
my ($x1, $y1, undef, undef) = $c->bbox($id);
if (($x1 < 0) or ($y1 < 0)) {
# delete text if it doesn't fit into the canas
$c->delete('withtag', 'TEXT');
# and log it instead, after replacing all newlines with spaces
$text =~ s/\n/ /g;
log_it($text);
}
}
##############################################################
# testSuite - some tests for mapivi
# idea: start with the pictures which are currently shown -
# independend of navigation kind. Copy all of them to a
# temp folder in the trash dir.
# then call separated test functions which do some tests on this
# set of pictures. Before the next test function is called the
# pictures are restored so that all functions get the same setup
# independend of the calling order by test_prepare().
##############################################################
sub testSuite {
# set original file list - should not be changed during test suite!
my @childs = $picLB->info('children');
if (@childs < 2) {
$top->messageBox(-icon => 'error', -message => lang('Test suite must be started in a folder with at least two picture!'),
-title => lang('Test suite'), -type => 'OK');
return;
}
if (@childs > 30) {
my $rc = $top->messageBox(-icon => 'question', -message => "Folder contains ".scalar(@childs)." files.\nIt is recommended to use between 2 and 30 files.\nMore files is Ok, but takes more time. Continue?",
-title => lang('Many files?'), -type => 'OKCancel');
return unless ($rc =~ m/Ok/i);
}
# store first folder to open after tests are finished
my $startdir = dirname($childs[0]);
my $rc = $top->messageBox(-icon => 'question', -message => langf("Start some internal tests with ".scalar @childs." pictures in $actdir.\nTest results will go to STDOUT (shell/DOS-box where you've started Mapivi).\nOk to go on?"),
-title => lang('Start test suite?'), -type => 'OKCancel');
return unless ($rc =~ m/Ok/i);
# store and reset some configurations which may require user interaction
# reset at end ...
my $tmp_AskDeleteHighRatingLevel = $config{AskDeleteHighRatingLevel};
$config{AskDeleteHighRatingLevel} = 0;
# preparation
# set up temp folders
my $dir0 = "$trashdir/testdir0";
my $dir1 = "$trashdir/testdir1";
my $dir2 = "$trashdir/testdir2";
# cleanup if folder is already there
print "testSuite: removing temp $dir0\n";
rmtree($dir0, 0, 1) if (-d $dir0); # dir, 0 = no message for each file, 1 = skip write protected files
unless (makeDir($dir0, NO_ASK)) { print "testSuite: could not create $dir0\n"; }
# check if everything worked
unless (-d $dir0) { warn "testSuite: *** $dir0 not found! Stopping test suite!\n"; return; }
print "testSuite: temp dir created\n";
# test initial copy actdir -> dir0
print "testSuite: testing copy all\n";
selectAll($picLB);
copyPics($dir0, COPY, $picLB, @childs);
openDirPost($dir0);
my $test_nr = 0;
return if (not test_prepare(\@childs,$dir0,$dir1,$dir2,\$test_nr));
test_selection($dir1);
return if (not test_prepare(\@childs,$dir0,$dir1,$dir2,\$test_nr));
test_copy($dir1, $dir2);
return if (not test_prepare(\@childs,$dir0,$dir1,$dir2,\$test_nr));
test_move($dir1, $dir2);
return if (not test_prepare(\@childs,$dir0,$dir1,$dir2,\$test_nr));
test_backup($dir1);
if (not $EvilOS) {
return if (not test_prepare(\@childs,$dir0,$dir1,$dir2,\$test_nr));
test_link($dir1, $dir2);
}
return if (not test_prepare(\@childs,$dir0,$dir1,$dir2,\$test_nr));
test_comment($dir1);
return if (not test_prepare(\@childs,$dir0,$dir1,$dir2,\$test_nr));
test_rotate($dir1);
return if (not test_prepare(\@childs,$dir0,$dir1,$dir2,\$test_nr));
test_exif($dir1);
##################################################
print "testSuite: going back to start dir\n";
openDirPost($startdir);
changeDir($startdir); # linking files changes the cwd so we must move back before we try to remove the dirs
# end
$top->messageBox(-icon => 'info', -message => "test suite finished",
-title => "test suite", -type => 'OK');
# cleanup
foreach ($dir0, $dir1, $dir2) {
print "testSuite: removing temp dir $_\n";
rmtree($_, 0, 1) if (-d $_); # dir, 0 = no message for each file, 1 = skip write protected files
}
# restore configurations
$config{AskDeleteHighRatingLevel} = $tmp_AskDeleteHighRatingLevel;
}
##############################################################
##############################################################
sub test_prepare {
my $childs = shift; # array ref
my ($dir0, $dir1, $dir2, $test_nr) = @_;
$$test_nr++;
openDirPost($dir0);
# cleanup if folders are already there
foreach ($dir1, $dir2) {
#print "testSuite: removing temp dir $_\n";
rmtree($_, 0, 1) if (-d $_); # dir, 0 = no message for each file, 1 = skip write protected files
}
foreach ($dir1, $dir2) { unless (makeDir($_, NO_ASK)) { print "testSuite: could not create $_\n"; } }
# check if everything worked
foreach ($dir1, $dir2) { unless (-d $_) { warn "testSuite: *** $_ not found! Stopping test suite!\n"; return 0; } }
print "testSuite: temp dirs created\n";
# test initial copy actdir -> dir0
print "testSuite: prepare pics testing. Test # $$test_nr\n";
selectAll($picLB);
copyPics($dir1, COPY, $picLB, @$childs);
openDirPost($dir1);
return 1;
}
##############################################################
##############################################################
sub test_selection {
my @childs = $picLB->info('children');
# test single selection
print "testSuite: testing single selection\n";
foreach (@childs) {
selectThumb($picLB, $_);
my @sel = $picLB->info('selection');
print "testSuite: *** wrong selection\n" if (@sel != 1);
print "testSuite: *** wrong selection\n" if ($sel[0] ne $_);
}
# test all selection
print "testSuite: testing all selection\n";
selectAll($picLB);
my @sel = $picLB->info('selection');
print "testSuite: *** wrong selection\n" if (@sel != @childs);
}
##############################################################
##############################################################
sub test_copy {
my ($dir1, $dir2) = @_;
my @childs1 = $picLB->info('children');
# copy first pic dir1 -> dir2
print "testSuite: testing copy first\n";
selectThumb($picLB, $childs1[0]);
my @sel = $picLB->info('selection');
if (@sel ne 1) {
warn "testSuite: *** sel error ".scalar @sel." ne 1\n";
}
copyPics($dir2, COPY, $picLB, @sel);
openDirPost($dir2);
my @childs2 = $picLB->info('children');
if (@childs2 ne 1) {
warn "testSuite: *** copy error ".scalar @childs2." ne 0\n";
}
if (basename($childs1[0]) ne basename($childs2[0])) {
warn "testSuite: *** copy error $childs1[0] ne $childs2[0]\n";
}
# copy last pic dir1 -> dir2
print "testSuite: testing copy last\n";
openDirPost($dir1);
@childs1 = $picLB->info('children');
selectThumb($picLB, $childs1[-1]);
@sel = $picLB->info('selection');
if (@sel ne 1) {
warn "testSuite: *** sel error ".scalar @sel." ne 1\n";
}
copyPics($dir2, COPY, $picLB, @sel);
openDirPost($dir2);
@childs2 = $picLB->info('children');
if (@childs2 ne 2) {
warn "testSuite: *** copy error ".scalar @childs2." ne 2\n";
}
if (basename($childs1[-1]) ne basename($childs2[-1])) {
warn "testSuite: *** copy error $childs1[-1] ne $childs2[-1]\n";
}
# test copy all dir1 -> dir2
openDirPost($dir1);
#my @childs1rest = $picLB->info('children');
my @childs1rest = @childs1;
# remove first and last from list, else we get an overwrite requester to the user
shift @childs1rest;
pop @childs1rest;
print "testSuite: testing copy all\n";
selectAll($picLB);
copyPics($dir2, COPY, $picLB, @childs1rest);
openDirPost($dir2);
@childs2 = $picLB->info('children');
if (@childs1 != @childs2) {
warn "testSuite: *** copy error ".scalar @childs1." ne ".scalar @childs2."\n";
}
foreach my $i (0 .. $#childs1) {
# todo this will fail, if files are sorted by file date (copy date)
if (basename($childs2[$i]) ne basename($childs1[$i])) {
warn "testSuite: *** copy error $childs2[$i] ne $childs1[$i]\n";
}
}
}
##############################################################
##############################################################
sub test_move {
my ($dir1, $dir2) = @_;
my @childs1 = $picLB->info('children');
# move first and last pics dir2 -> dir1
print "testSuite: testing move first and last\n";
selectThumb($picLB, $childs1[0]);
my @sel = $picLB->info('selection');
movePics($dir2, $picLB, @sel);
selectThumb($picLB, $childs1[-1]);
@sel = $picLB->info('selection');
movePics($dir2, $picLB, @sel);
openDirPost($dir2);
my @childs2 = $picLB->info('children');
if (@childs2 != 2) {
warn "testSuite: *** move error ".scalar @childs2." ne 2\n";
}
# move all pics dir1 -> dir2
print "testSuite: testing move all\n";
openDirPost($dir1);
selectAll($picLB);
@sel = $picLB->info('selection');
movePics($dir2, $picLB, @sel);
openDirPost($dir2);
@childs2 = $picLB->info('children');
if (@childs2 != @childs1) {
warn "testSuite: *** move error ".scalar @childs2." ne ".scalar @childs1."\n";
}
}
##############################################################
##############################################################
sub test_backup {
my $dir1 = shift;
# prepare: we should have no backup files (*-bak.jpg) before we start
# as this gives a warning when there is no backup we first have to create one
my @childs1 = $picLB->info('children');
copyPics($dir1, BACKUP, $picLB, $childs1[0]);
selectBak();
deletePics($picLB, TRASH);
@childs1 = $picLB->info('children');
my $nr = scalar(@childs1);
if ($nr <= 0) {
warn "testSuite: *** backup error after deleting backup files nothing left!\n";
return;
}
# test backup dir1
print "testSuite: testing backup all\n";
selectAll($picLB);
my @sel = $picLB->info('selection');
copyPics($dir1, BACKUP, $picLB, @sel);
@childs1 = $picLB->info('children');
if (@childs1 != $nr*2) {
warn "testSuite: *** backup error ".scalar @childs1." ne 2*$nr\n";
}
# test delete backups dir1
selectBak();
@sel = $picLB->info('selection');
warn "testSuite: *** sel error ".scalar @sel." ne 2\n" if (@sel != $nr);
deletePics($picLB, TRASH);
@childs1 = $picLB->info('children');
warn "testSuite: *** delete backup error ".scalar @childs1." ne 2\n" if (@childs1 != $nr);
}
##############################################################
##############################################################
sub test_link {
my ($dir1, $dir2) = @_;
# link all pics dir1 -> dir2
print "testSuite: testing link all\n";
openDirPost($dir1);
my @childs1 = $picLB->info('children');
selectAll($picLB);
my @sel = $picLB->info('selection');
linkPics($dir2, @sel);
@childs1 = $picLB->info('children');
openDirPost($dir2);
my @childs2 = $picLB->info('children');
warn "testSuite: link ".scalar @childs1." = ".scalar @childs2."?\n";
if (@childs1 != @childs2) {
warn "testSuite: *** link error ".scalar @childs1." ne ".scalar @childs2."\n";
}
}
##############################################################
##############################################################
sub test_comment {
my $dir1 = shift;
# test comments first pic
print "testSuite: testing comment single\n";
my $testcom = "xxxcccxxx1234ABC";
my @childs1 = $picLB->info('children');
selectThumb($picLB, $childs1[0]);
my @sel = $picLB->info('selection');
addCommentToPic($testcom, $sel[0], TOUCH);
my $com = getComment($sel[0], LONG);
if ($com !~ m/.*$testcom.*/) {
warn "testSuite: *** comment $com does not contain $testcom\n";
}
# test comments join
print "testSuite: testing comments remove and join\n";
# add a comment to all pics
selectAll($picLB);
@sel = $picLB->info('selection');
addCommentToPic($testcom, $_, TOUCH) foreach (@sel);
# remove the comments from the last pic, so we have at least one example for no comment
selectThumb($picLB, $childs1[-1]);
removeAllComments(NO_ASK);
warn "testSuite: *** remove comment error\n" if (scalar getComments($childs1[-1]) != 0);
selectAll($picLB);
my %comNr; # hash: key:dpic value:nr of comments
foreach (@childs1) {
my @com = getComments($_);
$comNr{$_} = scalar @com;
}
joinComments(NO_ASK);
foreach (@childs1) {
my @com = getComments($_);
my $nr = $comNr{$_};
$nr = 1 if ($nr >= 2);
print $comNr{$_}." -> $nr act: ".scalar @com."($#com)\n" if $verbose;
warn "testSuite: *** comment join error\n" if ($nr != @com);
}
}
##############################################################
##############################################################
sub test_rotate {
my $dir1 = shift;
my @childs1 = $picLB->info('children');
print "testSuite: testing rotate single\n";
selectThumb($picLB, $childs1[0]);
rotate(90);
rotate(270);
my $size = getFileSize($childs1[0]);
rotate(90);
rotate(270);
warn "testSuite: *** rotate single file mismatch!\n" if ($size != getFileSize($childs1[0]));
}
##############################################################
##############################################################
sub test_exif {
my $dir1 = shift;
my @childs1 = $picLB->info('children');
print "testSuite: testing EXIF date set/get\n";
selectThumb($picLB, $childs1[0]);
my $testdate = '2099:11:30 23:59:59';
my $errorstr = '';
setEXIFDatePic($childs1[0],$testdate,\$errorstr);
my $datetime = getEXIFDate($childs1[0]);
#print "EXIF date of $childs1[0]: $testdate -> $datetime\n";
warn "testSuite: *** set EXIF date $testdate != $datetime!\n" if ($testdate ne $datetime);
}
##############################################################
# addToCachedPics - add a image (path and file name) to
# the cachedPics list
# if it is already in the list, move it to
# the end
##############################################################
sub addToCachedPics {
my $dpic = shift;
for my $t ( 0 .. $#cachedPics ) {
if ($cachedPics[$t] eq $dpic) {
splice @cachedPics, $t, 1; # remove it from list
last;
}
}
push @cachedPics, $dpic; # add item to the list
print "addToCachedPics: $dpic list:$#cachedPics\n" if $verbose;
checkCachedPics();
}
##############################################################
# checkCachedPics - check if the cachedPics list contains more
# images than allowed, remove the oldest
# if necessary
##############################################################
sub checkCachedPics {
# first check if all entries are valid pictures
my @rm_list;
for my $t ( 0 .. $#cachedPics ) {
push @rm_list, $t unless (-f $cachedPics[$t]);
}
# remove the invalid pictures
for my $t (reverse @rm_list) {
my $dpic = $cachedPics[$t];
next unless ($dpic);
print "checkCachedPics: removing not existing $dpic\n" if $verbose;
$c->delete('withtag', $dpic); # remove it from the canvas
$photos{$dpic}->delete if $photos{$dpic}; # delete the photo object
delete $photos{$dpic}; # delete the hash item
splice @cachedPics, $t, 1; # remove not existing pictures it from list
}
# short the list, if it is to long
while (@cachedPics > $config{MaxCachedPics}) {
if ($actpic eq $cachedPics[0]) {
print "this is the actual pic - skipping!\n" if $verbose;
next;
}
my $dpic = shift @cachedPics; # get the oldest
print "checkCachedPics: removing old $dpic list:$#cachedPics\n" if $verbose;
$c->delete('withtag', $dpic); # remove it from the canvas
$photos{$dpic}->delete if $photos{$dpic}; # delete the photo object
delete $photos{$dpic}; # delete the hash item
}
#printlist(@cachedPics);
# just for safety
warn "*** checkCachedPics: photos hash contains more than MaxCachedPics pics (".scalar @cachedPics."(".scalar(keys(%photos)).") > ".$config{MaxCachedPics}.")" if (keys %photos > $config{MaxCachedPics});
}
##############################################################
# renameCachedPic - rename a list item
##############################################################
sub renameCachedPic {
my $old = shift;
my $new = shift;
return unless (defined $photos{$old});
# open new photo object
$photos{$new} = $top->Photo;
$photos{$new}->blank;
$photos{$new}->copy($photos{$old});
$c->delete('withtag', $old); # remove it from the canvas
$photos{$old}->delete if $photos{$old}; # delete the photo object
delete $photos{$old}; # delete the hash item
my $xoffset = 0; my $yoffset = 0;
$xoffset = int(($c->width - $photos{$new}->width) /2) if ($c->width > $photos{$new}->width);
$yoffset = int(($c->height - $photos{$new}->height)/2) if ($c->height > $photos{$new}->height);
# hide all items on the canvas
canvasHide();
# insert pic
my $id = $c->createImage($xoffset, $yoffset, -image => $photos{$new}, -tag => ["pic", $new], -anchor => "nw");
bindItem($id);
for my $t ( 0 .. $#cachedPics ) {
if ($cachedPics[$t] eq $old) {
$cachedPics[$t] = $new; # rename list item
}
}
print "renameCachedPic: $old -> $new\n" if $verbose;
checkCachedPics();
}
##############################################################
# deleteCachedPics - delete all or just one element(s)
# and photo objects of the cachedPics list
##############################################################
sub deleteCachedPics {
my $dpic = shift; # optional, if available this picture will be removed from the cachedPics list,
# if not available all elements will be deleted
if (defined($dpic) and isInList($dpic, \@cachedPics)) {
print "deleteCachedPics: delete single pic $dpic (".scalar @cachedPics.")\n" if $verbose;
$c->delete('withtag', $dpic); # remove it from the canvas
$photos{$dpic}->delete if $photos{$dpic}; # delete the photo object
delete $photos{$dpic}; # delete the hash item
#printlist(@cachedPics);
my @list = @cachedPics; # copy list
@cachedPics = (); # empty list
foreach my $i (reverse 0 .. $#list) {
unless ($list[$i] eq $dpic) {
print "deleteCachedPics: adding $list[$i]\n" if $verbose;
push @cachedPics, $list[$i];
}
}
}
else {
print "deleteCachedPics: delete all (".scalar @cachedPics.")\n" if $verbose;
foreach (@cachedPics) {
$c->delete('withtag', $_); # remove it from the canvas
$photos{$_}->delete if $photos{$_}; # delete the photo object
delete $photos{$_}; # delete the hash item
print "deleteCachedPics: deleting pic $_\n" if $verbose;
}
@cachedPics = (); # empty list
}
}
##############################################################
# showSelectedPic - displays the original picture of the
# selected thumbnail
##############################################################
sub showSelectedPic {
return if (stillBusy()); # block, until last picture is loaded
my @sellist = $picLB->info('selection');
# show index number in window
showNrOf();
return unless ($picLB->info('children'));
return if (@sellist > 1);
showPic($sellist[0]);
}
##############################################################
# showNrOf
##############################################################
sub showNrOf {
my @pics = $picLB->info('children');
my @sellist = $picLB->info('selection');
my $index = 0;
my $size = 0;
my $sizeStr = '';
if (@sellist >= 1) { # selection available
foreach (@pics) {
$index++;
last if ($_ eq $sellist[0]);
}
}
if (@sellist >= 2) { # more than one selected
foreach (@sellist) {
$size += getFileSize($_, NO_FORMAT);
}
$sizeStr = computeUnit($size) if $size;
$sizeStr = ", $sizeStr" if ($sizeStr ne '');
}
# show index number in window
$nrof = "$index/".@pics." (".@sellist."$sizeStr)";
}
##############################################################
# computeUnit - do a byte to kB or MB conversion
##############################################################
sub computeUnit {
my $size = shift;
my $sizeStr;
$size = int($size/1024); # KiloByte
if ($size > 1024) { # MegaByte
if ($size > 1024*1024) { # GigaByte
if ($size < (1024*1024*100)) { # less than 100GB
$size = int($size*10/(1024*1024))/10; # e.g. 6.9GB or 23.4GB
}
else {
$size = int($size/(1024*1024)); # e.g. 104GB
}
$sizeStr = "${size}GB";
}
else {
if ($size < (1024*100)) { # less than 100MB
$size = int($size*10/1024)/10; # e.g. 6.9MB or 23.4MB
}
else {
$size = int($size/1024); # e.g. 104MB
}
$sizeStr = "${size}MB";
}
}
else {
$sizeStr = "${size}kB";
}
return $sizeStr;
}
##############################################################
##############################################################
sub string_changed {
my ($old, $new) = @_;
my $change = 0;
# changed is true if ...
# a) old and new are defined and new is not empty and not equal
# b) old is undefined and new is defined and not empty
if ((defined $new) and ($new ne '')) {
if (defined $old) {
if ($old ne $new) {
$change = 1;
}
}
else { # old not defined
#if ($new ne '') {
$change = 1;
#}
}
}
return $change;
}
##############################################################
# check_IPTC_edit - check if the user added or edited the IPTC
# headline or caption of the actual pic and ask to save it
##############################################################
sub check_IPTC_edit {
my $dpic = shift;
# prevent question at startup
return if (not $config{ShowPic});
# we need a picture to compare
return unless defined $dpic;
return unless -f $dpic;
# function is only relevant when caption frame is visible
return unless $iptcF->ismapped;
my $change = 0;
my $headline_new = $titleText->get(0.1, 'end');
my $headline = getIPTCHeadline($dpic);
$headline_new =~ s/\n+$// if (defined $headline_new); # cut off trailing newline(s)
$change = string_changed($headline, $headline_new);
# only if no change has been detected so far we also check the caption
if (not $change) {
my $caption_new = $captionText->get(0.1, 'end');
my $caption = getIPTCCaption($dpic);
$caption_new =~ s/\n+$// if (defined $caption_new); # cut off trailing newline(s)
$caption =~ s/\n+$// if (defined $caption); # cut off trailing newline(s)
$change = string_changed($caption, $caption_new);
}
if ($change) {
my $rc = $top->messageBox(-icon => 'question',
-message => langf("Headline/caption of %s have been changed.\nShould Mapivi save the changes?", $dpic),
-title => lang("Save changes?"),
-type => 'YesNo');
$saveB->Invoke if ($rc =~ m/Yes/i);
}
return;
}
##############################################################
# showPic - displays a picture in the main window canvas
##############################################################
sub showPic {
# check if the user added or edited the IPTC caption of the actual pic and ask to save it
# Warning: must be called before $actpic is set to new picture ($dpic)
check_IPTC_edit($actpic);
my $dpic = shift;
my @pics = $picLB->info('children');
return if ((!defined $dpic) or (!@pics));
if (@pics < 1) {
warn lang("Error: No pictures in listbox") if $verbose;
log_it(lang("Error: No pictures in listbox"));
return;
}
$actpic = $dpic;
return if ((!defined $actpic) or ($actpic eq ''));
setTitle();
my $pic = basename($dpic);
# select thumb in list even if picture is not shown (see "ShowPic" below)
selectThumb($picLB, $dpic);
return if (!$config{ShowPic});
# show EXIF info and comment
showImageInfo($dpic);
# we are still not able to display RAW pictures (nefextract may be a solution for NEFs, see also extract_jpeg())
return if ($dpic =~ m/.*\.(nef)|(raw)$/i);
# do not show a picture if the frame is very small
if ($dpic =~ m/.*\.(tif)|(tiff)|(xbm)$/i) {
log_it("$pic ".lang("Not displayed (unsupported picture format)"));
return;
}
# do not show a picture if there is no picture frame
if (!$config{ShowPicFrame}) {
log_it("$pic ".lang("Not displayed - no picture frame (hint: try F9 or F11)"));
return;
}
# do not show a picture if the frame is very small
if ($mainF->width < 200) {
log_it("$pic ".lang("Not displayed (picture frame too small)"));
return;
}
$showPicInAction = 1;
# remove thumbnails from canvas, if any
clear_canvas_thumbs($c);
my $do_center = 0; # flag to center picture (do only when loading or resizing)
$balloon->detach($c); # clear the balloon info for the actual pic (right frame of main window)
log_it(langf("Loading %s ...", $pic));
my @ids = $c->find('withtag', $dpic);
my $id;
if (@ids > 0) { # pic is already loaded
print "showPic: using cached pic $dpic\n" if $verbose;
$id = $ids[0];
# hide all items on the canvas
canvasHide();
# make hidden picture visible again
$c->itemconfigure($id, -state => 'normal');
$top->update();
}
else {
print langf("showPic: loading %s\n",$dpic) if $verbose;
if (-f $dpic) { # load pic
$top->Busy();
#if ($dpic =~ m/.*\.avi$/i) {
# hide all items on the canvas
#canvasHide();
# load thumbnail
#my $thumb = getThumbFileName($dpic);
#$photos{$dpic} = $top->Photo(-file => $thumb, -gamma => $config{Gamma}) if -f $thumb;
#my $command = "vlc \"$dpic\" ";
#execute($command);
#}
#my $dpic_jpg = '';
#if ($dpic =~ m/(.*)\.nef$/i) {
# $dpic_jpg = $1.".jpg";
# print "$dpic is a NEF -> $dpic_jpg\n";
# my $command = "nefextract \"$dpic\" > \"$dpic_jpg\" ";
# execute($command);
#}
#if (-f $dpic_jpg) {
# load pic
# $photos{$dpic} = $top->Photo(-file => $dpic_jpg, -gamma => $config{Gamma});
# zoom pic
# autoZoom(\$photos{$dpic}, $dpic_jpg, $c->width, $c->height);
#}
#else {
# load pic
eval { $photos{$dpic} = $top->Photo(-file => $dpic, -gamma => $config{Gamma}); };
# error handling
if ($@) {
log_it("Error loading $pic");
print "Error loading $pic: \"$@\"\n";
$showPicInAction = 0;
$top->Unbusy();
return;
}
# zoom pic
autoZoom(\$photos{$dpic}, $dpic, $c->width, $c->height) if (exists $photos{$dpic} and $config{AutoZoom});
#}
if (exists $photos{$dpic}) {
# center pic in canvas, only when it's smaller
my $xoffset = 0; my $yoffset = 0;
$xoffset = int(($c->width - $photos{$dpic}->width) /2) if ($c->width > $photos{$dpic}->width);
$yoffset = int(($c->height - $photos{$dpic}->height)/2) if ($c->height > $photos{$dpic}->height);
# hide all items on the canvas
canvasHide();
# insert pic in canvas
$id = $c->createImage($xoffset, $yoffset, -image => $photos{$dpic}, -tag => ['pic',$dpic], -anchor => 'nw');
$do_center = 1; # set flag to center picture
bindItem($id);
addToCachedPics($dpic);
}
else {
log_it(langf("showPic: error loading %s!",$actpic));
warn langf("showPic: error loading %s!",$actpic) if $verbose;
}
$top->Unbusy();
addToCachedPics($dpic);
}
else {
canvasHide();
warn langf("showPic: error %s not available!", $actpic) if $verbose;
}
}
# show zoom info
showZoomInfo($dpic, $id);
showImageInfoCanvas($dpic);
increasePicPopularity($dpic);
updateOneRow($dpic, $picLB) if ($config{trackPopularity});
if ($config{ShowPicInfo}) {
# balloon info for displayed picture (right frame of the main window)
my $balloonmsg = makeBalloonMsg($dpic);
# bind the balloon to the canvas
$balloon->attach($c->Subwidget('canvas'), -balloonposition => 'mouse', -msg => {"pic" => $balloonmsg} );
}
else {
$balloon->detach($c->Subwidget('canvas'));
}
log_it($pic);
# adjust the canvas scrollbars, only if the canvas contains a picture
if ($c->bbox("all") and $photos{$dpic}) {
$c->configure(-scrollregion => [ $c->bbox("all") ]);
# move canvas view to upper left corner for small pictures
#$c->xviewMoveto(0) if ($c->Width > $photos{$dpic}->width);
#$c->yviewMoveto(0) if ($c->Height > $photos{$dpic}->height);
# center canvas over big pictures only the first time (new picture)
canvas_center($c, $photos{$dpic}->width, $photos{$dpic}->height) if $do_center;
}
$top->Unbusy();
$showPicInAction = 0;
}
##############################################################
# center canvas scrollbars over big pictures
##############################################################
sub canvas_center {
my ($c, $pic_w, $pic_h) = @_; # canvas widet, picture width (pixels), picture height (pixels)
$c->xviewMoveto(($pic_w - $c->width) /($pic_w*2)) if ($c->width < $pic_w);
$c->yviewMoveto(($pic_h - $c->height)/($pic_h*2)) if ($c->height < $pic_h);
}
##############################################################
# canvasHide
##############################################################
sub canvasHide {
# hide all items on the canvas
$c->update();
#$c->itemconfigure('all', -state => 'hidden');
#$c->itemconfigure('withtag', 'pic', -state => 'hidden');
foreach ($c->find('withtag', 'pic')) {
$c->itemconfigure($_, -state => 'hidden');
}
}
##############################################################
# setTitle - set the window title and the userinfo to the
# actual pic
##############################################################
sub setTitle {
my $title = '';
$title = basename($actpic)." - " if ((defined $actpic) and ($actpic ne '') and (-f $actpic));
$title .= "Mapivi $version $svnrevision";
# just a little gag
my (undef,undef,undef,$d,$m,$y) = getDateTime(time());
$title .= langf(" - Happy new year $y!") if ($d == 1 and $m == 1);
$top->title($title);
log_it(basename($actpic));
}
##############################################################
# increasePicPopularity
##############################################################
sub increasePicPopularity {
return unless ($config{trackPopularity});
my $dpic = shift;
if (defined $searchDB{$dpic}{POP}) {
$searchDB{$dpic}{POP}++;
}
else {
$searchDB{$dpic}{POP} = 1;
}
print langf("$dpic has been shown $searchDB{$dpic}{POP} times.\n") if $verbose;
}
##############################################################
# showMostPopularPics - display the Top 100 of the best rated pics
##############################################################
sub showMostPopularPics {
# open window
my $win = $top->Toplevel();
window_size($win, 80);
$win->title(lang('Best rated pictures - TOP 100'));
$win->iconimage($mapiviicon) if $mapiviicon;
my $text = lang('Searching ...');
my $butF = $win->Frame()->pack(-fill =>'x', -padx => 3, -pady => 3);
my $Xbut = $butF->Button(-text => lang('Close'),
-command => sub {
$win->destroy();
})->pack(-side => 'left', -expand => 0, -fill => 'x', -padx => 3, -pady => 3);
$butF->Label(-textvariable => \$text)->pack(-side => 'left', -expand => 1, -fill => 'x', -padx => 3, -pady => 3);
my $tlb = makeThumbListbox($win);
# key bindings
bind_exit_keys_to_button($win, $Xbut);
$win->bind('', sub { selectAll($tlb); } );
$win->bind('', sub {
return if (!$tlb->info('children'));
my $dpic = getNearestItem($tlb);
showPicInOwnWin($dpic); });
$win->bind('', sub {
my @sellist = getSelection($tlb);
return unless checkSelection($win, 1, 0, \@sellist, lang("picture(s)"));
show_multiple_pics(\@sellist, 0);
} );
# show picture in main window and in lighttable
$win->bind('', sub { open_pic_in_main($tlb); });
$win->bind('', sub { light_table_add_from_lb($tlb); } );
$win->Popup(-popover => 'cursor');
repositionWindow($win);
my @populatity_list = sort {
my $urga = 0;
$urga = $searchDB{$a}{URG} if (defined $searchDB{$a}{URG});
$urga = 9 if ($urga == 0);
my $urgb = 0;
$urgb = $searchDB{$b}{URG} if (defined $searchDB{$b}{URG});
$urgb = 9 if ($urgb == 0);
my $popa = 0;
$popa = $searchDB{$a}{POP} if (defined $searchDB{$a}{POP});
my $popb = 0;
$popb = $searchDB{$b}{POP} if (defined $searchDB{$b}{POP});
$urga <=> $urgb || $popb <=> $popa;
} keys %searchDB;
$text = lang('Loading ...');
$win->update();
my %thumbs;
foreach my $nr (0 .. 99) {
my $dpic = $populatity_list[$nr];
insertPic($tlb, $dpic, \%thumbs);
}
$text = lang('Ready');
$win->waitWindow;
# clean up memory - delete all found thumbnail photo objects
delete_thumb_objects(\%thumbs);
}
##############################################################
# resize window to x% of screensize and center it on screen
# (center does not work, at least on windows)
##############################################################
sub window_size {
my $win = shift;
my $size = shift; # in percent of screensize;
$size = $size/100;
my $w = int($size * $win->screenwidth);
my $h = int($size * $win->screenheight);
my $x = int(($win->screenwidth - $w)/2);
my $y = int(($win->screenheight - $h)/2);
$win->geometry("${w}x${h}+${x}+${y}");
}
##############################################################
# slideshow_all_pics - show all pictures of the search database
# in a slideshow
# pictures may be filtered based on rating and keywords
##############################################################
sub slideshow_all_pics {
my $set_or_start = shift;
if ($set_or_start == SETTINGS) {
# GUI to edit several filters stored in %conf hash
my $ok = picture_filter(lang("Filter all accessible pictures of your database to create a slideshow."));
return if (not $ok);
}
my @include_keys = split / /, $conf{slideshow_keywords_include}{value};
my @exclude_keys = split / /, $conf{slideshow_keywords_exclude}{value};
my @exclude_folders = split / /, $conf{slideshow_folders_exclude}{value};
my @pic_list;
log_it("Scanning database ...");
my $i = 0;
my $pw = progressWinInit($top, 'Filtering pictures ...');
my $pic_total = scalar(keys(%searchDB));
my %removed_by;
my $total = 0;
# build keyword/tag hash
#foreach my $dpic (keys %searchDB) {
while (my ($dpic, undef) = each %searchDB) {
last if progressWinCheck($pw);
$total = scalar @pic_list;
$i++;
progressWinUpdate($pw, "scanning ($i/$pic_total), found $total ...", $i, $pic_total);
# exclude non-JPEGS by file suffix (this is much faster than using is_a_JPEG())
if ($dpic !~ m/.*\.jp(g|eg)$/i) {
$removed_by{filesuffix}++;
next;
}
# exclude pics from certain folders
if (string_contains(dirname($dpic), \@exclude_folders)) {
$removed_by{folder}++;
next;
}
# include only pictures with certain keywords
if (@include_keys) {
if ((not defined $searchDB{$dpic}{KEYS}) or
($searchDB{$dpic}{KEYS} eq '') or
(string_contains_nor($searchDB{$dpic}{KEYS}, \@include_keys))) {
$removed_by{keyword}++;
next;
}
}
# don't show pictures with a low rating (but show pictures without rating)
if ($conf{slideshow_rating_exclude}{value} and
defined $searchDB{$dpic}{URG} and $searchDB{$dpic}{URG} >= $conf{slideshow_rating_level}{value}) {
$removed_by{rating}++;
next;
}
# don't show pictures without rating
if ($conf{slideshow_norating_exclude}{value} and not defined $searchDB{$dpic}{URG}) {
$removed_by{norating}++;
next;
}
# don't show pictures which have been shown more than n times
if ($conf{slideshow_pop_exclude}{value} and
defined $searchDB{$dpic}{POP} and $searchDB{$dpic}{POP} >= $conf{slideshow_pop_level}{value}) {
$removed_by{popularity}++;
next;
}
# exclude pictures with certain keywords
if (@exclude_keys) {
if (string_contains($searchDB{$dpic}{KEYS}, \@exclude_keys)) {
$removed_by{keyword}++;
next;
}
}
# exclude non-existing pictures (e.g. pictures stored on unconnected external media)
if (not -f $dpic) {
$removed_by{availability}++;
next;
}
# collect matching pics in a list
push @pic_list, $dpic;
last if ($conf{slideshow_number_limit}{value} and (scalar(@pic_list) >= $conf{slideshow_number}{value}));
}
progressWinEnd($pw);
log_it("Found $total pictures, $removed_by{keyword} removed due to keyword match.");
foreach my $reason (keys(%removed_by)) {
printf "%6d pictures removed by %s\n", $removed_by{$reason}, $reason;
}
if ($conf{slideshow_random}{value}) {
# shuffle randomly
fisher_yates_shuffle(\@pic_list);
}
else { # sort by name
@pic_list = sort { uc(basename($a)) cmp uc(basename($b)) } @pic_list;
}
show_multiple_pics(\@pic_list, 0, NORMAL, SHOW);
}
##############################################################
# set some picture filter options (e.g. for the slideshow)
##############################################################
sub picture_filter {
my $info_text = shift;
my $ok = 0;
my $w = 30;
# open window
my $win = $top->Toplevel();
$win->title(lang('Picture filter settings'));
$win->iconimage($mapiviicon) if $mapiviicon;
$win->Label(-text => $info_text, -anchor => 'w')->pack(-anchor => 'w');
# window frames
my $excf = $win->Frame(-bd => 1, -relief => 'raised')->pack(-fill => 'both', -padx => 6, -pady => 6);
$excf->Label(-text => lang('Exclude pictures ...'))->pack(-anchor=>'w', -padx => 3, -pady => 3);
my $incf = $win->Frame(-bd => 1, -relief => 'raised')->pack(-fill => 'both', -padx => 6, -pady => 6);
$incf->Label(-text => lang('Include pictures ...'))->pack(-anchor=>'w', -padx => 3, -pady => 3);
my $sortf = $win->Frame(-bd => 1, -relief => 'raised')->pack(-fill => 'both', -padx => 6, -pady => 6);
$sortf->Label(-text => lang('Sort pictures ...'))->pack(-anchor=>'w', -padx => 3, -pady => 3);
my $limitf = $win->Frame(-bd => 1, -relief => 'raised')->pack(-fill => 'both', -padx => 6, -pady => 6);
$limitf->Label(-text => lang('Limit number of pictures ...'))->pack(-anchor=>'w', -padx => 3, -pady => 3);
# exclude by rating
$excf->Checkbutton(-variable => \$conf{slideshow_rating_exclude}{value}, -text => lang('with rating lower than'))->pack(-anchor=>'w', -padx => 3, -pady => 3);
$excf->Scale(-variable => \$conf{slideshow_rating_level}{value},
-from => 1,
-to => 8,
-resolution => 1,
-orient => 'horizontal',
-showvalue => 1,
)->pack(-expand => 1, -fill => 'x', -padx => 6, -pady => 6);
$excf->Checkbutton(-variable => \$conf{slideshow_norating_exclude}{value}, -text => lang('without rating'))->pack(-anchor=>'w', -padx => 3, -pady => 3);
# exclude by popularity
$excf->Checkbutton(-variable => \$conf{slideshow_pop_exclude}{value}, -text => lang('shown more often than'))->pack(-anchor=>'w', -padx => 3, -pady => 3);
$excf->Scale(-variable => \$conf{slideshow_pop_level}{value},
-from => 1,
-to => 200,
-resolution => 1,
-orient => 'horizontal',
-showvalue => 1,
)->pack(-expand => 1, -fill => 'x', -padx => 6, -pady => 6);
# exclude by keywords
$excf->Label(-text => lang('matching one of these keywords (space separated, case insensitive)'), -anchor => 'w')->pack(-anchor => 'w', -padx => 3, -pady => 3);
$excf->Entry(-textvariable => \$conf{slideshow_keywords_exclude}{value}, -width => $w)->pack(-fill => 'x', -padx => 3, -pady => 3);
# exclude by folders
$excf->Label(-text => lang('in folders matching (space separated, case insensitive)'), -anchor => 'w')->pack(-anchor => 'w', -padx => 3, -pady => 3);
$excf->Entry(-textvariable => \$conf{slideshow_folders_exclude}{value}, -width => $w)->pack(-fill => 'x', -padx => 3, -pady => 3);
# include by keywords
$incf->Label(-text => lang('matching one of these keywords (space separated, case insensitive)'), -anchor => 'w')->pack(-anchor => 'w', -padx => 3, -pady => 3);
$incf->Entry(-textvariable => \$conf{slideshow_keywords_include}{value}, -width => $w)->pack(-fill => 'x', -padx => 3, -pady => 3);
# sort random or by filename
$sortf->Checkbutton(-variable => \$conf{slideshow_random}{value}, -text => lang('by random order'))->pack(-anchor=>'w', -padx => 3, -pady => 3);
# limit amount of pictures (low number will speed up time to scan database, but not all pictures are considered)
$limitf->Checkbutton(-variable => \$conf{slideshow_number_limit}{value}, -text => lang('use limit'))->pack(-anchor=>'w', -padx => 3, -pady => 3);
$limitf->Scale(-variable => \$conf{slideshow_number}{value},
-from => 2,
-to => scalar(keys(%searchDB)),
-resolution => 1,
-orient => 'horizontal',
-showvalue => 1,
)->pack(-expand => 1, -fill => 'x', -padx => 6, -pady => 6);
my $but_frame = $win->Frame()->pack(-fill =>'x');
my $ok_but = $but_frame->Button(-text => lang('OK'),
-command => sub {
$ok = 1;
$win->withdraw();
$win->destroy();
})->pack(-side => 'left', -expand => 1, -fill => 'x', -padx => 2, -pady => 3);
my $x_but = $but_frame->Button(-text => lang('Cancel'),
-command => sub {
$ok = 0;
$win->withdraw();
$win->destroy();
})->pack(-side => 'left', -expand => 1, -fill => 'x', -padx => 2, -pady => 3);
$win->Popup(-popover => 'cursor');
repositionWindow($win);
$win->waitWindow;
return $ok;
}
##############################################################
# check if any items of the list are contained in the string
# case insensitive!
##############################################################
sub string_contains {
my $string = shift;
my $list_ref = shift;
my $match = 0;
if (defined $string) {
foreach (@$list_ref) {
if ($string =~ m/$_/i) {
$match = 1;
last;
}
}
}
return $match;
}
##############################################################
# check if any items of the list are not contained in the string
# case insensitive! (this is equivalent to an AND-Search!)
##############################################################
sub string_contains_not {
my $string = shift;
my $list_ref = shift;
my $match = 0;
if (defined $string) {
foreach (@$list_ref) {
if (not ($string =~ m/$_/i)) {
$match = 1;
last;
}
}
}
return $match;
}
##############################################################
# check if any items of the list are not contained in the string
# case insensitive! (this is equivalent to a NOR-Search!)
##############################################################
sub string_contains_nor {
my $string = shift;
my $list_ref = shift; # include keyword list
my $match = 0;
if (defined $string) {
# or-function "Tim, Tom" -> "Tim|Tom"
my $pattern = '';
foreach (@$list_ref) {
$pattern .= $_.'|';
}
# remove last "|" again
$pattern = substr($pattern, 0, length($pattern)-1);
if (not ($string =~ m/$pattern/i)) {
$match = 1;
}
}
return $match;
}
##############################################################
# exif_histogram - display a histogram of some EXIF data
##############################################################
sub exif_histogram {
my $lb = shift;
my @pics;
# if a listbox reference is given we try to get the selected pictures from there
if (defined $lb and Exists($lb)) {
@pics = getSelection($lb);
}
# else we use all pictures of the search database
if (!@pics or (scalar @pics < 1)) {
@pics = keys %searchDB;
}
# open window
my $win = $top->Toplevel();
$win->title(lang('EXIF histograms'));
$win->iconimage($mapiviicon) if $mapiviicon;
my $text = langf("Collecting EXIF data in ".scalar @pics." pictures ...");
my $c_w = 800;
my $c_h = 600;
my $border = 20;
$win->Label(-textvariable => \$text)->pack(-expand => 0, -fill => 'x');
my $canvas = $win->Canvas(-width => $c_w,
-height => $c_h,
-background => $conf{color_bg}{value},
-relief => 'sunken',)->pack(-side => 'top', -padx => 3, -pady => 3);
my %balloon_hash;
$balloon->attach($canvas, -balloonposition => "mouse", -msg => \%balloon_hash );
my $butF = $win->Frame()->pack(-fill =>'x', -padx => 3, -pady => 3);
my $Xbut = $butF->Button(-text => lang('Close'),
-command => sub {
$win->destroy();
})->pack(-side => 'left', -expand => 1, -fill => 'x', -padx => 3, -pady => 3);
bind_exit_keys_to_button($win, $Xbut);
$win->Popup(-popover => 'cursor');
repositionWindow($win);
my %histogram;
my %histogram_long = (
'focal_distance35' => lang('Focal distance in 35mm (mm)'),
'focal_distance' => lang('Focal distance (mm)'),
'aperture' => lang('Aperture (F)'),
'iso' => lang('Film speed (ISO)'),
'exposure_time' => lang('Exposure time (1/s)'),
);
$win->Busy;
#my %aperture;
foreach my $dpic (@pics) {
next unless exists $searchDB{$dpic};
next unless exists $searchDB{$dpic}{EXIF};
my $exif = $searchDB{$dpic}{EXIF};
# Focal distance - the EXIF info should look like this: ... 105mm ... with no brackets
if ($exif =~ m|.*[^\(](\d+)mm[^\)].*|) {
$histogram{focal_distance}{$1}++;
}
if ($exif =~ m|.*\((\d+)mm\).*|) {
$histogram{focal_distance35}{$1}++;
}
# Aperture - the EXIF info should look like this: ... F2.8 ...
if ($exif =~ m|.* F(\d+\.\d) .*|) {
$histogram{aperture}{$1}++;
}
# ISO - the EXIF info should look like this: ... ISO400 ...
if ($exif =~ m|.* ISO(\d+) .*|) {
$histogram{iso}{$1}++;
}
# exposure time - the EXIF info should look like this: ... 1/125s ...
if ($exif =~ m|.* (\d+)\/(\d+)s .*|) {
$histogram{exposure_time}{$2}++ if ($1 == 1);
}
}
# my @populatity_list = sort {
# my $popa = 0;
# $popa = $searchDB{$a}{POP} if (defined $searchDB{$a}{POP});
# my $popb = 0;
# $popb = $searchDB{$b}{POP} if (defined $searchDB{$b}{POP});
# $popb <=> $popa;
# } keys %searchDB;
$text = lang('Printing histogram ...');
$win->update();
#my $font = $win->Font(-family => $config{FontFamily}, -size => $config{FontSize});
$c_w -= 2*$border;
$c_h -= 2*$border;
my $size_min = 3;
my $nr_of_diagrams = keys %histogram;
# diagram height
my $d_h = ($c_h - ($nr_of_diagrams - 1)*$border)/$nr_of_diagrams ;
# bottom line of next diagram
my $y = 0;
foreach my $kind (sort keys %histogram) {
$y = $y + $border + $d_h;
# determine maximum values of this hash
my $max_value = 0;
my $max_key = 0;
my $sum = 0;
foreach (keys %{$histogram{$kind}}) {
$max_value = $histogram{$kind}{$_} if ($histogram{$kind}{$_} > $max_value);
$max_key = $_ if ($_ > $max_key);
$sum += $histogram{$kind}{$_};
}
draw_coordinate_system($canvas, $border, $y-$d_h, $c_w, $d_h);
foreach (sort {$a <=> $b} keys %{$histogram{$kind}}) {
my $x = $_/$max_key*$c_w + $border;
$x = sqrt($_/$max_key)*$c_w + $border if ($kind eq 'exposure_time');;
my $h = $histogram{$kind}{$_}/$max_value*$d_h;
$h = $size_min if ($h < $size_min); # minimum height
$canvas->createLine( $x, $y, $x, $y-$h, -fill => 'red', -width => $size_min, -tags => "$_/$histogram{$kind}{$_}");
my $procent = sprintf "%2.2f%%", $histogram{$kind}{$_}/$sum*100;
$balloon_hash{"$_/$histogram{$kind}{$_}"} = langf("$histogram_long{$kind}: ${_} $histogram{$kind}{$_} pictures ($procent)\nFound this information type in $sum pictures.");
}
# diagram title
$canvas->createText($border + $c_w/2, $y-$d_h, -font => $font, -fill => $conf{color_fg}{value}, -text => $histogram_long{$kind}, -anchor => 'n',);
}
$win->Unbusy;
$text = langf("EXIF histogram of ".scalar @pics." pictures. (Hint: Stop mouse pointer above a line to see details.)");
$win->waitWindow;
}
##############################################################
##############################################################
sub draw_coordinate_system {
my ($c, $x, $y, $w, $h) = @_;
# y-axis
$c->createLine($x, $y+$h, $x, $y-8,
-fill => $conf{color_fg}{value},
-tags => 'coordinate system',
-arrow => 'last',
-arrowshape => [6,6,3],
-width => 1,
);
# x-axis
$c->createLine($x, $y+$h, $x+$w+8, $y+$h,
-fill => $conf{color_fg}{value},
-tags => 'coordinate system',
-arrow => 'last',
-arrowshape => [6,6,3],
-width => 1,
);
}
##############################################################
# stopWatchStart
##############################################################
my $stopWatchTime;
sub stopWatchStart {
$stopWatchTime = Tk::timeofday();
}
##############################################################
# stopWatchStop
##############################################################
sub stopWatchStop {
my $text = '';
$text = shift;
printf langf("stopWatch: %.5f secs ($text)\n"), (Tk::timeofday() - $stopWatchTime);
}
##############################################################
# selectThumb
##############################################################
sub selectThumb {
my $lb = shift;
my $index = shift;
$lb->selectionClear();
return unless (defined $index);
unless ($lb->info("exists", $index)) {
warn "selectThumb: $index is not available!" if $verbose;
return;
}
$lb->selectionSet($index);
$lb->anchorSet($index);
$lb->see($index);
if ($config{CenterThumb}) {
my $next = $lb->info('next', $index);
my $prev = $lb->info('prev', $index);
$lb->see($prev) if ($prev);
$lb->update;
$lb->see($next) if ($next);
}
$lb->update;
showNrOf();
}
##############################################################
# selectAll
##############################################################
sub selectAll {
my $lb = shift;
my @item = $lb->info('children');
return unless (@item);
$lb->selectionSet($item[0], $item[-1]); # Hlist doesn't work with 'end' or 'all'
showNrOf() if ($lb == $picLB);
}
##############################################################
# selectBak
##############################################################
sub selectBak {
$picLB->selectionClear();
my @pics = $picLB->info('children');
foreach (@pics) {
if ($_ =~ m/.*-bak\.jp(g|eg)$/i) {
$picLB->selectionSet($_);
}
}
showNrOf();
if (!defined $picLB->info('selection')) {
$top->messageBox(-icon => 'info', -message => "Nothing selected!\nThere are no file names matching the pattern: \"*-bak.jp(e)g\".",
-title => "No backups", -type => 'OK');
}
}
##############################################################
# selectInv
##############################################################
sub selectInv {
my @sellist = $picLB->info('selection');
$picLB->selectionClear();
my @pics = $picLB->info('children');
foreach (@pics) {
if (!isInList($_, \@sellist)) {
$picLB->selectionSet($_);
}
}
showNrOf();
}
##############################################################
# getThumbFileName - return the location of the corresponding
# thumbnail file (full path)
##############################################################
sub getThumbFileName {
my $dpic = shift;
my $dir = dirname( $dpic);
my $pic = basename($dpic);
# normalize the path
$dir =~ s!\\!\/!g; # replace Windows path delimiter with UNIX style \ -> /
if (defined $thumbDBhash{$dir}) {
return $thumbDBhash{$dir}."/$pic";
}
# the default place for thumbnails is always a sub folder called ".thumbs" in the actual folder
my $thumbdir = "$dir/$thumbdirname";
# central thumbDB
if (($config{CentralThumbDB}) or # config option set to central thumbdir
(!-d $dir) or # if the folder is not mounted/available
((-d $thumbdir) and (!-w $thumbdir)) or # or .thumbdir exists but is write protected
(-f "$dir/.nothumbs") or # or file .nothumbs is found
((!-w $dir) and (!-d $thumbdir))) { # or dir is write protected but there is no .thumbdir
$dir = cut_device_letter($dir);
$thumbdir = "$thumbDB/$dir";
$thumbdir =~ s/\/+/\//g; # replace multiple slashes with one // -> /
}
$thumbDBhash{$dir} = $thumbdir; # store for quicker response
return "$thumbdir/$pic";
}
##############################################################
# get rid of the device names (C:\ d:/ etc.) in Windows paths
##############################################################
sub cut_device_letter {
my $dir = shift;
if ($EvilOS) {
# in windows we have to get rid of the device names (C:\ d:/ etc.) because they may change between sessions and we can't use them inside a path
print "cut_device_letter: $dir " if $verbose;
$dir =~ s!^[a-z]:/!!i; # for slash
$dir =~ s!^[a-z]:\\!!i; # for backslash
print "-> $dir\n" if $verbose;
}
return $dir;
}
##############################################################
# generateThumbs - generate thumbnails for each picture
# remove outdated thumbs in folder $actdir (global variable!)
##############################################################
sub generateThumbs {
print "generateThumbs\n" if $verbose;
my $ask = shift; # ASK = ask the user befor making a thumbnail dir, NO_ASK
my $show = shift; # SHOW = show the generated thumbs in $picLB, NO_SHOW
my $getpics = shift; # optional bool, get the pics with getpics not from the listbox
my $nrofprocs = 0;
my @pics;
if ((defined $getpics) and ($getpics == 1)) {
@pics = getPics($actdir, WITH_PATH, NO_CHECK_JPEG);
# if the thumbs won't be shown, no need to sort
sortPics($config{SortBy}, $config{SortReverse}, \@pics) if ($show == SHOW);
}
else {
@pics = $picLB->info('children'); # this should be much faster than getPics($actdir);
}
# remove outdated thumbs and exif data
cleanSubDirs($actdir);
return 0 if (@pics <= 0);
$nrToConvert = 0;
# count first
foreach my $lpic (@pics) {
my $dpic = $lpic;
next if (!getRealFile(\$dpic));
my $thumb = getThumbFileName($lpic);
if (aNewerThanb($dpic, $thumb)) {
$nrToConvert++; # count the nr of thumbs to generate/refresh
}
}
return 0 if ($nrToConvert == 0); # nothing to do
# ask the user, if he wants to update the thumbs now
if ($config{AskGenerateThumb}) {
my $rc = checkDialog("Generate thumbnails?",
"There are $nrToConvert thumbnails to generate.\nShall I do this now?",
\$config{AskGenerateThumb},
"ask every time",
'',
'OK', 'Cancel');
return 0 if ($rc ne 'OK');
}
my $prefix = thumbnail_prefix(\%config);
# generate thumbs
my $generated_thumbs = 0;
foreach my $lpic (@pics) {
my $dpic = $lpic;
next if (!getRealFile(\$dpic));
my $pic = basename($dpic);
my $thumb = getThumbFileName($lpic);
next if (!aNewerThanb($dpic, $thumb));
if (-z $dpic) { # file is empty (size zero)
log_it("Generating thumbnails: $pic is an empty file. Skipping.");
next;
}
removeFile($thumb);
my $thumbdir = dirname($thumb);
next if (!makeDir($thumbdir, $ask));
if (!-w $thumbdir) {
log_it("Thumb folder $thumbdir is not writeable, so mapivi is not able to generate thumbnails");
next;
}
# try to get the embedded thumbnail when option is selected and for all RAW pictures
if ($config{UseEXIFThumb} or is_raw_file($dpic)) {
my $errors = '';
extractThumb($dpic, $thumb, \$errors);
# resize/process according thumbnail options
if (-f $thumb) {
# especially for RAW files we need both "JPEG:" statements so we can't use thumbnail_postfix here
my $com = "$prefix JPEG:\"$thumb\" JPEG:\"$thumb\" ";
execute($com);
}
}
# found a EXIF thumbnail -> show it
if (-f $thumb) {
# here we increase the process counter, just because ...
proccount(1);
# ... in updateOneThumb it will be decreased
updateOneThumb($thumb, $lpic, $show);
next; # thumbnail finished, do next pic in loop
}
my $string = thumbnail_postfix($prefix, $dpic, $thumb);
print "command: $string\n" if $verbose;
if (!$EvilOS) { # running on a "good" OS like Linux we can use background processes :)
# start a background process for each pic
my $fh = Tk::IO->new(-linecommand => \&nop, -childcommand => [\&updateOneThumb, $thumb, $lpic, $show]);
#$hiresstart = [gettimeofday]; # hires - measure the loading time
$fh->exec($string);
proccount(1); # count processes
$nrofprocs = proccount();
if ($nrofprocs >= $config{MaxProcs}) {
# waiting for current process to finish
$fh->wait();
}
}
else { # we run on a evil OS like windows - no threading :(
proccount(1); # count processes
(system "$string") == 0 or warn "$string failed: $!";
updateOneThumb($thumb, $lpic, $show);
}
$generated_thumbs++;
}
return $generated_thumbs;
}
##############################################################
# generateOneThumb
##############################################################
sub generateOneThumb {
my $dpic = shift;
my $thumb = getThumbFileName($dpic);
my $prefix = thumbnail_prefix(\%config);
my $string = thumbnail_postfix($prefix, $dpic, $thumb);
execute($string);
}
##############################################################
# cleanSubDirs - remove thumbs and exif infos without a
# corresponding picture
##############################################################
sub cleanSubDirs {
my $dir = shift;
my $thumbdir = dirname(getThumbFileName("$dir/dummy.jpg"));
my $exifdir = "$dir/$exifdirname";
return if (!-d $dir);
# clean thumb and exif dir
foreach my $subdir ($thumbdir, $exifdir) {
if (-d $subdir) {
my @subpics = getPics($subdir, JUST_FILE, NO_CHECK_JPEG); # no sort needed
foreach my $pic (@subpics) {
if (!-f "$dir/$pic") {
removeFile("$subdir/$pic");
}
}
}
}
}
##############################################################
# thumbnail_prefix - build up the command string for the
# generation of thumbnails depending on
# the settings in the given config hash
##############################################################
sub thumbnail_prefix {
my $conf = shift;
my $pre = '';
$pre = " montage -thumbnail \"$conf->{'ThumbSize'}x$conf->{'ThumbSize'}>+$conf->{'ThumbBorder'}+$conf->{'ThumbBorder'}\" -quality $conf->{'ThumbQuality'} -background \"$conf->{'ColorThumbBG'}\" ";
#$pre = " montage -size \"$conf->{'ThumbSize'}x$conf->{'ThumbSize'}>\" -geometry \"$conf->{'ThumbSize'}x$conf->{'ThumbSize'}>+$conf->{'ThumbBorder'}+$conf->{'ThumbBorder'}\" -quality $conf->{'ThumbQuality'} -background \"$conf->{'ColorThumbBG'}\" ";
#$pre .= "-frame $conf->{'ThumbBorder'}x$conf->{'ThumbBorder'} " if $conf->{UseThumbFrame};
$pre .= "-shadow " if $conf->{UseThumbShadow};
# ! Sharpen is the most time consuming option, when building thumbnails!
if ($conf->{ThumbSharpen} > 0) {
$pre .= "-sharpen $conf->{'ThumbSharpen'} " # the higher the value the slower
}
return $pre;
}
##############################################################
# build the second part of the image magick command line
# this is only separated from the first part (thumbnail_prefix)
# due to performance reasons (prefix is generic and has to be
# called just once, while postfix is specific for each file)
##############################################################
sub thumbnail_postfix {
my ($prefix, $dpic, $thumb) = @_;
# thumbnail is always in JPEG format, but the suffix of the picture is not changed
my $string = "$prefix \"$dpic\"";
# for avi videos or animated GIFs we generate just one thumbnail from the first frame
$string .= "[0]" if (($dpic =~ /.*\.avi$/i) or ($dpic =~ /.*\.gif$/i));
$string .= " JPEG:\"$thumb\" ";
return $string;
}
##############################################################
# light_table_open_window
##############################################################
sub light_table_open_window {
if (Exists($ltw)) {
$ltw->deiconify;
$ltw->raise;
$ltw->focus;
return;
}
# open window
$ltw = $top->Toplevel();
$ltw->title(lang('Picture collection'));
$ltw->iconimage($mapiviicon) if $mapiviicon;
$ltw->bind('', sub {light_table_close();});
$ltw->bind('', sub {light_table_close();});
$ltw->bind('', sub {light_table_select_all();});
$ltw->bind('', sub {fullscreen($ltw);});
# call quitMain when the window is closed by the window manager
$ltw->protocol("WM_DELETE_WINDOW" => sub { light_table_close(); });
if ($EvilOS) {
$ltw->DropSite
(-dropcommand => [\&light_table_dragAndDropExtern, $ltw],
-droptypes => 'Win32'
);
}
# bool flag: if true we ask the user for confirmation before closing
$ltw->{unsafed_changes} = 0;
# status bars
my $collection_frame = $ltw->Frame()->pack(-anchor => 'w', -fill => 'x', -expand => 0, -pady => 1);
$collection_frame->Label(-text => lang('Collection').':')->pack(-side => 'left', -padx => 2, -pady => 2);
$collection_frame->Label(-textvariable => \$ltw->{folder})->pack(-side => 'left', -padx => 2, -pady => 2);
$collection_frame->Label(-textvariable => \$ltw->{collection})->pack(-side => 'left', -padx => 2, -pady => 2);
$collection_frame->Label(-text => ', '.lang('File').':')->pack(-side => 'left', -padx => 2, -pady => 2);
$collection_frame->Label(-textvariable => \$ltw->{file})->pack(-side => 'left', -padx => 2, -pady => 2);
$collection_frame->Label(-text => ', '.lang('Unsaved').':')->pack(-side => 'left', -padx => 2, -pady => 2);
$collection_frame->Label(-textvariable => \$ltw->{unsafed_changes})->pack(-side => 'left', -padx => 2, -pady => 2);
my $status_frame = $ltw->Frame()->pack(-anchor => 'w', -fill => 'x', -expand => 0, -pady => 1);
$status_frame->Label(-textvariable => \$ltw->{label})->pack(-side => 'left', -padx => 2, -pady => 2);
# main canvas
$ltw->{frame} = $ltw->Scrolled('Canvas',
-scrollbars => 'oe',
-confine => 1,
-xscrollincrement => 117,
-yscrollincrement => 117,
-height => 570,
-width => 370,
-relief => 'flat',
-borderwidth => 0,
-highlightthickness => 0,
)->pack(-fill =>'both', -expand => 1, -padx => 2, -pady => 2);
$ltw->{canvas} = $ltw->{frame}->Subwidget('canvas');
# add menu
$ltw->{menu} = $ltw->Menu;
$ltw->configure(-menu => $ltw->{menu});
my $file_menu = $ltw->{menu}->cascade(-label => lang('Slideshow'));
$file_menu->cget(-menu)->configure(-title => lang('Slideshow menu'));
$file_menu->command(-label => lang('Open ...'), -command => sub { collection_open(RESET); });
$file_menu->separator;
$file_menu->command(-label => lang('Show slideshow'), -command => sub { show_multiple_pics($ltw->{canvas}->{thumb_list}, 0); });
$file_menu->command(-label => lang('Show slideshow, start from selected picture'), -command => sub {
my @sel = $ltw->{canvas}->find('withtag', 'THUMBSELECT_MH');
return unless checkSelection($ltw, 1, 0, \@sel, lang("picture(s)"));
my $dpic = get_path_from_id($ltw->{canvas},$sel[0]);
my $index = index_in_list($dpic, $ltw->{canvas}->{thumb_list});
show_multiple_pics($ltw->{canvas}->{thumb_list}, $index); });
$file_menu->command(-label => lang('Show selected pictures'), -command => sub { light_table_show_sel_pics($ltw, $ltw->{canvas}->{thumb_list}); });
$file_menu->command(-label => lang('Open selected pictures in external viewer'), -command => sub { openPicInViewer($ltw->{canvas}); }, -accelerator => '');
$file_menu->separator;
$file_menu->command(-label => lang('Save'), -command => sub {
if ((defined $ltw->{folder} and $ltw->{folder} ne '') and (defined $ltw->{collection} and $ltw->{collection} ne '')) {
light_table_save();
}
else {
light_table_save_as();
}
});
$file_menu->command(-label => lang('Save as ...'), -command => sub { light_table_save_as(); });
$file_menu->separator;
$file_menu->command(-label => lang('Import from file ...'), -command => sub { light_table_open(RESET); });
$file_menu->command(-label => lang('Add from file ...'), -command => sub { light_table_open(ADD); });
$file_menu->command(-label => lang('Export to file'), -command => sub {
if ((defined $ltw->{file}) and (-f $ltw->{file})) {
light_table_save_to_file($ltw->{file});
}
else {
light_table_save_to_file_as();
}
});
$file_menu->command(-label => lang('Export to file as ...'), -command => sub { light_table_save_to_file_as(); });
$file_menu->separator;
$file_menu->command(-label => lang('Clear'), -command => sub { undef @{$ltw->{canvas}->{thumb_list}}; light_table_clear(); light_table_reset_collection();});
$file_menu->command(-label => lang('Update'), -command => sub { light_table_reorder($ltw->{canvas}, $ltw->{canvas}->{thumb_list}); light_table_update_selection();});
$file_menu->command(-label => lang('Reload thumbnails'), -command => sub { light_table_reload(); });
$file_menu->separator;
$file_menu->command(-label => lang('Close'), -command => sub { light_table_close(); });
my $sort_menu = $ltw->{menu}->cascade(-label => lang('Sort'));
$sort_menu->command(-label => lang('File name (A - Z)'),
-command => sub {
$ltw->Busy;
sortPics('name', 0, $ltw->{canvas}->{thumb_list});
$ltw->{unsafed_changes} = 1; # set dirty bit
$ltw->Unbusy;
light_table_reorder($ltw->{canvas}, $ltw->{canvas}->{thumb_list});
light_table_update_selection();
});
$sort_menu->command(-label => lang('File name (Z - A)'),
-command => sub {
$ltw->Busy;
sortPics('name', 1, $ltw->{canvas}->{thumb_list});
$ltw->{unsafed_changes} = 1; # set dirty bit
$ltw->Unbusy;
light_table_reorder($ltw->{canvas}, $ltw->{canvas}->{thumb_list});
light_table_update_selection();
});
$sort_menu->separator;
$sort_menu->command(-label => lang('Date (new first)'),
-command => sub {
$ltw->Busy;
sortPics('exifdate', 0, $ltw->{canvas}->{thumb_list});
$ltw->{unsafed_changes} = 1; # set dirty bit
$ltw->Unbusy;
light_table_reorder($ltw->{canvas}, $ltw->{canvas}->{thumb_list});
light_table_update_selection();
});
$sort_menu->command(-label => lang('Date (old first)'),
-command => sub {
$ltw->Busy;
sortPics('exifdate', 1, $ltw->{canvas}->{thumb_list});
$ltw->{unsafed_changes} = 1; # set dirty bit
$ltw->Unbusy;
light_table_reorder($ltw->{canvas}, $ltw->{canvas}->{thumb_list});
light_table_update_selection();
});
$sort_menu->separator;
$sort_menu->command(-label => lang('Rating (high first)'),
-command => sub {
$ltw->Busy;
sortPics('urgency', 0, $ltw->{canvas}->{thumb_list});
$ltw->{unsafed_changes} = 1; # set dirty bit
$ltw->Unbusy;
light_table_reorder($ltw->{canvas}, $ltw->{canvas}->{thumb_list});
light_table_update_selection();
});
$sort_menu->command(-label => lang('Rating (low first)'),
-command => sub {
$ltw->Busy;
sortPics('urgency', 1, $ltw->{canvas}->{thumb_list});
$ltw->{unsafed_changes} = 1; # set dirty bit
$ltw->Unbusy;
light_table_reorder($ltw->{canvas}, $ltw->{canvas}->{thumb_list});
light_table_update_selection();
});
my $opt_menu = $ltw->{menu}->cascade(-label => lang("Options"));
$ltw->{show_balloon} = 1; # todo: move to config hash
$ltw->{show_status} = 1; # todo: move to config hash
$opt_menu->checkbutton(-label => lang("Show picture info"), -variable => \$ltw->{show_balloon}, -command => sub { light_table_balloon();});
# window resize event
$ltw->bind("" => sub {
# get canvas size
my $cw = $ltw->{canvas}->width;
my $ch = $ltw->{canvas}->height;
# compare with last size
if (defined $ltw->{LAST_CANVAS_WIDTH} and defined $ltw->{LAST_CANVAS_HEIGHT}) {
# if the canvas size didn't change we need no reorder
return if (($cw == $ltw->{LAST_CANVAS_WIDTH}) and ($ch == $ltw->{LAST_CANVAS_HEIGHT}));
}
# store new size
$ltw->{LAST_CANVAS_WIDTH} = $cw;
$ltw->{LAST_CANVAS_HEIGHT} = $ch;
# if there is a timer running cancel it
$ltw->{LAST_RESIZE_TIMER_MH}->cancel if ($ltw->{LAST_RESIZE_TIMER_MH});
$ltw->{LAST_RESIZE_MH} = Tk::timeofday;
# after 200 msec we reorder the thumbnails according to the new geometry to give a preview
$ltw->{LAST_RESIZE_TIMER_MH} = $ltw->after(200, sub {
light_table_reorder($ltw->{canvas}, $ltw->{canvas}->{thumb_list});
light_table_update_selection();
});
});
my $context_menu = $ltw->Menu(-title => lang("Context Menu"));
$ltw->bind('', sub {
$context_menu->Popup(-popover => "cursor", -popanchor => "nw");
} );
$ltw->bind('', sub { light_table_delete(); });
$ltw->bind('', sub { light_table_show_sel_pics($ltw, $ltw->{canvas}->{thumb_list}); });
$ltw->bind('', sub { openPicInViewer($ltw->{canvas}); });
$context_menu->command(-image => compound_menu($top, lang('move selected to top'), 'go-first.png'), -command => sub { light_table_shift('top'); });
$context_menu->command(-image => compound_menu($top, lang('move selected to bottom'), 'go-last.png'), -command => sub { light_table_shift('bottom'); });
$context_menu->command(-label => lang('remove selected from collection'),
-accelerator => "",
-command => sub { light_table_delete(); });
$context_menu->separator; # ----------------------- #
$context_menu->command(-label => lang('Select all'), -command => sub { light_table_select_all(); }, -accelerator => '');
$context_menu->command(-label => lang('Select to end'), -command => sub { light_table_select_to_end(); });
$context_menu->separator; # ----------------------- #
addFileActionsMenu($context_menu, $ltw->{canvas});
$context_menu->command(-label => lang('copy and rename selected'),
-command => sub { light_table_copy_rename(); });
$context_menu->command(-image => compound_menu($top, lang('Copy to print ...'), 'printer.png'), -command => sub { copyToPrint($ltw->{canvas}); });
$context_menu->separator; # ----------------------- #
$context_menu->command(-image => compound_menu($top, lang('Crop (lossless) ...'), 'edit-cut.png'), -command => sub { crop($ltw->{canvas}); }, -accelerator => "");
$context_menu->command(-label => lang('Collage/index print ...'),
-command => sub { my @pics = selection_get_sort($ltw->{canvas}, $ltw->{canvas}->{thumb_list}); indexPrint(\@pics); });
$context_menu->separator; # ----------------------- #
$context_menu->command(-image => compound_menu($top, lang('Open pictures in new window'), 'image-x-generic.png'),
-command => sub { light_table_show_sel_pics($ltw, $ltw->{canvas}->{thumb_list});}, -accelerator => '');
$context_menu->command(-image => compound_menu($top, lang('Open pictures in external viewer'), 'image-x-generic.png'),
-command => sub { openPicInViewer($ltw->{canvas}); });
$ltw->{canvas}->{thumb_distance} = 5; # store values also in canvas
$ltw->{canvas}->{thumb_size} = 108; # for light_table_reorder
$ltw->Popup;
checkGeometry(\$config{LtwGeometry});
$ltw->geometry($config{LtwGeometry});
}
##############################################################
##############################################################
sub collection_open {
my @collections;
foreach my $folder (keys %slideshows) {
# safety check: neither $folder nor $collection must contain string " - "
# as this is used as delimiter
warn "folder \"$folder\" contains delimiter string!" if ($folder =~ m/.* - .*/);
foreach my $collection (keys %{$slideshows{$folder}}) {
warn "collection \"$collection\" contains delimiter string!" if ($folder =~ m/.* - .*/);
push @collections, "$folder - $collection";
}
}
@collections = sort @collections;
my $title = 'Open collection';
my $text = 'Please select collection to open';
my @sellist;
return 0 unless (mySelListBoxDialog($title, $text, SINGLE, 'OK', \@sellist, @collections));
if ($sellist[0]) {
my $fold_col = $collections[$sellist[0]] ;
my @tmp = split / - /, $fold_col;
my $folder = $tmp[0];
my $collection = $tmp[1];
if (exists $slideshows{$folder}{$collection}) {
my $pics = $slideshows{$folder}{$collection}{pics};
#my $file = $slideshows{$folder}{$collection}{file};
light_table_edit($pics, $folder, $collection);
log_it("Open collection: $folder $collection");
} else {
log_it("Error in open collection: $folder $collection does not exists!");
}
}
}
##############################################################
##############################################################
sub light_table_show_sel_pics {
my $widget = shift;
my $picture_list_ref = shift;
my @pics = selection_get_sort($widget->{canvas}, $picture_list_ref);
return unless checkSelection($widget, 1, 0, \@pics, lang("picture(s)"));
show_multiple_pics(\@pics, 0);
}
##############################################################
# light_table_open
##############################################################
sub light_table_open {
my $mode = shift; # must be ADD or RESET
my $filei = shift; # optional slideshow file
my ($ok, $errors, $info, $doubles_count, $doubles, $file) = light_table_open_int($mode, $filei);
my $text = '';
$text .= "These $doubles_count pictures are already in the slideshow and have been skipped:\n$doubles\n\n" if ($doubles_count > 0);
$text .= "Errors while reading $file:\n$errors" if ($errors ne '');
$text .= "\nInformation while reading $file:\n$info" if ($info ne '');
showText("Information and Errors", $text, NO_WAIT);
if ($ok and $mode == RESET) {
$ltw->title(lang('Collection').': '.basename($file));
$ltw->{file} = $file;
}
}
##############################################################
# light_table_reopen - same as light_table_open, but shows only
# errors and does not change the slideshow file name
##############################################################
sub light_table_reopen {
my $mode = shift; # must be ADD or RESET
my $filei = shift; # optional slideshow file
my ($ok, $errors, $info, $doubles_count, $doubles, $file) = light_table_open_int($mode, $filei);
if ($$errors ne '') {
my $text = '';
$text .= "These $doubles_count pictures are already in the slideshow and have been skipped:\n$doubles\n\n" if ($doubles_count > 0);
$text .= "Errors while reading $file:\n$$errors" if ($$errors ne '');
$text .= "\nInformation while reading $file:\n$$info" if ($$info ne '');
showText("Information and Errors", $text, NO_WAIT);
}
}
##############################################################
# light_table_open_int
##############################################################
sub light_table_open_int {
my $mode = shift; # must be ADD or RESET
my $file = shift; # optional slideshow file
my $doubles = '';
my $doubles_count = 0;
my $text = 'Open';
$text = 'Add to' if ($mode == ADD);
# open file requester only when needed
if (!defined $file or !-f $file) {
my $types = [ ['gqview slideshow', '.gqv',], ['XnView slideshow', '.sld',], ['All Files', '*',], ];
$file = $ltw->getOpenFile(-title => "$text slideshow", -defaultextension => 'gqv', -initialdir => $config{SlideShowDir}, -filetypes => $types);
}
return (0, 'No valid file', '', $doubles_count, $doubles, $file) if ((!defined $file) or ($file eq '') or (!-f $file));
unless (-T $file) {
$ltw->messageBox(-icon => 'warning',
-message => 'Please select a valid slideshow (ASCII) file.',
-title => 'Wrong file type',
-type => 'OK');
return (0, 'Wrong file type', '', $doubles_count, $doubles, $file);
}
$config{SlideShowDir} = dirname($file) if (-d dirname($file));
my ($ok, $errors, $info, $pics) = read_slideshow_from_file($file);
if ($mode == RESET) {
# reset list and clean up canvas
undef @{$ltw->{canvas}->{thumb_list}};
light_table_clear();
}
my @pics_valid;
foreach my $dpic (@$pics) {
if (isInList($dpic, $ltw->{canvas}->{thumb_list})) {
$doubles .= "$dpic\n";
$doubles_count++;
}
else {
push @pics_valid, $dpic;
}
}
# add pics to end of thumb list
push @{$ltw->{canvas}->{thumb_list}}, @pics_valid;
# add new pictures to collection (light table)
light_table_add_list(\@pics_valid);
$ltw->{label} = scalar(@{$ltw->{canvas}->{thumb_list}}).' '.lang('pictures');
return (1, $errors, $info, $doubles_count, $doubles, $file);
}
##############################################################
##############################################################
sub read_slideshow_from_file {
my $file = shift;
my $fh;
my @pics;
my $info = '';
my $error = '';
if (!open($fh, '<', $file)) {
warn "read_slideshow_from_file: Couldn't open $file: $!";
return (0, "Couldn't open $file: $!", $info, \@pics);
}
my $pic_number = 0;
my $not_found = 0;
my $double = 0;
while (<$fh>) {
chomp; # no newline
if ($_ =~ m|\"(.*)\"|) { # match just quoted lines
$pic_number++;
my $dpic;
# $dpic may also have a relative path!
$dpic = File::Spec->rel2abs($1, dirname($file));
# replace Windows path delimiter with UNIX style \ -> /
$dpic =~ s!\\!\/!g;
if (-f $dpic) {
if (isInList($dpic, \@pics)) {
$double++;
$info .= "info: $dpic is already in list\n";
}
else {
push @pics, $dpic;
}
}
else {
$not_found++;
$error .= "error: $dpic not found! (number: $pic_number)\n";
}
}
else { $info .= "info: ignoring line \"$_\"\n"; }
}
$info .= basename($file)." references $pic_number pictures, ";
$info .= "$not_found could not be found, " if ($not_found);
$info .= "$double were already in list, " if ($double);
$info .= "using ".scalar(@pics)." pictures.\n";
close $fh;
return (1, $error, $info, \@pics);
}
##############################################################
# light_table_reload - save slideshow to temp file and open it again
# can be used to reload updated thumbnails
##############################################################
sub light_table_reload {
my $datetime = getDateTimeShortString(time());
my $file = "$trashdir/slideshow-$datetime.gqv";
if (light_table_save_to_file_int($file)) {
# todo: $ltw->{file} is set to $file, so the original slideshow file name is lost!!!
light_table_reopen(RESET, $file);
}
}
##############################################################
# light_table_save_to_file_as
##############################################################
sub light_table_save_to_file_as {
my $types = [ ['gqview slideshow', '.gqv',], ['Slideshow file', '.sld',], ['All Files', '*',], ];
my $file = $ltw->getSaveFile(-title => "Save slideshow as, use .gqv (gqview) or .sld (XnView) suffix", -defaultextension => 'gqv', -initialfile => "slideshow.gqv", -initialdir => $config{SlideShowDir}, -filetypes => $types);
return 0 if ((!defined $file) or ($file eq ''));
$config{SlideShowDir} = dirname($file) if (-d dirname($file));
my ($basename,$dir,$suffix) = fileparse($file, '\.[^.]*'); # suffix = . and not-. (one dot and zero or more non-dots)
my $ok = 0;
if ($suffix eq '.sld') {
$ok = set_sld_options();
}
elsif ($suffix eq '.gqv') {
$ok = set_gqv_options();
}
else {
$ltw->messageBox(-icon => 'error', -message => "Sorry, but the slideshow suffix $suffix is not supported.",
-title => "Wrong file suffix", -type => 'OK');
}
return 0 if (not $ok);
light_table_save_to_file($file);
return 1;
}
##############################################################
# set some options for XnView slideshow (suffix: .sld)
##############################################################
sub set_sld_options {
my $ok = 0;
# open window
my $win = $ltw->Toplevel();
$win->title('Save slideshow options');
$win->iconimage($mapiviicon) if $mapiviicon;
$win->Checkbutton(-variable => \$config{relative_path}, -text => "Use relative file paths")->pack(-anchor=>'w');
$win->Checkbutton(-variable => \$config{xnview_loop}, -text => "Loop slide show")->pack(-anchor=>'w');
$win->Checkbutton(-variable => \$config{xnview_fullscreen}, -text => "Full screen display")->pack(-anchor=>'w');
$win->Checkbutton(-variable => \$config{xnview_title}, -text => "Show title bar")->pack(-anchor=>'w');
$win->Checkbutton(-variable => \$config{xnview_filename}, -text => "Show file name")->pack(-anchor=>'w');
$win->Checkbutton(-variable => \$config{xnview_mouse}, -text => "Hide mouse")->pack(-anchor=>'w');
$win->Checkbutton(-variable => \$config{xnview_random}, -text => "Random order")->pack(-anchor=>'w');
my $but_frame = $win->Frame()->pack(-fill =>'x');
my $ok_but = $but_frame->Button(-text => lang('OK'),
-command => sub {
$ok = 1;
$win->withdraw();
$win->destroy();
})->pack(-side => 'left', -expand => 1, -fill => 'x', -padx => 2, -pady => 3);
my $xBut = $but_frame->Button(-text => lang('Cancel'),
-command => sub {
$ok = 0;
$win->withdraw();
$win->destroy();
})->pack(-side => 'left', -expand => 1, -fill => 'x', -padx => 2, -pady => 3);
bind_exit_keys_to_button($win, $xBut);
$win->Popup(-popover => 'cursor');
repositionWindow($win);
$win->waitWindow;
return $ok;
}
##############################################################
# set some options for gqview slideshow (suffix: .gqv)
##############################################################
sub set_gqv_options {
$config{relative_path} = 0; # gqview only supports absolut paths
return 1;
}
##############################################################
# light_table_save - save slideshow to slideshows hash
##############################################################
sub light_table_save {
# save slideshow to %slideshows hash
#use Data::Dumper; # and then in the code e.g. print Dumper(\%conf);
#print "--------- before ----------\n";
#print Dumper(%slideshows);
# we need a local copy
my @pics = @{$ltw->{canvas}->{thumb_list}};
$slideshows{$ltw->{folder}}{$ltw->{collection}}{pics} = \@pics;
#print "--------- after ----------\n";
#print Dumper(%slideshows);
# and save slideshow hash to file
save_slideshows();
log_it("wrote collection: $ltw->{folder}: $ltw->{collection}");
$ltw->{label} = lang("wrote collection: ").$ltw->{folder}.' '.$ltw->{collection};
$ltw->title(lang('Collection').': '.$ltw->{folder}.' '.$ltw->{collection});
$ltw->{unsafed_changes} = 0; # reset dirty bit
}
##############################################################
# light_table_save_as - get folder and collection name
##############################################################
sub light_table_save_as {
# todo:improve folder/collection selection by providing one dialog and
# displaying all available collections
# check if user selected folder and or collection in tree of main window
my ($ok, $folder, $collection) = get_selected_collection($nav_F->{collection_frame}->{tree}, 0);
if ($ok == 0) { # no selection
$folder = 'folder';
$collection = 'collection';
}
if ($ok == 1) { # only folder selection
$collection = 'collection';
} # hint: $ok == 2 means folder and collection are selected
my $rc = myEntryDialog(lang('Save collection'), lang('Please enter folder name'), \$folder);
return if (($rc ne 'OK') or ($folder eq ''));
$rc = myEntryDialog(lang('Save collection'), langf("Please enter collection name in folder %s",$folder), \$collection);
return if (($rc ne 'OK') or ($collection eq ''));
if (exists $slideshows{$folder}{$collection}) {
my $rc = $ltw->messageBox(-icon => 'question', -message => langf("Collection %s %s exists. Overwrite this collection?", $folder, $collection), -title => lang('Overwrite collection?'), -type => 'OKCancel');
return if ($rc !~ m/Ok/i);
}
$ltw->{folder} = $folder;
$ltw->{collection} = $collection;
light_table_save();
}
##############################################################
# light_table_save_to_file
##############################################################
sub light_table_save_to_file {
my $file = shift;
if (light_table_save_to_file_int($file)) {
log_it("wrote collection: $file");
$ltw->{label} = lang("wrote collection: ").basename($file);
$ltw->title(lang('Collection').': '.basename($file));
$ltw->{file} = $file;
print "collection saved to file, but not to hash!\n";
}
else {
log_it("Error writing collection: $file");
$ltw->{label} = "Error writing collection: ".basename($file);
}
}
##############################################################
# light_table_save_to_file_int
##############################################################
sub light_table_save_to_file_int {
my $file = shift;
print "writing slideshow to $file\n" if $verbose;
my $fh;
my ($basename,$dir,$suffix) = fileparse($file, '\.[^.]*'); # suffix = . and not-. (one dot and zero or more non-dots)
my $header;
if ($suffix eq '.sld') {
$header = '# Slide Show Sequence
View = 1
CenterWindow = 0
ReadErrors = 1
BackgroundColor = 0';
}
elsif ($suffix eq '.gqv') {
$header = "#GQView collection\n#Created with Mapivi version $version\n";
}
if (!open($fh, '>', $file)) {
$ltw->messageBox(-icon => 'error', -message => "Error writing slideshow file:\ncould not open $file for write access!: $!",
-title => "Error writing file", -type => 'OK');
print "could not open $file for write access!: $!\n" if $verbose;
return 0;
}
print $fh "$header\n";
if ($suffix eq '.sld') {
print $fh "Loop = $config{xnview_loop}\n";
print $fh "FullScreen = $config{xnview_fullscreen}\n";
print $fh "TitleBar = $config{xnview_title}\n";
print $fh "HideMouse = $config{xnview_mouse}\n";
print $fh "RandomOrder = $config{xnview_random}\n";
print $fh "ShowFilename = $config{xnview_filename}\n";
}
foreach my $dpic (@{$ltw->{canvas}->{thumb_list}}) {
my $rel = $dpic;
if ($config{relative_path}) {
$rel = File::Spec->abs2rel($dpic, dirname($file));
}
print $fh "\"$rel\"\n";
print "\"$rel\"\n" if $verbose;
}
if ($suffix eq '.gqv') {
print $fh "#end\n";
}
close $fh;
$ltw->{unsafed_changes} = 0; # reset dirty bit
return 1;
}
##############################################################
# light_table_close
##############################################################
sub light_table_close {
my $ask = shift;
if ($ltw->{unsafed_changes}) {
my $rc = $ltw->messageBox(-icon => 'question',
-message => lang("Collection will not be saved automatically.\nAll changes will be lost.\nReally close collection?"),
-title => lang("Close collection?"), -type => 'YesNo');
return 0 unless ($rc =~ m/Yes/i);
}
undef @{$ltw->{canvas}->{thumb_list}};
light_table_clear();
$config{LtwGeometry} = $ltw->geometry;
$ltw->destroy();
return 1;
}
##############################################################
# light_table_clear
##############################################################
sub light_table_clear {
$ltw->{canvas}->delete('all');
# delete all photo objects (thumbnnails)
foreach my $dpic (keys %{$ltw->{canvas}->{thumbs}}) {
# delete defined photo object
delete_photo_object($ltw->{canvas}->{thumbs}->{$dpic});
# delete hash entry
delete $ltw->{canvas}->{thumbs}->{$dpic};
}
$ltw->{label} = scalar @{$ltw->{canvas}->{thumb_list}}.' '.lang('pictures');
$ltw->title(lang('Picture collection'));
$ltw->{unsafed_changes} = 0; # reset dirty bit
}
##############################################################
# light_table_reset_collection
##############################################################
sub light_table_reset_collection {
$ltw->{folder} = '';
$ltw->{collection} = '';
}
##############################################################
# light_table_add_from_lb
##############################################################
sub light_table_add_from_lb {
my $lb = shift;
my @sellist = getSelection($lb);
light_table_add(\@sellist);
}
##############################################################
# light_table_add
##############################################################
sub light_table_add {
my $list_ref = shift;
return unless checkSelection($top, 1, 0, $list_ref, lang("picture(s)"));
# open light table window if needed
light_table_open_window() unless (Exists($ltw));
my $error = '';
my $error_count = 0;
my @list;
# check for double pictures (not yet supported)
foreach my $dpic (@$list_ref) {
if (isInList($dpic, $ltw->{canvas}->{thumb_list})) {
$error .= "$dpic\n";
$error_count++;
}
else {
push @list, $dpic;
log_it(lang("added to collection: ").$dpic);
$ltw->{unsafed_changes} = 1; # set dirty bit
}
}
if ($error ne '') {
$error = "These $error_count pictures are already in the slideshow and have been skipped:\n\n".$error;
showText('Ignored pictures', $error, NO_WAIT);
}
return unless (@list);
# add selected pictures at end of slideshow list
push @{$ltw->{canvas}->{thumb_list}}, @list;
# add selected pictures to light table
light_table_add_list(\@list);
}
##############################################################
# light_table_edit
##############################################################
sub light_table_edit {
my $list_ref = shift;
my $folder = shift; # optional slideshow folder (not file folder)
my $collection = shift; # optional slideshow name (not file name)
if (Exists($ltw)) {
my $rc = $top->messageBox(-icon => 'question', -message => langf("Close current collection and open %s %s?",$folder, $collection), -title => lang('Close collection?'), -type => 'OKCancel');
return if ($rc !~ m/Ok/i);
}
# open light table window if needed
light_table_open_window() unless (Exists($ltw));
undef @{$ltw->{canvas}->{thumb_list}};
light_table_clear();
# store folder and collection name
$ltw->{folder} = $folder if (defined $folder);
$ltw->{collection} = $collection if (defined $collection);
$ltw->{unsafed_changes} = 0; # clear dirty bit
$ltw->{file} = $slideshows{$folder}{$collection}{file} if (defined $slideshows{$folder}{$collection}{file});
# copy collection pics to slideshow list
@{$ltw->{canvas}->{thumb_list}} = @$list_ref;
# add selected pictures to light table
light_table_add_list($list_ref);
}
##############################################################
# light_table_add_list
##############################################################
sub light_table_add_list {
my $list_ref = shift; # list of JPEG pics with full path
return if (@$list_ref < 1); # no pics to add
# get thumb size info from first thumbnail in list (this may be wrong, as others may be bigger)
my ($tw, $th) = getSize(getThumbFileName($$list_ref[0]));
if ($tw > 1) {
$ltw->{canvas}->{thumb_size} = $tw;
}
my $i = 0;
my $pw = 0;
$pw = progressWinInit($ltw, "Add pictures to collection")if (@$list_ref > 1);;
foreach my $dpic (@$list_ref) {
my $thumb = getThumbFileName($dpic);
last if progressWinCheck($pw);
$i++;
progressWinUpdate($pw, "adding picture ($i/".scalar @$list_ref.") ...", $i, scalar @$list_ref) if $pw;
if (-f $thumb) {
# save all thumb photo objects in canvas hash to delete them later
$ltw->{canvas}->{thumbs}->{$dpic} = $ltw->Photo(-file => $thumb); }
else {
# reminder: when we delete this photo object later, we should not delete the empty thumb object!
$ltw->{canvas}->{thumbs}->{$dpic} = $mapivi_icons{'EmptyThumb'};
}
if ($ltw->{canvas}->{thumbs}->{$dpic}) {
# create image on canvas
# all mapivi thumb tags contain _MH!!!
# this is needed to extract the dpic from the id in get_path_from_id()
my $id = $ltw->{canvas}->createImage(0, 0,
-image => $ltw->{canvas}->{thumbs}->{$dpic},
-tag => ['THUMB_MH', 'THUMB_MH'.$dpic],
-anchor => 'nw');
# add bindings
$ltw->{canvas}->bind($id,'',
sub { light_table_select($id); });
$ltw->{canvas}->bind($id,'',
sub {$ltw->{LOCK_MH} = 1; light_table_select_range();});
$ltw->{canvas}->bind($id,'',
sub {$ltw->{LOCK_MH} = 1; light_table_select_add($id); });
$ltw->{canvas}->bind($id,'',
sub { light_table_move($id); });
$ltw->{canvas}->bind($id,'',
sub { return if ($ltw->{LOCK_MH}); light_table_drop($id); });
$ltw->{canvas}->bind($id,'',
sub { $ltw->{LOCK_MH} = 0; });
$ltw->{canvas}->bind($id,'',
sub { $ltw->{LOCK_MH} = 0; });
$ltw->{canvas}->bind($id,'',
sub { my @sel = selection_get_sort($ltw->{canvas}, $ltw->{canvas}->{thumb_list}); show_multiple_pics(\@sel, 0); });
}
}
progressWinEnd($pw) if $pw;
light_table_reorder($ltw->{canvas}, $ltw->{canvas}->{thumb_list});
light_table_update_selection();
$ltw->{canvas}->yviewMoveto(1);
$ltw->{label} = scalar @{$ltw->{canvas}->{thumb_list}}.' pictures';
}
##############################################################
# show_canvas_thumbs
# shows a list of thumbnails in the canvas (tag: THUMB_MH)
# stores photo objects in $c->{thumbs}
##############################################################
sub show_canvas_thumbs {
return if (not $conf{show_canvas_thumbs}{value});
my $c = shift; # canvas widget
my $list_ref = shift; # list of JPEG pics with full path
return if (@$list_ref < 1); # no pics to add
# remove all thumbnails from canvas
clear_canvas_thumbs($c);
# hide all picture items on the canvas
canvasHide();
# clear image info
showImageInfo();
# clear canvas info
#showImageInfoCanvas();
# get thumb size info from first thumbnail in list (todo: this may be wrong, as others may be bigger)
my ($tw, $th) = getSize(getThumbFileName($$list_ref[0]));
if ($tw > 1) {
$c->{thumb_size} = $tw;
}
my $i = 0;
my $pw = progressWinInit($c, "Add pictures to canvas");
foreach my $dpic (@$list_ref) {
my $thumb = getThumbFileName($dpic);
last if progressWinCheck($pw);
$i++;
progressWinUpdate($pw, "adding picture ($i/".scalar @$list_ref.") ...", $i, scalar @$list_ref);
if (-f $thumb) {
# save all thumb photo objects in canvas hash to delete them later
$c->{thumbs}->{$dpic} = $c->Photo(-file => $thumb);
}
else {
$c->{thumbs}->{$dpic} = $mapivi_icons{'EmptyThumb'};
}
add_canvas_thumb($c, $dpic, 0, 0);
}
light_table_reorder($c, $list_ref);
add_canvas_ratings($c); # has to be called after light_table_reorder()!
canvas_update_selection($c);
progressWinEnd($pw);
$c->yviewMoveto(0);
}
##############################################################
# Hint: has to be called after light_table_reorder()!
##############################################################
sub add_canvas_ratings {
my $c = shift; # canvas
my @ids = $c->find('withtag', 'THUMB_MH');
foreach my $id (@ids) {
my $dpic = get_path_from_id($c, $id);
my $stars = iptc_rating_stars_nr($searchDB{$dpic}{URG});
if ($stars) {
my $size = 7; my $offset = $size+1;
my ($x, $y, $x1, $y1) = $c->coords($id);
# add rating as circles
for (1 .. $stars) {
$c->createOval( $x+1, $y+1, $x+$size, $y+$size,
-tags => ['STAR', 'STAR'.$dpic],
-outline => 'sienna1',
-fill => 'sienna2',
-width => 2,
);
$x += $offset;
}
}
}
}
##############################################################
# add one thumbnail to the canvas
##############################################################
sub add_canvas_thumb {
my ($c, $dpic, $x, $y) = @_;
if ($c->{thumbs}->{$dpic}) {
my $id = $c->createImage($x, $y,
-image => $c->{thumbs}->{$dpic},
# we add THUMB_MH to the file name to avoid problems with other
# picture items on the canvas, see also checkCachedPics()
-tag => ['THUMB_MH', 'THUMB_MH'.$dpic],
-anchor => 'nw');
# add bindings
$c->bind($id,'',
sub { #clear_canvas_thumbs($c); # is already called within showPic()!
showPic($dpic);});
$c->bind($id,'',
sub { $picLB->selectionClear();
$picLB->selectionSet($dpic);
$picLB->anchorSet($dpic);
$picLB->see($dpic);
canvas_update_selection($c);
showNrOf();
log_it(lang('Double click to display').' '.basename($dpic));});
$c->bind($id,'',
sub { if ($picLB->selectionIncludes($dpic)) {
$picLB->selectionClear($dpic);
} else {
$picLB->selectionSet($dpic);
}
$picLB->anchorSet($dpic);
$picLB->see($dpic);
canvas_update_selection($c);
showNrOf(); });
$c->bind($id,'',
sub { my $anchor = $picLB->info('anchor');
if ((defined $anchor) and ($anchor ne '')) {
$picLB->selectionSet($anchor, $dpic);
$picLB->see($dpic);
canvas_update_selection($c);
showNrOf();
}});
}
else {
warn "add_canvas_thumb: Found no thumbnail for $dpic!";
}
}
##############################################################
# clear_canvas_thumbs
# remove all canvas items with tag 'THUMB_MH' and free
# the canvas local photo objects stored in $c->{thumbs}
##############################################################
sub clear_canvas_thumbs {
return if (not $conf{show_canvas_thumbs}{value});
my $c = shift; # canvas widget
my @ids = $c->find('withtag', 'THUMB_MH');
foreach my $id (@ids) {
$c->delete('withtag', $id);
}
$c->delete('withtag', 'MARK');
$c->delete('withtag', 'STAR');
my @thumb_objects = keys %{$c->{thumbs}};
foreach my $dpic (@thumb_objects) {
# delete photo object
delete_photo_object($c->{thumbs}->{$dpic});
# delete hash entry
delete $c->{thumbs}->{$dpic};
}
if (scalar(@ids) != scalar(@thumb_objects)) {
warn "clear_canvas_thumbs: Warning: ".scalar(@ids)." canvas thumbs and ".scalar(@thumb_objects)." photo objects are not equal";
}
canvas_update_selection($c);
}
##############################################################
# canvas_update_selection - draw a mark on each selected
# thumbnail
##############################################################
sub canvas_update_selection {
my $c = shift; # canvas widget
# first we remove all selection markers
$c->delete('withtag', 'MARK');
# find all selected thumbs from picLB
my @sel = getSelection($picLB);
return if (not @sel);
# draw a mark on all selected pictures
foreach my $dpic (@sel) {
my ($x, $y) = $c->coords('THUMB_MH'.$dpic);
if (defined $x) {
$c->createRectangle( $x, $y, $x+$c->{thumb_size}, $y+$c->{thumb_size},
-tags => ['MARK'],
#-fill => 'yellow2'
-outline => 'yellow2',
-width => 2
);
}
}
}
##############################################################
# light_table_balloon
##############################################################
sub light_table_balloon {
if ($ltw->{show_balloon}) {
my $msg;
# the balloon message is generated on demand later, to speed up the loading of the thumbs
$balloon->attach($ltw->{canvas},
-postcommand => sub {
my ($current) = $ltw->{canvas}->find('withtag', 'current');
my $dpic = get_path_from_id($ltw->{canvas},$current);
$msg = makeBalloonMsg($dpic);
},
-balloonposition => 'mouse',
-msg => \$msg);
}
else {
$balloon->detach($ltw->{canvas});
}
}
##############################################################
# light_table_reorder
##############################################################
sub light_table_reorder {
my $c = shift; # canvas widget
my $pic_list = shift; # list reference, thumbnails will be sorted using this list
return if (not defined $pic_list);
return if (scalar(@$pic_list) <= 1);
$c->update;
#$c->Busy; # resizing the window does not work under windows if Busy is used
my $dis = $c->{thumb_size} + $c->{thumb_distance};
# get canvas size
my $cx = $c->width;
my $cy = $c->height;
# calc visible columns and rows
my $c_cols = int($cx/$dis);
$c_cols = 1 if ($c_cols < 1); # avoid division by zero
my $c_rows = int($cy/$dis);
# how many rows are needed for all pics?
my $all_rows = int(@$pic_list / $c_cols);
$all_rows++ if ((@$pic_list % $c_cols) != 0);
# adjust scrollbar
$c->configure(-scrollregion => [0, 0, $c_cols*$dis + $c->{thumb_distance}, $all_rows*$dis + $c->{thumb_distance}]);
my $index = 0;
foreach my $dpic (@$pic_list) {
my ($id) = $c->find('withtag', 'THUMB_MH'.$dpic);
if (not defined $id) {
warn "light_table_reorder: Found no item for $dpic (index:$index)!";
}
my $row = int ($index / $c_cols);
my $col = $index % $c_cols; # modulo
# we move the thumbs by tag which is the THUMB_MH+path+file name
# this excludes the possibility to have a pic twice in the list :-(
$c->coords('THUMB_MH'.$dpic, $col*$dis+$c->{thumb_distance}, $row*$dis+$c->{thumb_distance});
$index++;
}
}
##############################################################
# get_path_from_id
# assumes that the item has a tag "THUMB_MH/path/to/file"
# and returns /path/to/file or empty string
##############################################################
sub get_path_from_id {
my $c = shift; # canvas
my $id = shift; # id of canvas item
my @tags = $c->gettags($id);
my $dpic = '';
foreach (@tags) {
next if ($_ eq 'current');
next if ($_ =~ m/.*_MH$/); # all mapivi thumb tags are ending with _MH
$dpic = $_; # so this must be the THUMB_MH+path+file name
}
if ($dpic eq '') {
print "get_path_from_id: Error could not find path from item: ";
print "$_ " foreach (@tags);
print "\n";
}
if ($dpic =~ m/^THUMB_MH(.*)/) {
$dpic = $1; # cut off THUMB_MH prefix
}
else {
print "get_path_from_id: Error contains no THUMB_MH prefix: $dpic\n";
$dpic = '';
}
return $dpic;
}
##############################################################
# light_table_copy_rename
##############################################################
sub light_table_copy_rename {
# find all selected thumbs
my @sel = selection_get_sort($ltw->{canvas}, $ltw->{canvas}->{thumb_list});
#my @sel = $ltw->{canvas}->find('withtag', 'THUMBSELECT_MH');
return unless checkSelection($top, 1, 0, \@sel, lang("picture(s)"));
my $rc = $ltw->messageBox(-icon => 'warning', -message => "Copy and rename the ".scalar @sel." selected pictures.\nThe pictures will be renamed by adding a leading number according to the current order.\npic.jpg will for example be renamed to: 000-pic.jpg.\n\nOk to proceed?",
-title => "Copy and rename", -type => "OKCancel");
return if ($rc !~ m/Ok/i);
my $targetdir = getDirDialog("Copy pictures to");
return if ($targetdir eq '');
return unless (-d $targetdir);
makeDir(dirname(getThumbFileName("$targetdir/dummy.jpg")), ASK);
my $i = 0;
my $overwrite = OVERWRITE;
#my $digits = 3;
# idea from Yann Michel
my $digits = int(log(@sel)/log(10))+1; # calculate the needed digits dynamically
my $pw = progressWinInit($ltw, "Copy and rename pictures");
foreach my $dpic (@sel) {
last if progressWinCheck($pw);
my $pic = basename($dpic);
my $tpic = $targetdir.'/'.sprintf "%0*d-$pic", $digits, $i;
my $thumbpic = getThumbFileName($dpic);
my $thumbtpic = getThumbFileName($tpic);
$i++;
progressWinUpdate($pw, "copy and rename picture ($i/".scalar @sel.") ...", $i, scalar @sel);
$overwrite = overwritePic($tpic, $dpic, (scalar(@sel) - $i + 1)) if ($overwrite != OVERWRITEALL);
next if ($overwrite == CANCEL);
last if ($overwrite == CANCELALL);
if (mycopy($dpic, $tpic, OVERWRITE)) {
if ((-d dirname($thumbtpic)) and (-f $thumbpic)) {
mycopy($thumbpic, $thumbtpic, OVERWRITE)
}
$searchDB{$tpic} = $searchDB{$dpic}; # copy meta info in search database
}
} # foreach - end
progressWinEnd($pw);
}
##############################################################
# light_table_drop
##############################################################
sub light_table_drop {
# where the drop happened
my $x = $ltw->{canvas}->canvasx($Tk::event->x());
my $y = $ltw->{canvas}->canvasy($Tk::event->y());
# distance between upper left corner of thumbs
my $dis = $ltw->{canvas}->{thumb_size} + $ltw->{canvas}->{thumb_distance};
$dis = 1 if ($dis == 0); # avoid division by zero
# drop position in cols/rows
my $col = sprintf "%0d", ($x / $dis); # round
my $row = sprintf "%0d", ($y / $dis);
print "drop at x=$x y=$y col=$col row=$row\n" if $verbose;
# get size of canvas in cols/rows
my $cx = $ltw->{canvas}->width;
my $cy = $ltw->{canvas}->height;
my $c_cols = int($cx/$dis);
my $c_rows = int($cy/$dis);
# new position in list
my $to_index = $row * $c_cols + $col;
my $max_index = scalar(@{$ltw->{canvas}->{thumb_list}}) - 1;
if ($to_index > $max_index) {
#print "to_index $to_index is bigger than max_index $max_index - reducing\n";
$to_index = $max_index;
}
#my $to_dpic = ${$ltw->{canvas}->{thumb_list}}[$to_index];
# find all selected thumbs
my @sel = $ltw->{canvas}->find('withtag', 'THUMBSELECT_MH');
my @sel_dpics;
my @old_order = @{$ltw->{canvas}->{thumb_list}};
# remove selected pics from the pic list
foreach my $id (@sel) {
my $dpic = get_path_from_id($ltw->{canvas}, $id);
my $index = index_in_list($dpic, $ltw->{canvas}->{thumb_list});
#print "drop: removing index $index ($dpic)\n";
# remove this pic from the list
push @sel_dpics, splice @{$ltw->{canvas}->{thumb_list}}, $index, 1;
}
# add the removed pics at the right place again
foreach my $dpic (@sel_dpics) {
#print "drop: adding at $to_index $dpic\n";
# add it at the new position
splice @{$ltw->{canvas}->{thumb_list}}, $to_index, 0, $dpic;
}
# set dirty bit only if order of pics really changed (compare lists by joining them to strings)
if ("@old_order" ne "@{$ltw->{canvas}->{thumb_list}}") {
$ltw->{unsafed_changes} = 1;
}
light_table_reorder($ltw->{canvas}, $ltw->{canvas}->{thumb_list});
light_table_update_selection();
}
##############################################################
# index_in_list - returns the index of an element in a list
# return -1 if not found
##############################################################
sub index_in_list {
my $e = shift;
my $listRef = shift;
my $index = 0;
foreach (@$listRef) {
last if ($e eq $_);
$index++;
}
if ($index > @$listRef) {
print "$index is bigger than @$listRef\n" if $verbose;
$index = -1;
}
return $index;
}
##############################################################
# light_table_select - select a thumbnail, remove all other selections
##############################################################
sub light_table_select {
my $id = shift;
# remember the current selection
my @sel_IDs = $ltw->{canvas}->find('withtag', 'THUMBSELECT_MH');
$ltw->{sel_IDs} = \@sel_IDs;
$ltw->{sel_time} = Tk::timeofday();
# delete all selection frames
remove_tag_from_all('THUMBSELECT_MH');
remove_tag_from_all('ANCHOR_MH');
# select just the current thumb
$ltw->{canvas}->addtag('THUMBSELECT_MH', 'withtag', 'current');
# this is the new anchor
$ltw->{canvas}->addtag('ANCHOR_MH', 'withtag', 'current');
# update the selection frames
light_table_update_selection();
}
##############################################################
# remove_tag_from_all - delete a certain tag from all elements
# in the canvas
##############################################################
sub remove_tag_from_all {
my $tag = shift;
#print "remove_tag_from_all: $tag\n";
# build a list of all thumbs with this tag
#my @sel = $ltw->{canvas}->find( qw|withtag $tag| );
my @sel = $ltw->{canvas}->find('withtag', $tag);
# remove the tag from these thumbs
foreach my $id (@sel) {
#print "remove_tag_from_all: removing $tag\n";
$ltw->{canvas}->dtag($id, $tag);
}
}
##############################################################
# light_table_select_add - toggle selection of single thumbnail
##############################################################
sub light_table_select_add {
my @tags = $ltw->{canvas}->gettags('current');
if (isInList('THUMBSELECT_MH', \@tags)) {
# delete existing tag
$ltw->{canvas}->dtag('current', 'THUMBSELECT_MH');
}
else {
# add tag
$ltw->{canvas}->addtag('THUMBSELECT_MH', 'withtag', 'current');
}
light_table_update_selection();
}
##############################################################
# light_table_select_all - select all thumbnail
##############################################################
sub light_table_select_all {
remove_tag_from_all('THUMBSELECT_MH');
my @all = $ltw->{canvas}->find('all');
foreach my $id (@all) {
$ltw->{canvas}->addtag('THUMBSELECT_MH', 'withtag', $id);
}
light_table_update_selection();
}
##############################################################
# light_table_select_range - select range of thumbnail
##############################################################
sub light_table_select_range {
# build a list of all thumbs with tag ANCHOR_MH
my @sel = $ltw->{canvas}->find('withtag', 'ANCHOR_MH');
if (@sel < 1) {
print "no anchor found!\n" if $verbose;
return;
}
if (@sel > 1) {
print "error ".scalar @sel." anchors found! - removing anchors\n" if $verbose;
remove_tag_from_all('ANCHOR_MH');
return;
}
my $start_id = $sel[0];
my $start_dpic = get_path_from_id($ltw->{canvas},$start_id);
my $start_index = index_in_list($start_dpic, $ltw->{canvas}->{thumb_list});
@sel = $ltw->{canvas}->find('withtag', 'current');
my $end_id = $sel[0];
my $end_dpic = get_path_from_id($ltw->{canvas},$end_id);
my $end_index = index_in_list($end_dpic, $ltw->{canvas}->{thumb_list});
print "light_table_select_range: select from $start_dpic ($start_index) to $end_dpic ($end_index)\n" if $verbose;
# do we need to swap?
if ($end_index < $start_index) {
my $tmp = $start_index;
$start_index = $end_index;
$end_index = $tmp;
}
foreach ($start_index .. $end_index) {
$ltw->{canvas}->addtag('THUMBSELECT_MH', 'withtag', 'THUMB_MH'.${$ltw->{canvas}->{thumb_list}}[$_]);
}
light_table_update_selection();
}
##############################################################
# light_table_select_to end - select range of thumbnail from
# selected (must be just one!) to the last
##############################################################
sub light_table_select_to_end {
my @pics_sel = getSelection($ltw->{canvas}); # or $ltw->{canvas} ???
return unless checkSelection($ltw, 1, 1, \@pics_sel, lang("picture(s)"));
my $start_dpic = $pics_sel[0];
my $start = 0;
foreach my $dpic (@{$ltw->{canvas}->{thumb_list}}) {
# skip through list until we see the selected start picture
# then start tagging with select tag to end of list
$start = 1 if ($dpic eq $start_dpic);
if ($start) {
$ltw->{canvas}->addtag('THUMBSELECT_MH', 'withtag', 'THUMB_MH'.$dpic);
}
}
light_table_update_selection();
}
##############################################################
# light_table_update_selection - draw a frame around each selected
# thumbnail (with tag THUMBSELECT_MH)
##############################################################
sub light_table_update_selection {
# first we remove all frames
$ltw->{canvas}->delete('withtag', 'FRAME');
# find all selected thumbs
my @sel = $ltw->{canvas}->find('withtag', 'THUMBSELECT_MH');
return if (not @sel);
# draw a frame around all selected pictures
foreach my $thumb (@sel) {
my ($x, $y) = $ltw->{canvas}->coords($thumb);
$ltw->{canvas}->createRectangle( $x, $y, $x+$ltw->{canvas}->{thumb_size}+1, $y+$ltw->{canvas}->{thumb_size}+1,
-tags => ['FRAME'],
-outline => 'yellow2', #$config{ColorSelBut},
-width => 2,
);
}
# add the filename if just one thumbnail is selected
my $picture = '';
if (@sel == 1) {
my $dpic = get_path_from_id($ltw->{canvas},$sel[0]);
$picture = ' ('.basename($dpic).')';
}
$ltw->{label} = scalar @{$ltw->{canvas}->{thumb_list}}.' pictures, '.scalar @sel.' selected'.$picture;
}
##############################################################
# light_table_delete - remove the selected thumbs from the list
# will - of course - not remove the files!!!
##############################################################
sub light_table_delete {
# find all selected thumbs
my @sel = $ltw->{canvas}->find('withtag', 'THUMBSELECT_MH');
# remove them from the list and the canvas
foreach my $id (@sel) {
my $dpic = get_path_from_id($ltw->{canvas},$id);
my $index = index_in_list($dpic, $ltw->{canvas}->{thumb_list});
# remove this pic from the list
splice @{$ltw->{canvas}->{thumb_list}}, $index, 1;
# delete item from canvas
$ltw->{canvas}->delete($id);
# delete defined photo object
delete_photo_object($ltw->{canvas}->{thumbs}->{$dpic});
# delete hash entry
delete $ltw->{canvas}->{thumbs}->{$dpic};
}
$ltw->{unsafed_changes} = 1; # set dirty bit
light_table_reorder($ltw->{canvas}, $ltw->{canvas}->{thumb_list});
light_table_update_selection();
}
##############################################################
# delete photo object, exception: EmptyThumb object
##############################################################
sub delete_photo_object {
my $object = shift;
if (defined $object) {
# delete photo object
# exception: EmptyThumb photo object, because we still need this
if ($object != $mapivi_icons{'EmptyThumb'}) {
$object->delete;
}
}
}
##############################################################
# light_table_shift - move the selected thumbs to the top or
# bottom of the list
##############################################################
sub light_table_shift {
my $where = shift; # must be 'top' or 'bottom'
return unless (defined $where);
return if (($where ne 'top') and ($where ne 'bottom'));
# find all selected thumbs
my @sel = $ltw->{canvas}->find('withtag', 'THUMBSELECT_MH');
my @shift_pics; # pics to move
# remove them from the list
foreach my $id (@sel) {
my $dpic = get_path_from_id($ltw->{canvas},$id);
my $index = index_in_list($dpic, $ltw->{canvas}->{thumb_list});
# remove this pic from the list and add it to @shift_pics
push @shift_pics, splice @{$ltw->{canvas}->{thumb_list}}, $index, 1;
}
if ($where eq 'top') {
unshift @{$ltw->{canvas}->{thumb_list}}, @shift_pics; # add them at the start of the list
}
elsif ($where eq 'bottom') {
push @{$ltw->{canvas}->{thumb_list}}, @shift_pics; # add them to the end of the list
}
else {
warn "light_table_shift: should not be reached where = $where";
}
$ltw->{unsafed_changes} = 1; # set dirty bit
light_table_reorder($ltw->{canvas}, $ltw->{canvas}->{thumb_list});
light_table_update_selection();
}
##############################################################
# light_table_move - called if a thumbnail is dragged inside the light table
##############################################################
sub light_table_move {
# stop repeat timer
$ltw->{SCROLL_MH}->cancel if $ltw->{SCROLL_MH};
my $id = shift;
# if the last selection happened just 400ms ago and the clicked
# thumb was inside the last selection, we reselect the last selection
if (((Tk::timeofday() - $ltw->{sel_time}) < 0.4) and isInList($id, $ltw->{sel_IDs})) {
# reset time
$ltw->{sel_time} = 0;
# first remove the tags
remove_tag_from_all('THUMBSELECT_MH');
# then add the selection from the saved list
foreach my $id (@{$ltw->{sel_IDs}}) {
my $dpic = get_path_from_id($ltw->{canvas},$id);
$ltw->{canvas}->addtag('THUMBSELECT_MH', 'withtag', 'THUMB_MH'.$dpic);
}
light_table_update_selection();
}
$ltw->{canvas}->raise($id);
# get mouse coordinates
my $ex = $Tk::event->x();
my $ey = $Tk::event->y();
my $x = $ltw->{canvas}->canvasx($ex);
my $y = $ltw->{canvas}->canvasy($ey);
my $offset = int($ltw->{canvas}->{thumb_size}/2);
# move thumb to mouse position
$ltw->{canvas}->coords($id, $x-$offset, $y-$offset);
# autoscroll: scroll up or down if needed
# get actual scroll state
my ($y1,$y2) = $ltw->{canvas}->yview;
my $cy = $Tk::event->y;
print "light_table_move cy:$cy\n" if $verbose;
# everything is visible no scrolling needed
return if ($y1 == 0 and $y2 == 1);
my $c_h = $ltw->{canvas}->height; # the visible height
#my @sr = $ltw->{canvas}->cget(-scrollregion);
#my @sr = $ltw->{frame}->cget(-scrollregion);
#my $c_h_all = $sr[3] - $sr[1]; # the height of the scrollregion
# scroll up if mouse is less then a half thumbnailsize away from the upper border
# and there is still room to scroll ($y1 > 0) and no button release has happened
if (($cy < $offset) and ($y1 > 0)) {
$ltw->{SCROLL_MH} = $ltw->repeat(100, sub {
print "scroll up\n" if $verbose;
$ltw->{canvas}->yview('scroll',-1,'units');
# move thumb to mouse position
my $x = $ltw->{canvas}->canvasx($ex);
my $y = $ltw->{canvas}->canvasy($ey);
$ltw->{canvas}->coords($id, $x-$offset, $y-$offset);
$ltw->idletasks; });
}
# scroll down if mouse is less then a half thumbnailsize away from the lower border
# and there is still room to scroll ($y2 < 1) and no button release has happened
if (($cy > $c_h - $offset) and ($y2 < 1)) {
$ltw->{SCROLL_MH} = $ltw->repeat(100, sub {
print "scroll down\n" if $verbose;
$ltw->{canvas}->yview('scroll',1,'units');
# move thumb to mouse position
my $x = $ltw->{canvas}->canvasx($ex);
my $y = $ltw->{canvas}->canvasy($ey);
$ltw->{canvas}->coords($id, $x-$offset, $y-$offset);
$ltw->idletasks; });
}
}
##############################################################
# nop - a do nothing function, needed from Tk::IO
##############################################################
sub nop { return; }
##############################################################
# getThumbCaption - return the appropriate caption for the
# thumbnail of a picture, possibly empty
##############################################################
sub getThumbCaption {
my $dpic = shift;
if (($config{ThumbCapt} eq '') or ($config{ThumbCapt} eq 'none')) {
return '';
}
elsif ($config{ThumbCapt} eq 'filename') {
my $capt = basename($dpic);
$capt =~ s/(.*)\.jp(g|eg)$/$1/i; # remove suffix
return $capt;
}
elsif ($config{ThumbCapt} eq 'filenameSuffix') {
my $capt = basename($dpic);
return $capt;
}
elsif ($config{ThumbCapt} eq 'objectname') {
return getIPTCObjectName($dpic);
}
else {
warn 'getThumbCaption: ThumbCapt has unexpected value: "'.$config{ThumbCapt}.'"';
return '';
}
}
##############################################################
# updateOneThumb - this function is called when a convert
# process is finished; replaces the default
# thumbnail with the actual thumbnail
##############################################################
sub updateOneThumb {
my $thumb = shift;
my $dpic = shift; # the index (entrypath) of the hlist element
my $show = shift; # SHOW, NO_SHOW
proccount(-1);
$nrToConvert--; $nrToConvert = 0 if ($nrToConvert < 0);
# check if we are still in the same dir
if (dirname($thumb) ne dirname(getThumbFileName("$actdir/dummy.jpg"))) {
return; # no, we are not so do not display the generated thumbs
}
if (($show == SHOW) and (-f $thumb)) {
$thumbs{$thumb} = $picLB->Photo(-file => $thumb, -gamma => $config{Gamma});
# if there is already an image ...
if ($picLB->itemCget($dpic, $picLB->{thumbcol}, -itemtype) eq "imagetext") {
# ... configure it
$picLB->itemConfigure($dpic, $picLB->{thumbcol}, -image => $thumbs{$thumb}, -itemtype => "imagetext");
}
else {
$picLB->itemCreate($dpic, $picLB->{thumbcol}, -style => $thumbS, -itemtype => 'imagetext', -image => $thumbs{$thumb}, -text => getThumbCaption($dpic));
}
# update thumbnails shown in picture frame / canvas (if enabled)
if ($conf{show_canvas_thumbs}{value}) {
my @ids = $c->find('withtag', 'THUMB_MH'.$dpic);
if (@ids) {
# store coordinates
my ($x,$y,undef,undef) = $c->coords($ids[0]);
# delete outdated thumbnail
$c->delete('withtag', $ids[0]);
# create and add new thumb
$c->{thumbs}->{$dpic} = $c->Photo(-file => $thumb);
add_canvas_thumb($c, $dpic, $x, $y);
}
}
}
}
##############################################################
# proccount - count the spawned processes
# returns the number of running processes if no
# parameter is given
##############################################################
sub proccount {
my $diff = shift; # optional parameter
return $proccount unless (defined $diff);
$proccount = 0 unless (defined $proccount); # todo why?
$proccount += $diff;
$proccount = 0 if ($proccount < 0); # should never happen!
$top->update;
print "proccount = $proccount\n" if $verbose;
}
##############################################################
# smart_update - reread actual directory, add new and remove
# deleted pics, without reloading the existing
# thumbnails; the goal is to have a faster
# update for large folders
##############################################################
sub smart_update {
log_it(lang("Smart update"));
$top->update;
my @act_pics;
my $rc = get_pics_by_modus(\@act_pics);
return $rc if ($rc != 1);
# get the new list of pics in the actual folder
#my @act_pics = getPics($actdir, WITH_PATH);
sortPics($config{SortBy}, $config{SortReverse}, \@act_pics);
# get the displayed pics from the listbox
my @disp_pics = $picLB->info('children');
my $removed_pics = 0;
my $new_pics = 0;
# remove deleted pictures first
foreach my $dpic (@disp_pics) {
if ((!isInList($dpic, \@act_pics)) and ($picLB->info('exists', $dpic))) {
print "deleting $dpic from picLB\n" if $verbose;
$removed_pics++;
$picLB->delete('entry', $dpic);
}
}
# get the displayed pics from the listbox again after the deletion
@disp_pics = $picLB->info('children');
# count new pictures first
foreach my $dpic (@act_pics) {
$new_pics++ if (!$picLB->info('exists', $dpic));
}
if ($new_pics > 0) {
# todo this init is not the perfect solution as a rename of the
# first pic will be shown as second pic
my $after = $disp_pics[0];
my $pw = progressWinInit($picLB, lang("Smart update"));
my $n = 0;
# add the new pics to the listbox
foreach my $dpic (@act_pics) {
last if progressWinCheck($pw);
if (!$picLB->info('exists', $dpic)) {
$n++;
progressWinUpdate($pw, "adding new picture ($n/$new_pics) ...", $n, $new_pics);
print "adding $dpic to picLB\n" if $verbose;
addOneRow($picLB, $dpic, 1, $after);
}
$after = $dpic;
}
progressWinEnd($pw);
}
showNrOf();
log_it("ready! removed $removed_pics and added $new_pics picture(s)");
generateThumbs(ASK, SHOW);
}
##############################################################
# updateThumbsPlus - update and show the actual pic again
##############################################################
sub updateThumbsPlus {
updateThumbs();
showPic($actpic);
}
##############################################################
# updateThumbs - reads the pictures of the actual dir, shows the
# thumbnails, the given picture and generates
# the thumbnails
##############################################################
sub updateThumbs {
log_it(lang('Loading thumbnails ...'));
$top->update;
checkCachedPics();
canvasHide();
# delete all photo objects (thumbnnails)
foreach (keys %thumbs) {
print "updateThumbs: deleting thumbnail object of $_\n" if $verbose;
# delete defined photo object
delete_photo_object($thumbs{$_}); # delete photo object
delete $thumbs{$_}; # delete hash entry
}
if ($verbose) {
my @check = $top->imageNames;
print " there are ".scalar @check." pics left\n";
}
if (showThumbs()) {
log_it(lang('Loading thumbnails ...').' '.lang('Ready!'));
generateThumbs(ASK, SHOW);
}
else {
log_it(lang("user abord (not all pictures are loaded!)"));
}
showNrOf();
check_new_keywords();
}
##############################################################
# showThumbs - display all thumbnail pictures of the actual
# directory in the listbox
##############################################################
sub showThumbs {
# clean the thumbnail table
# with this step all references to the already deleted photo objects are cleared
# -> the memory is available
$picLB->delete('all');
if ($verbose) {
my @check = $top->imageNames;
print " there are ".scalar @check." pics left\n";
}
my @pics;
my $rc = get_pics_by_modus(\@pics);
return $rc if ($rc != 1);
# if we have many pictures we ask first if the user wants to see them all
my $cut_after = 0;
if (@pics > $config{ThumbMaxLimit}) {
my $cancel = lang('Cancel');
my $all = lang('All');
my $some = langf("Only %d", $config{ThumbMaxLimit});
my $rc = $top->Dialog(-text => langf("Show %d pictures?", scalar(@pics)),
-title => lang("Show all pictures?"),
-width => 40,
-buttons => [$all, $some, $cancel])->Show();
return 0 if ($rc eq $cancel);
$cut_after = 1 if ($rc eq $some);
}
sortPics($config{SortBy}, $config{SortReverse}, \@pics);
if ($cut_after) {
cut_list(\@pics, $config{ThumbMaxLimit});
}
# remove .thumbs subdir etc.
cleanOneDir($actdir) if (($act_modus == FOLDER) and (@pics == 0));
$rc = showThumbsInList($picLB, \@pics);
show_canvas_thumbs($c, \@pics);
set_act_nav_label();
return $rc;
}
##############################################################
##############################################################
sub set_act_nav_label {
$actdirF->{folder_check_buttons}->packForget if ($actdirF->{folder_check_buttons}->ismapped);
if ($act_modus == FOLDER) {
$act_nav_label = lang("Folder").": $actdir";
$actdirF->{folder_check_buttons}->pack(-in => $actdirF, -side => 'left', -expand => 0, -fill => 'x', -padx => 2, -pady => 1) unless ($actdirF->{folder_check_buttons}->ismapped);
}
elsif ($act_modus == LOCATION) {
$act_nav_label = lang("Location").": ";
$act_nav_label .= "$_ " foreach (@act_location);
}
elsif ($act_modus == DATE) {
$act_nav_label = lang("Date").": ";
$act_nav_label .= "$_ " foreach (@act_date);
}
elsif ($act_modus == KEYWORDCLOUD) {
$act_nav_label = lang("Keywordcloud").": ";
$act_nav_label .= "$_ " foreach (@act_keywords);
}
elsif ($act_modus == KEYWORD) {
$act_nav_label = lang("Keyword").": ";
$act_nav_label .= "$_ " foreach (@act_keywords);
}
elsif ($act_modus == SEARCH) {
$act_nav_label = lang("Search").": $config{SearchPattern}";
}
elsif ($act_modus == COLLECTION) {
$act_nav_label = lang("Collection").": ";
$act_nav_label .= "$_ " foreach (@act_collection);
}
else {
$act_nav_label = lang("Unknown navigation modus!");
}
$act_nav_label =~ s/\s+$//; # remove trailing whitespace
if (($act_modus != FOLDER) and $conf{nav_rating_on}{value}) {
$act_nav_label .= ", ".lang("Rating").": ".iptc_rating_stars_urg($conf{search_rating_max}{value})." - ".iptc_rating_stars_urg($conf{search_rating_min}{value});
}
}
my @navigation_history;
##############################################################
##############################################################
sub navigation_history_save {
my $hash = {};
$hash->{modus} = $act_modus;
$hash->{folder} = $actdir;
$hash->{location} = join(" ", @act_location);
$hash->{date} = join(" ", @act_date);
$hash->{keywords} = join(" ", @act_keywords);
$hash->{exkeywords} = join(" ", @act_keywords_ex);
$hash->{search} = $config{SearchPattern};
push @navigation_history, $hash;
print "navigation_history_save: ".scalar @navigation_history." history entries\n";
foreach my $href (@navigation_history) {
print "modus: $href->{modus} folder: $href->{folder} keys: $href->{keywords} date: $href->{date} loc: $href->{location} search: $href->{search}\n";
}
}
##############################################################
##############################################################
sub get_pics_by_modus {
my $pics = shift; # list reference
#navigation_history_save();
if ($act_modus == FOLDER) {
@$pics = getPics($actdir, WITH_PATH, $config{CheckForNonJPEGs});
}
elsif ($act_modus == LOCATION) {
@$pics = get_pics_by(LOCATION, \@act_location);
}
elsif ($act_modus == DATE) {
@$pics = get_pics_by(DATE, \@act_date);
}
elsif ($act_modus == KEYWORDCLOUD) {
@$pics = get_pics_with_keywords(\@act_keywords, \@act_keywords_ex);
}
elsif ($act_modus == KEYWORD) {
@$pics = get_pics_with_keywords(\@act_keywords, \@act_keywords_ex);
}
elsif ($act_modus == SEARCH) {
@$pics = get_pics_by_searching($config{SearchPattern}, '');
}
elsif ($act_modus == COLLECTION) {
# print "act collection: $_\n" foreach (@act_collection);
# index 0 = folder, 1 = collection
@$pics = @{$slideshows{$act_collection[0]}{$act_collection[1]}{pics}};
}
else {
warn "showThumbs called with unknown modus: $act_modus";
return 0;
}
$actdirF->{Filter}->{excluded_pics} = 0; # reset filter display
if ($conf{filter_pics}{value}) {
$actdirF->{Filter}->{excluded_pics} = filter_pics($pics, $conf{filter_pics_keywords}{value});
}
return 1;
}
##############################################################
# showThumbsInList
##############################################################
sub showThumbsInList {
my $lb = shift; # the listbox widget
my $listR = shift; # the list of pics to show
# show some infos to the user while loading
my $n = 0; # actual number
my $nr = @$listR; # total number
my $pw = progressWinInit($lb, lang('Load pictures'));
foreach my $dpic (@$listR) {
last if progressWinCheck($pw);
$n++;
# debug helper: print "xxx loading picture ($n/$nr)\n";
progressWinUpdate($pw, lang('loading picture')." ($n/$nr) ...", $n, $nr);
addOneRow($lb, $dpic, 1);
}
progressWinEnd($pw);
if (($lb == $picLB) and ($n != $nr)) {
log_it("user abord at $n of $nr");
#$lb->after(1000); # just a little delay to show the message above
return 0;
}
return 1;
}
##############################################################
# Source: http://newsgroups.derkeiler.com/Archive/Comp/comp.lang.perl.tk/2006-02/msg00050.html
##############################################################
sub get_encode_file {
my $filename = shift;
# todo: should not die here!!!!!!
open my $filehandle, '<', $filename or die "Can't open $filename. $!\n";
local $/;
return encode_base64(<$filehandle>);
}
##############################################################
# addOneRow - adds a new row, or updates an existing row
##############################################################
sub addOneRow {
my $lb = shift;
my $dpic = shift;
my $with_thumb = shift; # bool 1 = thumb, 0 = defaultthumb
my $after;
$after = shift; # optional
unless ($lb->info('exists', $dpic)) {
# create new row, we use the path and file name (=$dpic) as unique index for the hlist entry
if (($after) and ($lb->info('exists', $after))) {
$lb->add($dpic, -after => $after);
}
else {
$lb->add($dpic);
}
}
my $thumb = getThumbFileName($dpic);
my $thumbP = undef;
if (-f $thumb) {
# Source: http://newsgroups.derkeiler.com/Archive/Comp/comp.lang.perl.tk/2006-02/msg00050.html
# Some of the Tk modules (like Photo) do their own file IO and just
# cannot deal with non-ASCII characters in file names (on Windows,
# at least, I don't have as much experience with Linux, OSX, et al.)
# I have been bitten by this before and haven't really found a good
# solution. A kind of clunky work-around I have employed in the past
# is to use the standard perl IO functions to load the file into
# memory, base64 encode it and then feed it to the module as data.
# Extra work, but it side steps the problem without resorting to
# measures which may be beyond your control. (Like requiring all
# file names to use only ASCII characters.)
if ($EvilOS) {
$thumbP = $lb->Photo(-format => 'jpeg', -data => get_encode_file($thumb), -gamma => $config{Gamma});
}
else {
$thumbP = $lb->Photo(-format => 'jpeg', -file => $thumb, -gamma => $config{Gamma});
}
$thumbs{$dpic} = $thumbP; # save all thumb photo objects in global hash %thumbs to delete them when changing the dir
}
# test feature to improve speed: read meta info only if there is no info in the DB or the modification date has changed
# on windows this is 10 times faster to read in a folder with 200 pics (34 secs vs. 3 secs)
# todo there should be a possibility to force a reread, if somebody added metainfo without changing the modification date - however this is still possible using add to database
if ($searchDB{$dpic} and $searchDB{$dpic}{MOD}) {
if ($searchDB{$dpic}{MOD} != getFileDate($dpic, NO_FORMAT)) {
addToSearchDB($dpic); # save the infos into the search data base
}
}
else { # branch for pics not yet stored in the database or with missing modification dates
addToSearchDB($dpic); # save the infos into the search data base
}
my $pic = basename($dpic);
my $dir = dirname($dpic);
my $com = $searchDB{$dpic}{COM};
my $exif = date_iso_to_relative($searchDB{$dpic}{EXIF});
my $iptc = displayIPTC($dpic);
$com = formatString($com, $config{LineLength}, , $config{LineLimit}); # format the comment for the list
$iptc = formatString($iptc, $config{LineLength},, $config{LineLimit}); # format the IPTC info for the list
my $rating_size = get_rating_and_size($dpic, $lb);
my $image;
if ((defined $thumbP) and $with_thumb) {
$image = $thumbP;
} else {
$image = $mapivi_icons{'EmptyThumb'};
}
if (defined $image) {
$lb->itemCreate($dpic, $lb->{thumbcol}, -style => $thumbS, -itemtype => 'imagetext', -image => $image, -text => getThumbCaption($dpic));
}
# insert items in the table row
$lb->itemCreate($dpic, $lb->{filecol}, -itemtype => "image", -image => $rating_size, -style => $fileS);
$lb->itemCreate($dpic, $lb->{iptccol}, -text => $iptc, -style => $iptcS);
$lb->itemCreate($dpic, $lb->{comcol}, -text => $com, -style => $comS);
$lb->itemCreate($dpic, $lb->{exifcol}, -text => $exif, -style => $exifS);
$lb->itemCreate($dpic, $lb->{dircol}, -text => $dir, -style => $dirS);
}
##############################################################
##############################################################
sub get_rating_and_size {
my $dpic = shift;
my $lb = shift;
my $star_icon = iptc_rating_star_icons($dpic);
my $file_info = getAllFileInfo($dpic);
# use Tk::Compound to display a picture above a text, both aligned to the left side
my $compound = $lb->Compound;
# next line display the rating stars as small icons
$compound->Line(-anchor => 'w');
$compound->Image(-image => $mapivi_icons{$star_icon});
# next line: text
$compound->Line(-anchor => 'w');
$compound->Text(-text => $file_info, -justify => 'left');
# flags (optional)
if (defined $searchDB{$dpic}{FLAG}) {
my $flag = $searchDB{$dpic}{FLAG};
if ($flag != 0) {
$compound->Line(-anchor => 'w');
$compound->Image(-image => $mapivi_icons{'FlagRed'}) if ($flag & FLAG_RED);
$compound->Image(-image => $mapivi_icons{'FlagGreen'}) if ($flag & FLAG_GREEN);
$compound->Image(-image => $mapivi_icons{'FlagBlue'}) if ($flag & FLAG_BLUE);
}
}
return $compound;
}
##############################################################
# displayIPTC - convert the searchdb info into a formated string
##############################################################
sub displayIPTC {
my $dpic = shift;
my $iptc = '';
$iptc = displayUrgency($searchDB{$dpic}{URG});
$iptc .= "Keywords: ".$searchDB{$dpic}{KEYS}."\n" if (defined $searchDB{$dpic}{KEYS});
$iptc .= $searchDB{$dpic}{IPTC} if (defined $searchDB{$dpic}{IPTC});
return $iptc;
}
##############################################################
# displayUrgency - create string with rating/urgency number
##############################################################
sub displayUrgency {
my $urg = shift;
return '' unless (defined $urg);
return "Rating: $urg\n";
}
##############################################################
# iptc_rating_stars_urg - convert the IPTC urgency number into a
# rating string with zero to five stars (*) and the urgency in parenthesis
##############################################################
sub iptc_rating_stars_urg {
my $urgency = shift;
my $stars = iptc_rating_stars($urgency);
$urgency = '-' if ($urgency eq '');
return "$stars ($urgency)";
}
##############################################################
# iptc_rating_stars - convert the IPTC urgency number into a
# rating string with zero to five stars (*)
##############################################################
sub iptc_rating_stars {
my $urgency = shift;
return '' unless (defined $urgency);
return '' if ($urgency <= 0);
my $stars = '';
for (my $x = 5; $x >= $urgency; $x -= 1) {
$stars .= '*';
}
return $stars;
}
##############################################################
# iptc_rating_stars_nr - convert the IPTC urgency number into
# the number of rating stars
##############################################################
sub iptc_rating_stars_nr {
my $urgency = shift;
return 0 unless (defined $urgency);
return 0 if ($urgency <= 0);
return 0 if ($urgency > 5);
# todo: should we also handle 6,7,8 -> 2/3, 1/2, 1/3?
return (6 - $urgency);
}
##############################################################
# iptc_rating_stars_icons - convert the rating into a icon file name
##############################################################
sub iptc_rating_star_icons {
my $dpic = shift;
return 'Rating0' unless (defined $dpic);
my $urg = $searchDB{$dpic}{URG};
return 'Rating0' unless (defined $urg);
return 'Rating0' if (($urg <= 0) or ($urg > 8));
return "Rating$urg";
}
##############################################################
##############################################################
sub rating_button {
my ($widget, $callback, $info, $side, $fill, $rating) = @_;
my $frame = $widget->Frame(-relief => 'sunken')->pack(-side => $side, -fill => $fill);
$balloon->attach($frame, -msg => $info);
my $label;
# mapping of IPTC urgency to 5 star rating string
my %urg2star = (
1 => '5 stars',
2 => '4 stars',
3 => '3 stars',
4 => '2 stars',
5 => '1 star',
6 => '2/3 star',
7 => '1/2 star',
8 => '1/3 star',
0 => '0 stars',
);
my @menuorder = (1,2,3,4,5,6,7,8,0);
my $menu = $widget->Menu(-title => 'Rating');
foreach my $urg (@menuorder) {
$menu->command(-image => compound_menu($widget, $urg2star{$urg}, "rating-$urg.png"),
-command => sub {$$rating = $urg; $label->configure(-image => $mapivi_icons{"Rating$urg"}); &$callback();});
}
$label = $frame->Label(-image => $mapivi_icons{"Rating$$rating"}, -bd => 0)->pack(-side => 'left', -fill => 'y');
$label->bind('', sub { $menu->Popup(-popover => 'cursor', -popanchor => 'n'); } );
return $label;
}
##############################################################
##############################################################
sub rating_button_min_max {
my ($widget, $ratingA, $ratingB, $callback) = @_;
my ($butA, $butB);
# todo: fails is rating is 0!!!
$butA = rating_button($widget, sub {
$$ratingB = $$ratingA if ($$ratingB != 0 and (($$ratingB < $$ratingA) or ($$ratingA == 0)));
$butB->configure(-image => $mapivi_icons{'Rating'.$$ratingB}); &$callback() if $callback
}, "Rating Max", 'left', 'x', $ratingA);
$widget->Label(-text => '-')->pack(-side => 'left');
$butB = rating_button($widget, sub {
$$ratingA = $$ratingB if ($$ratingA == 0 or ($$ratingB > 0 and ($$ratingA > $$ratingB)));
$butA->configure(-image => $mapivi_icons{'Rating'.$$ratingA}); &$callback() if $callback
}, "Rating Min", 'left', 'x', $ratingB);
return ($butA, $butB);
}
##############################################################
# addToSearchDB - add a picture to the search data base
# this function can be called with one or four
# parameters
##############################################################
sub addToSearchDB {
my $dpic = shift;
# normalize the path
$dpic =~ s/\\/\//g; # replace Windows path delimiter with UNIX style \ -> /
$dpic =~ s/\/+/\//g; # replace multiple slashes with one // -> /
$dpic =~ s/\/\.\//\//g; # replace dot dir /./ -> /
if (!-f $dpic) {
warn "addToSearchDB: $dpic not found!";
return;
}
print "addToSearchDB $dpic\n" if $verbose;
# do not save pics to the database which are located in .thumbs/ .xvpics/ .exif/
my $dir = dirname($dpic);
$dir =~ s!/$!!g; # remove trailing /
if ($dir =~ m/$thumbdirname|$exifdirname|$xvpicsdirname$/) {
print "addToSearchDB: ignoring $dpic\n" if $verbose;
return;
}
my ($com, $exif, $ctime, $mtime, $iptc, $urgency, $size, $x, $y, $keys, @keys, $pop, $flag);
# $meta is returned at the end of the sub,
# the SOF segment is needed for the latter call of getAllFileInfo
my $meta = getMetaData($dpic, "COM|APP1|APP13|SOF", 'FASTREADONLY');
$exif = getShortEXIF( $dpic, WRAP, $meta);
$com = getComment( $dpic, LONG, $meta);
$iptc = getIPTC( $dpic, SHORT, $meta);
$size = getFileSize( $dpic, NO_FORMAT);
($x,$y) = getSize( $dpic, $meta);
$mtime = getFileDate( $dpic, NO_FORMAT);
@keys = getIPTCkeywords($dpic, $meta);
$pop = 0;
$pop = $searchDB{$dpic}{POP} if (defined $searchDB{$dpic}{POP});
$flag = $searchDB{$dpic}{FLAG} if (defined $searchDB{$dpic}{FLAG});
# handling of non-printables is already done in getIPTC and getIPTCkeywords
# todo: It is needed here too, but why?
$iptc =~ tr/\n -~//cd; # remove all non-printable chars, but not newline
foreach (@keys) {
$_ =~ tr/ -~//cd; # remove all non-printable chars (Picasa adds one to each keyword)
}
# build a space separated string from the keyword list
# todo find a better separator, so that keywords with spaces can be supported better
foreach (@keys) { $keys .= "$_ "; }
# check if the pictures contain new keywords
if ($config{CheckNewKeywords}) {
foreach (@keys) {
# store all keywords in a hash and count them
if (defined $new_keywords{$_}) {
$new_keywords{$_}++;
}
else {
$new_keywords{$_} = 1;
}
}
}
# try to get the EXIF date from the short EXIF info format: "dd.mm.yyyy hh:mm:ss"
# there may be [t] or [s] in front of the date!
undef $ctime;
if (defined($exif)) {
my $year; my $mon; my $day; my $hour; my $min; my $sec;
# support three different date formats
# dd.mm.yyyy hh:mm:ss
if ($exif =~ m/(\d\d)\.(\d\d)\.(\d\d\d\d)\s(\d\d):(\d\d):(\d\d)/) {
$day = $1;
$mon = $2;
$year = $3;
$hour = $4;
$min = $5;
$sec = $6;
}
# mm/dd/yyyy hh:mm:ss
if ($exif =~ m/(\d\d)\/(\d\d)\/(\d\d\d\d)\s(\d\d):(\d\d):(\d\d)/) {
$mon = $1;
$day = $2;
$year = $3;
$hour = $4;
$min = $5;
$sec = $6;
}
# yyyy-mm-dd hh:mm:ss
if ($exif =~ m/(\d\d\d\d)-(\d\d)-(\d\d)\s(\d\d):(\d\d):(\d\d)/) {
$year = $1;
$mon = $2;
$day = $3;
$hour = $4;
$min = $5;
$sec = $6;
}
$mon--;
if (defined $year) {
# todo: this may be dangerous or at least wrong!
if ($year > $copyright_year) { # fix wrong dates
print "Mapivi warning: $dpic: EXIF year: $year is in the future, correcting to $copyright_year\n";
$year = $copyright_year;
}
#$year -= 1900;
if ($mon >= 0 and $mon <= 11) {
# calculate the time as value in seconds since the Epoch (Midnight, January 1, 1970)
$ctime = timelocal($sec,$min,$hour,$day,$mon,$year);
#warn "using exifdate for $dpic: $ctime\n" if $verbose;
# optional checks
#my ($s,$m,$h,$d,$mo,$y) = localtime $ctime;
#$y += 1900; $mo++; # do some adjustments
# build up the date time string, sim#lar to the EXIF format
#my $date1 = sprintf "%04d:%02d:%02d %02d:%02d:%02d", $y, $mo, $d, $h, $m, $s;
#my $date2 = "$3:$2:$1 $4:$5:$6";
#print "$date2 $date $dpic\n" if ($date1 ne $date2);
}
}
#else { print "mon = $mon $3:$2:$1 $4:$5:$6\n";}
}
#else { print "no exif date: $exif" if $verbose; }
# if there is no exif time available use the file modification date
unless (defined $ctime) {
$ctime = (lstat $dpic)[9]; # 9 is the modification date time
#warn "using filedate for $dpic: $ctime\n" if $verbose;
}
# replace all newlines with space before adding to the database
#$com =~ s/\n/ /g if (defined $com);
#$exif =~ s/\n/ /g if (defined $exif);
#$iptc =~ s/\n/ /g if (defined $iptc);
# maybe there was something defined before, so we better overwrite it with ''
$com = '' unless (defined $com);
$exif = '' unless (defined $exif);
$iptc = '' unless (defined $iptc);
$iptc =~ s/urgency\s*:\s*\d*\s*//i; # remove urgency from the IPTC field
$iptc =~ s/keywords\s*:\s*.*\n*//i; # remove keywords from the IPTC field
$urgency = getIPTCurgency($dpic, $meta);
$urgency = undef if ($urgency == 9);
delete $searchDB{$dpic}; # clear hash item first
#print "adding: IPTC: $iptc\n";
#print "adding: Keys: $keys\n";
#print "adding: URG : $urgency\n";
$searchDB{$dpic}{COM} = $com; # save (complete!) comment
$searchDB{$dpic}{EXIF} = $exif; # save short EXIF info
$searchDB{$dpic}{SIZE} = $size; # save file size in Bytes
$searchDB{$dpic}{PIXX} = $x; # save pixel size (x = width)
$searchDB{$dpic}{PIXY} = $y; # save pixel size (y = height)
$searchDB{$dpic}{TIME} = $ctime; # save EXIF/file creation time
$searchDB{$dpic}{MOD} = $mtime; # save file modification time
$searchDB{$dpic}{IPTC} = $iptc; # save complete IPTC info, but without urgency and keywords
$searchDB{$dpic}{URG} = $urgency; # save IPTC urgency
$searchDB{$dpic}{KEYS} = $keys; # save IPTC keywords
$searchDB{$dpic}{POP} = $pop if ($config{trackPopularity}); # save popularity (how often the pic was shown)
$searchDB{$dpic}{FLAG} = $flag; # save flag markers
#print "---IPTC: $searchDB{$dpic}{IPTC}---\n";
return $meta;
}
##############################################################
# getMetaData - returns the Image::MetaData::JPEG
# object of $dpic
##############################################################
sub getMetaData {
my $dpic = shift;
my $what = shift; # regex to match the needed segments e.g. "COM" for comment,
# or "APP13|COM" for IPTC info and comment segments
my $option = shift; # optional option, if set to 'FASTREADONLY' will speed things up
return unless is_a_JPEG($dpic);
# mapivi just needs the comments (COM), EXIF (APP1), IPTC (APP13) and size (SOF) segments
my $meta = new Image::MetaData::JPEG($dpic, $what, $option);
print "getMetaData: Kind:$what pic:$dpic\n" if $verbose;
warn "Error: " . Image::MetaData::JPEG::Error() unless $meta;
return $meta;
}
##############################################################
# check is file is a raw picture file based on file suffix
##############################################################
sub is_raw_file {
my $file = shift;
my $is_raw = 0;
if (-f $file) {
my ($basename,$dir,$suffix) = fileparse($file, '\.[^.]*'); # suffix = . and not-. (one dot and zero or more non-dots)
$is_raw = 1 if (isInList(lc($suffix), \@raw_suffix_lc));
}
return $is_raw;
}
##############################################################
# check if the given file has a RAW file with same name
# and in same folder
##############################################################
sub has_raw_file {
my $basename = shift; # the basename is the complete path with filename but without suffix
my $rc = 0;
foreach my $raw_suffix (@raw_suffix) {
# check for different suffix and suffix in lower case
if ((-f $basename.$raw_suffix) or (-f $basename.lc($raw_suffix))) {
$rc = 1;
last;
}
}
return $rc;
}
##############################################################
# return true if a copy of the given file in the origs folder
# with either the same name or the "-bak" suffix exists
# the second return value is the file name if found, else
# it is undef
##############################################################
sub has_orig_file {
my ($pic,$dir,$suffix) = @_;
my $rc = 0;
my $file = undef;
my $orig = $dir.$conf{origs_folder_name}{value}.'/'.$pic.$suffix;
if (-f $orig) {
$rc = 1;
$file = $orig;
}
else {
my $origbak = buildBackupName($orig);
if (-f $origbak) {
$rc = 1;
$file = $origbak;
}
}
return ($rc, $file);
}
##############################################################
# getAllFileInfo
##############################################################
sub getAllFileInfo {
my $dpic = shift;
my $bpic = buildBackupName($dpic);
my $size = '';
my $w = 0;
my $h = 0;
my ($pic,$dir,$suffix) = fileparse($dpic, '\.[^.]*'); # suffix = . and not-. (one dot and zero or more non-dots)
my $basename = "$dir/$pic";
$size = basename($dpic)."\n";
$size .= int($searchDB{$dpic}{SIZE}/1024).'kB' if $searchDB{$dpic}{SIZE};
$size .= '[bak]' if (-f $bpic); # show that there is a backup file
$size .= '[orig]' if (has_orig_file($pic,$dir,$suffix)); # show that there is a original file
$size .= '[raw]' if (has_raw_file($basename)); # show that there is a raw file
$size .= '[XMP]' if ((-f $basename.'.xmp') or (-f $basename.'.XMP')); # show that there is a XMP sidecar file
$size .= '[WAV]' if ((-f $basename.'.wav') or (-f $basename.'.WAV')); # show that there is a WAV audio file
$size .= "\n".date_iso_to_relative(getDateTimeISOString($searchDB{$dpic}{MOD})) if ($config{ShowFileDate} and defined $searchDB{$dpic}{MOD});
$w = $searchDB{$dpic}{PIXX} if $searchDB{$dpic}{PIXX};
$h = $searchDB{$dpic}{PIXY} if $searchDB{$dpic}{PIXY};
# MP = MegaPixel
my $p = sprintf "%.2f", ($w*$h/1000000);
$size .= "\n${w}x$h (${p}MP)";
if ($config{BitsPixel}) {
my $bitPix = getBitPix($dpic);
$bitPix = sprintf "%.2f", $bitPix;
$size .= "\n${bitPix}b/p";
}
$size .= "\n".getAspectRatio($w, $h) if ($config{AspectRatio} and ($w > 0) and ($h > 0));
if (-l $dpic) { $size .= "\n(Link)"; }
$size .= " Viewed ".$searchDB{$dpic}{POP}.' times' if (($config{trackPopularity}) and (defined $searchDB{$dpic}{POP}));
return $size;
}
##############################################################
# getAspectRatio
##############################################################
sub getAspectRatio {
my $w = shift;
my $h = shift;
return '' if (($h == 0) or ($w == 0));
my $aspectdelta = 1 + ($config{AspectSloppyFactor} / 100); # delta factor for aspect ratio
my $r = $w/$h; # aspect ratio
my $ratio = '';
if (($r <= $aspectdelta*4/3) and ($r >= (4/3)/$aspectdelta)) {
$ratio = "[4:3]";
} elsif (($r <= $aspectdelta*3/4) and ($r >= (3/4)/$aspectdelta)) {
$ratio = "[3:4]";
} elsif (($r <= $aspectdelta*2/3) and ($r >= (2/3)/$aspectdelta)) {
$ratio = "[2:3]";
} elsif (($r <= $aspectdelta*3/2) and ($r >= (3/2)/$aspectdelta)) {
$ratio = "[3:2]";
} elsif (($r <= $aspectdelta*5/4) and ($r >= (5/4)/$aspectdelta)) {
$ratio = "[5:4]";
} elsif (($r <= $aspectdelta*4/5) and ($r >= (4/5)/$aspectdelta)) {
$ratio = "[4:5]";
} elsif (($r <= $aspectdelta*7/5) and ($r >= (7/5)/$aspectdelta)) {
$ratio = "[7:5]";
} elsif (($r <= $aspectdelta*5/7) and ($r >= (5/7)/$aspectdelta)) {
$ratio = "[5:7]";
} elsif (($r <= $aspectdelta*16/9) and ($r >= (16/9)/$aspectdelta)) {
$ratio = "[16:9]";
} elsif (($r <= $aspectdelta*9/16) and ($r >= (9/16)/$aspectdelta)) {
$ratio = "[9:16]";
} elsif ($w == $h) {
$ratio = "[1:1]";
} else {
if ($w > $h) { $ratio = sprintf "[%.2f:1]", ($w/$h); }
else { $ratio = sprintf "[1:%.2f]", ($h/$w); }
}
return $ratio;
}
##############################################################
# removeIPTC
##############################################################
sub removeIPTC {
my @sellist = $picLB->info('selection');
return unless checkSelection($top, 1, 0, \@sellist, lang("picture(s)"));
my $rc = $top->messageBox(-icon => 'question', -message => langf("Please press Ok to remove all IPTC info of the %d selected pictures. There is no undo!", scalar @sellist),
-title => lang('Remove all IPTC info?'), -type => 'OKCancel');
return if ($rc !~ m/Ok/i);
my $errors = '';
my $i = 0;
my $pw = progressWinInit($top, "Remove IPTC info");
foreach my $dpic (@sellist){
last if progressWinCheck($pw);
$i++;
progressWinUpdate($pw, "Removing IPTC info ($i/".scalar @sellist.") ...", $i, scalar @sellist);
next unless (-f $dpic);
next if (!checkWriteable($dpic));
my $meta = getMetaData($dpic, "APP13");
$meta->remove_app13_info(-1, 'IPTC'); # remove all APP13 IPTC segments
unless ($meta->save()) {
$errors .= "removeIPTC: save $dpic failed!\n";
}
updateOneRow($dpic, $picLB);
if ($dpic eq $actpic) {
showImageInfo($dpic);
#showImageInfoCanvas($dpic);
}
}
progressWinEnd($pw);
log_it("ready! (removed IPTC info of $i/".scalar @sellist.")");
showText("Errors while removing IPTC infos", $errors, NO_WAIT) if ($errors ne '');
return;
}
##############################################################
# cutString - cat a string to a given length, remove newline
# and carriage return and add e.g. dots if cut
# examples: cutString("elephant",20,"..") -> "elephant"
# cutString("elephant", 7,"..") -> "eleph.."
# cutString("elephant",-7,"..") -> "..phant"
##############################################################
sub cutString {
my $str = shift; # input string
my $len = shift; # the max length
my $dot = shift; # the dots (e.g. ".." or "...")
return unless (defined $str);
return if ($str eq '');
my $dotlen = length($dot);
my $out = $str;
if (length($dot) >= abs($len)) {
warn "cutString: lenght of dots is longer or equal than length";
return $out;
}
if ($len >= 0) {
$out = substr($out, 0, ($len-$dotlen)).$dot if (length($out) > $len);
}
else {
$out = $dot.substr($out, ($len+$dotlen), length($str)) if (length($out) > -$len);
}
$out =~ s/\n//g; # remove newlines
$out =~ s/\r//g; # remove \r (carriage return)
return $out;
}
##############################################################
# formatString - cuts and formats a string to
# a width of $linelenght chars and a length of
# $line_nr_limit lines.
# this function wont work as expected with
# comments containing a lot of nearly empty lines
##############################################################
sub formatString {
my $string = shift;
my $linelenght = shift;
my $line_nr_limit = shift; # use -1 if there should be no line nr limit
return '' if ((!defined $string) or ($string eq ''));
local($Text::Wrap::columns) = $linelenght+1;
local($Text::Wrap::huge) = 'overflow';
# sanitize and wrap string
$string =~ s/\r//g; # cut \r (carriage return)
$string =~ tr[\200-\377][\000-\177]; # remove the eight bit
$string =~ tr/\n -~//cd; # remove non-printable characters (but not \n)
$string = wrap('','',$string);
# limit the number of lines (cut off the rest)
if ($line_nr_limit > 0) {
# split up in an array of single lines
my @l = split /\n/, $string;
my $max = $line_nr_limit;
$max = @l if (@l < $max);
$string = '';
# rebuild string by using the first $max lines
for ( 0 .. ($max - 1)) {
$string .= sprintf "%s\n", $l[$_];
}
$string =~ s/\n+$//; # cut off trailing newline(s)
}
return $string;
}
##############################################################
##############################################################
sub get_list_size {
my $list_ref = shift;
my $size = 0;
my $size_str = '';
foreach my $dpic (@{$list_ref}) {
$size += getFileSize($dpic, NO_FORMAT);
}
$size_str = computeUnit($size) if $size;
return $size_str;
}
##############################################################
# getFileSize - get the size in kB of a file, even if it is a link
##############################################################
sub getFileSize {
my $dpic = shift;
my $format = shift; # NO_FORMAT = return size unformated in Bytes (integer) FORMAT = with "kB" added (string)
my $size = '';
return $quickSortHashSize{$dpic} if ($quickSortSwitch and defined $quickSortHashSize{$dpic});
if (!-f $dpic) {
warn "getFileSize: $dpic is no file!";
if ((defined $format) and ($format == NO_FORMAT)) {
return 0;
}
else {
return '';
}
}
if (-l $dpic) {
$size = (lstat (getLinkTarget($dpic)))[7];
}
else {
$size = (lstat $dpic)[7];
}
if ((defined $format) and ($format == FORMAT)) {
$size = int($size/1024).'kB' if $size;
}
$quickSortHashSize{$dpic} = $size if $quickSortSwitch;
return $size;
}
##############################################################
# makeDir - create the directory for storing the
# thumbnail pictures or EXIF infos
##############################################################
sub makeDir {
my $dir = shift;
my $ask = shift; # ASK = ask before creating a dir, NO_ASK
return 1 if (-d $dir);
if ( ($ask == ASK) and $config{AskMakeDir} ) {
my $rc = checkDialog("Create new folder?",
"Mapivi would like to create this folder:\n$dir\nContinue?",
\$config{AskMakeDir},
"ask every time",
'',
'OK', 'Cancel');
return if ($rc ne 'OK');
}
# 0755 = rwxr.xr.x
eval { mkpath($dir, 0, oct(755)) }; # 0 = no output, 0755 = access rights
if ($@) {
$top->messageBox(-icon => 'warning', -message => "makeDir: can not create $dir: $@",
-title => 'Error', -type => 'OK');
return 0;
}
return 1;
}
##############################################################
# aNewerThanb - true if file a is newer than file b, or if
# file a exists and file b does not
##############################################################
sub aNewerThanb {
my $afile = shift;
my $bfile = shift;
if (-f $afile) {
if (-f $bfile) {
# compare modification times
return (lstat $afile)[9] > (lstat $bfile)[9];
}
return 1;
}
return 0;
}
##############################################################
# nextPic - get the index of the next picture in the directory
##############################################################
sub nextPic {
my $actpic = shift;
my @pics = $picLB->info('children');
# if there are no pics return an empty string
return '' if (@pics == 0);
# if there is no actpic we start with the first
return $pics[0] if ($actpic eq '');
# try to get the next pic
my $next = $picLB->info('next', $actpic);
# if there is no next pic
unless ($next) {
# we have reached the end and start again with the first picture
beep() if ($config{BeepWhenLooping});
$next = $pics[0];
}
return $next;
}
##############################################################
# nextSelectedPic - get the index of the next selected picture
# in the directory
##############################################################
sub nextSelectedPic {
my $actpic = shift;
my @pics = $picLB->info('children');
my @sel = $picLB->info('selection');
# if there are no pics return an empty string
return '' if (@pics == 0);
return '' if (@sel == 0);
my $start = 0;
my $next = '';
my $nextsel = '';
foreach my $dpic (@pics) {
# skip all pics until we reach the actual picture
$start = 1 if ($dpic eq $actpic);
next unless $start;
# get the next picture
$next = $picLB->info('next', $dpic);
# check if it is selected
if ($next and isInList($next, \@sel)) {
$nextsel = $next;
last;
}
}
# if there is no next pic
if ($nextsel eq '') {
# we have reached the end and start again with the first selected picture
#beep() if ($config{BeepWhenLooping});
$nextsel = $sel[0];
}
return $nextsel;
}
##############################################################
# prevPic - show the previous picture in the directory
##############################################################
sub prevPic {
my $actpic = shift;
my @pics = $picLB->info('children');
# if there are no pics return an empty string
return '' if (@pics == 0);
# if there is no actpic we start with the first
return $pics[-1] if ($actpic eq '');
# try to get the previous pic
my $prev = $picLB->info('prev', $actpic);
# if there is no prev pic
unless ($prev) {
# we have reached the start and jump to the last picture
beep() if ($config{BeepWhenLooping});
$prev = $pics[-1];
}
return $prev;
}
##############################################################
# gotoPic
##############################################################
sub gotoPic {
my $lb = shift;
return if (stillBusy()); # block, until last picture is loaded
if ($slideshow == 1) {
$slideshow = 0; slideshow();
} # switch slideshow off
my @childs = $lb->info('children');
return if (!@childs);
my $goto = '';
my $rc = myEntryDialog("Go to picture/select pictures", "Please enter a part of the name or the index number of the picture(s) to select/show.\nIndex number are entered like this: /number.\nUse /c to switch to case sensitive and /s if the filename starts with the search string.\n\nExamples:\nabc show and select all pictures containing abc (any case)\n/10 show picture number 10\n/sabc show and select all pictures starting with abc (any case)\n/cABC show and select all pictures containing an upper case ABC\n/s/cABC show and select all pictures starting with an upper case ABC", \$goto);
return if (($rc ne 'OK') or ($goto eq ''));
if ($goto =~ m/(\/)(\d+)/) { # $goto is a number
if (($2 > 0) and ($2 < @childs + 1)) {
# saved here for undo function
@savedselection2 = @savedselection;
@savedselection = $lb->info('selection');
$lb->selectionClear();
showPic($childs[$2-1]) if ($lb == $picLB);
}
else {
log_it("number $2 is out of range!");
}
}
else { # $goto is a string
my @pics;
my $case = "i";
my $start = ".*";
if ($goto =~ m/.*\/c/) { $case = ''; $goto =~ s/\/c//; }
if ($goto =~ m/.*\/s/) { $start = "^"; $goto =~ s/\/s//; }
foreach (@childs) {
if (basename($_) =~ m/(?$case)$start$goto.*/) {
push @pics, $_;
}
}
if (@pics) {
# saved here for undo function
@savedselection2 = @savedselection;
@savedselection = $lb->info('selection');
$lb->selectionClear();
showPic($pics[0]) if ($lb == $picLB);
reselect($lb, @pics);
log_it("selected ".scalar @pics." pictures matching \"$goto\"");
}
else {
log_it("string $goto was not found in the picture names");
}
}
}
##############################################################
# showImageInfo - display infos and comment of given image
# if available
##############################################################
sub showImageInfo {
my $dpic = shift;
if ((not defined $dpic) or (not -f $dpic)) {
$widthheight = '';
$size = '';
#$exif = '';
$rating_but->configure(-image => $mapivi_icons{Rating0});
$commentText->delete( 0.1, 'end') if ($config{ShowCommentField});
}
else {
my $meta = getMetaData($dpic, "COM|APP13|APP1|SOF", 'FASTREADONLY');
($width, $height) = getSize($dpic, $meta);
$widthheight = $width.'x'.$height;
if ($config{ShowCommentField}) {
my $comment = getComment($dpic, LONG, $meta);
# does not work! mh 14.07.03
# # determine the height of the textbox by counting the number of lines
# my $height = ($comment =~ tr/\n//);
# $height++;
# $height = 10 if ($height > 10); # not to big, we have scrollbars
# print "h = $height\n";
# $commentText->configure(-height => $height);
$commentText->delete( 0.1, 'end'); # remove old comment
$commentText->insert('end', $comment); # insert new comment
}
update_IPTC_frame_content($dpic);
my $star_icon = iptc_rating_star_icons($dpic);
$rating_but->configure(-image => $mapivi_icons{$star_icon});
$size = getFileSize($dpic, FORMAT);
}
setTitle();
# also update the canvas text
showImageInfoCanvas($dpic); # if ($dpic eq $actpic);
}
##############################################################
# update or clear IPTC Headline and Caption entry in picture frame
##############################################################
sub update_IPTC_frame_content {
my $dpic = shift; # optional
if (($config{ShowIPTCFrame}) and (defined $titleText)) {
$titleText->delete( 0.1, 'end'); # remove old headline
$captionText->delete( 0.1, 'end'); # remove old caption
if ((defined $dpic) and (-f $dpic)) {
my $headline = getIPTCHeadline($dpic);
$titleText->insert('end', $headline); # insert new headline
my $caption = getIPTCCaption($dpic);
$captionText->insert('end', $caption); # insert new caption
}
}
return;
}
##############################################################
# showImageInfoCanvas - display infos on the canvas
##############################################################
# ToDo: check if either showImageInfo could call showImageInfoCanvas or other way round
# and fix all calls correspondingly
sub showImageInfoCanvas {
my $dpic = shift;
$c->delete('withtag', 'TEXT'); # remove picture info text
$c->delete('withtag', 'GPS'); # remove GPS button
update_IPTC_frame_content($dpic);
return 0 unless (defined $dpic);
return 0 unless (-f $dpic);
if ($config{ShowPicInfo}) {
# update balloon info for displayed picture
my $balloonmsg = makeBalloonMsg($dpic);
# bind the balloon to the canvas
$balloon->attach($c->Subwidget('canvas'), -balloonposition => 'mouse', -msg => {'pic' => $balloonmsg} );
}
return 1 unless ($config{ShowInfoInCanvas});
GPS_button($c, $dpic);
my $info = lang('File').': '.basename($dpic)."\n";
$info .= lang('Path').': '.dirname($dpic)."\n\n";
my $meta = getMetaData($dpic, "COM|APP13|APP1|SOF", 'FASTREADONLY');
my $exif = formatString(date_iso_to_relative(getShortEXIF($dpic, NO_WRAP, $meta)), 80, -1);
my $comm = formatString(getComment($dpic, LONG, $meta), 80, -1);
my $iptc = formatString(getIPTC($dpic, LONG, $meta), 80, -1);
my $xmp = formatString(xmp_get($dpic), 80, -1);
#my $iptcE= formatString(iptc_get($dpic), 80, -1); # iptc extracted by ExifTool
#my $exifE= formatString(exif_get($dpic), 80, -1); # exif extracted by ExifTool
$info .= "EXIF:\n$exif\n" if ($exif ne '');
$info .= "\nIPTC:\n$iptc\n" if ($iptc ne '');
$info .= "\nXMP:\n$xmp\n" if ($xmp ne '');
#$info .= "\nIPTC (from ExifTool):\n$iptcE\n" if ($iptcE ne '');
#$info .= "\nEXIF (from ExifTool):\n$exifE\n" if ($exifE ne '');
$info .= "\nComment:\n$comm" if ($comm ne '');
return 1 if ($info eq '');
# show image info on canvas white font with black shadow
$c->createText( 5, 5, -font => $font, -text => $info, -anchor => 'nw',
-fill => 'black', -tags => ['TEXT']);
my $id = $c->createText( 4, 4, -font => $font, -text => $info, -anchor => 'nw',
-fill => $conf{color_fg}{value}, -tags => ['TEXT']);
my ($x1, $y1, $x2, $y2) = $c->bbox($id);
$c->createText( 4, $y2+4, -font => $small_font, -text => lang("F3: show/hide overlay text"),
-anchor => 'nw', -fill => 'gray60', -tags => ['TEXT']);
return 1;
}
##############################################################
# display any text with shadow on any canvas
# based on showImageInfoCanvas
# uses TEXT, METAINFO and SHADOW as tags
##############################################################
sub show_text_on_canvas {
my $c = shift; # canvas widget
my $text = shift;
$c->delete('withtag', 'TEXT'); # remove picture info text
if ($conf{show_micro_meta}{value}) {
return 1 if (not defined $text or $text eq '');
# show image info on canvas white font with black shadow (shadow offset = 1 pixel)
$c->createText( 5, 5, -font => $font, -text => $text, -anchor => 'nw',
-fill => 'black', -tags => ['TEXT','SHADOW']);
my $id = $c->createText( 4, 4, -font => $font, -text => $text, -anchor => 'nw',
-fill => 'gray60', -tags => ['TEXT','METAINFO']); # old fill: $conf{color_fg}{value}
# change font size to fill window width
adapt_font_size($c, 'METAINFO', 'SHADOW');
# add info text (always in small size)
my ($x1, $y1, $x2, $y2) = $c->bbox($id);
$c->createText( 4, $y2+4, -font => $small_font, -text => lang("F3: show/hide overlay text"),
-anchor => 'nw', -fill => 'gray60', -tags => ['TEXT']);
}
return 1;
}
##############################################################
##############################################################
sub adapt_font_size {
my $c = shift; # canvas widget
my $tag = shift; # tag of text item on canvas
my $tag2 = shift; # tag of shadow text item on canvas
my $font_size_min = 10;
my $font_size = $font_size_min;
my $quit = 0; # flag to exit loop
$top->update;
my $c_w = $c->width;
return if (not defined $c_w);
my @ids = $c->find('withtag', $tag);
return if (not @ids);
# assumption: there is just one canvas element with this tag
my $border = 3; #0.1 * $c->Width; # keep a 10% border around the text
for my $i (1..10) { # max 10 iterations to avoid endless loops
my ($x1, $y1, $x2, $y2) = $c->bbox($ids[0]);
last if (not defined ($x1));
# calc distance between right text border and right canvas corner
my $distance = $c_w - $border - $x2;
#print "adapt_FontSize: $i $font_size distance: $distance canvas:$c_w x2:$x2\n";
# Flux Capacitor ;-)
if ($distance > 100) { # a lot of space -> increase font size
$font_size = round($font_size*1.2);
}
elsif ($distance > 50) { # some space left
$font_size += 1;
}
elsif ($distance < -100) { # text is much too wide
$font_size = round($font_size*0.8);
}
elsif ($distance < 0) { # text is a litte too wide
$font_size -= 1;
}
else {
# size if fine, leave loop
last;
}
# minimum and maximum font sizes
if ($font_size < $font_size_min) {
$font_size = $font_size_min;
#print " reached minimum font size\n";
$quit = 1; # leave loop after font change
}
if ($font_size > $conf{font_size_big}{value}) {
$font_size = $conf{font_size_big}{value};
#print " reached maximum font size\n";
$quit = 1; # leave loop after font change
}
# make and apply new font
$font_big = $top->Font(-family => $config{'FontFamily'}, -size => $font_size);
$c->itemconfigure($ids[0], -font => $font_big);
# update also shadow text
my @ids2 = $c->find('withtag', $tag2);
$c->itemconfigure($ids2[0], -font => $font_big) if (@ids2);
$c->update;
last if ($quit);
}
return 1;
}
##############################################################
# returns string with very short picture meta info
# only EXIF and IPTC
# todo: maybe add some selected XMP values later
##############################################################
sub get_meta_micro {
my $dpic = shift;
my $meta = getMetaData($dpic, "COM|APP13|APP1|SOF", 'FASTREADONLY');
my $micro = formatString(date_iso_to_relative(getMicroEXIF($dpic, $meta)), 80, -1);
$micro .= "\n" if ($micro ne '');
$micro .= formatString(getIPTC($dpic, MICRO, $meta), 80, -1);
return $micro;
}
##############################################################
# adds a GPS button on the given canvas depending
# on the existence of EXIF GPS coordinates in the given picture
##############################################################
sub GPS_button {
my $c = shift; # canvas widget
my $dpic = shift; # displayed picture
# get GPS info from picture
my ($lat, $lon, $lat_ref, $lon_ref) = gps_get($dpic);
# add GPS button if both coordinates are available
if (defined $lat and defined $lon) {
$lat *= -1 if (defined $lat_ref and $lat_ref eq 'South');
$lon *= -1 if (defined $lon_ref and $lon_ref eq 'West');
# add GPS button in the upper right corner of the canvas
$c->createImage(($c->width - 20), 10, -image => $mapivi_icons{'Location'},
-tag => ['GPS'], -anchor => 'ne');
$c->bind(+'GPS', '', sub {
#web_browser_open('http://maps.google.com/maps?q='."$lat,$lon");
# due to the & in the open street web address we need additional quotes "
web_browser_open('http://www.openstreetmap.org/"?mlat='.$lat.'&mlon='.$lon.'"');
});
$c->bind(+'GPS', '', sub {
$c->configure(-cursor => 'hand2');
# workaround because balloon doesn't work
log_it('click here to display GPS position ('.$lat.', '.$lon.') in web browser');
});
$c->bind(+'GPS', '', sub {
$c->configure(-cursor => 'arrow');
# workaround because balloon doesn't work
log_it('');
});
# 2010-10 doesn't work, reason unclear:
#$balloon->attach($c->Subwidget('canvas'), -balloonposition => 'mouse', -msg => {'GPS' => 'click here to display GPS position in web browser'} );
}
}
##############################################################
##############################################################
sub web_browser_open {
my $url = shift;
my $command = "$conf{web_browser}{value} $url";
# instead of the & for UNIX windows needs a "start" in front of the application to run in the background
if ($EvilOS) {
$command = "start $url";
}
else {
$command .= " 2>&1 1>/dev/null &";
}
log_it("Open $url in browser ...");
$top->Busy;
(system "$command") == 0 or warn "$command failed: $!";
log_it("Ready! ($url opened)");
$top->Unbusy;
}
##############################################################
# showZoomInfo - calculate the zoom factor of the displayed
# pic by messuring the size of the file
# and the size on the canvas
##############################################################
sub showZoomInfo {
my $dpic = shift;
my $id = shift;
if (-f $dpic) {
my ($width, $height) = getSize($dpic);
my ($x1, $y1, $x2, $y2) = $c->bbox($id);
if ((defined $x2) and (defined $x1) and ($x2 - $x1 != 0)) {
my $z = $width/($x2 - $x1);
if ($z > 0) { # avoid divison by zero
$zoomFactorStr = int(1/$z * 100)."%";
if ($verbose) {
my $wz = $photos{$dpic}->width;
print "showZoomInfo: id=$id z = $z zoomFactorStr = $zoomFactorStr x1:$x1 x2:$x2 w:$width wz:$wz\n";
}
return;
}
}
}
$zoomFactorStr = "?%";
}
##############################################################
# handleNonJPEG
##############################################################
sub handleNonJPEG {
my $dir = shift;
my @pics = @_;
my $changed = 0; # counter
return 0 if ((defined $nonJPEGdirNoAskAgain{"$dir"}) and ($nonJPEGdirNoAskAgain{"$dir"} == 1));
# open window
my $myDiag = $top->Toplevel();
$myDiag->title(lang('Non-JPEG pictures'));
$myDiag->Label(-text => "There are ".scalar @pics." non-JPEG pictures in folder ".basename($dir).".\nShould I convert these pictures to JPEG format?\n(After convertion these pictures will be visible in Mapivi.)")->pack(-fill => 'x', -padx => 3, -pady => 3);
my $qS = labeledScale($myDiag, 'top', 40, "Quality of JPEG picture when converting", \$config{PicQuality}, 10, 100, 1);
qualityBalloon($qS);
my $removeOrig = 0;
$myDiag->Checkbutton(-variable => \$removeOrig, -text => "Remove the original pictures after conversion")->pack(-anchor=>'w');
my $ButF =
$myDiag->Frame()->pack(-fill =>'x', -padx => 0, -pady => 0);
my $OKB =
$ButF->Button(-text => lang('OK'),
-command => sub {
$myDiag->withdraw();
$myDiag->destroy();
$changed = convertToJPEG($dir, $removeOrig, @pics);
})->pack(-side => 'left', -expand => 1, -fill => 'x', -padx => 2, -pady => 3);
$ButF->Button(-text => lang("Show picture list"),
-command => sub {
my $info = "Non-JPEG pictures in $dir:\n\n";
foreach (sort @pics) {
my $size = getFileSize("$dir/$_", NO_FORMAT);
$info .= sprintf "%-45s %12s Bytes\n", $_, $size;
}
showText("Non-JPEG pictures", $info, WAIT);
})->pack(-side => 'left', -expand => 1, -fill => 'x', -padx => 2, -pady => 3);
my $xBut = ButF->Button(-text => lang('Cancel'),
-command => sub {
# save dir in hash, so we don't bother the user again if he reopens the dir
$nonJPEGdirNoAskAgain{"$dir"} = 1;
$myDiag->withdraw();
$myDiag->destroy();
})->pack(-side => 'left', -expand => 1, -fill => 'x', -padx => 2, -pady => 3);
bind_exit_keys_to_button($myDiag, $xBut);
$myDiag->Popup(-popover => 'cursor');
repositionWindow($myDiag);
if ($EvilOS) { # sometimes to dialog disappears when clicked on, so we need a short grab
$myDiag->grab;
$myDiag->after(50, sub{$myDiag->grabRelease});
}
$myDiag->waitWindow;
my $reread = ($changed > 0) ? 1 : 0;
return $reread;
}
##############################################################
# convertToJPEG - convert the piclist to JPEG format
##############################################################
sub convertToJPEG {
my $dir = shift;
my $del = shift; # delete orig after conversion (bool)
my @pics = @_;
my $converted = 0;
foreach (@pics) {
my $dpic = "$dir/$_";
my $tpic = $dpic;
$tpic =~ s/($nonJPEGsuffixes)$/jpg/i;
print "convertToJPEG: $_ -> $tpic\n" if $verbose;
if (-f $tpic) {
$top->messageBox(-icon => 'warning', -message => "$tpic exists - skipping!",
-title => 'Warning', -type => 'OK');
next;
}
log_it("converting $_ to JPEG $tpic ...");
my $command = "convert";
$command .= " -quality ".$config{PicQuality}." \"$dpic\" \"$tpic\"";
$top->Busy;
#(system "$command") == 0 or warn "$command failed: $!";
execute($command);
$top->Unbusy;
$converted++ if ((-f $tpic) and (!-z $tpic));
if (($del) and ((-f $tpic) and (!-z $tpic))) { removeFile($dpic); }
}
return $converted;
}
##############################################################
# showNonJPEGS - show all non JPEG files of the actual folder
# todo: rename to show_hidden_files and show the diff between
# files in folder and actually displayed pictures
##############################################################
sub showNonJPEGS {
my @files = getFiles($actdir);
# put just the files not matching jpg, jpeg, JPG or JPEG in the file list
my @nonjpeg = sort(grep {!m/.*\.jp(g|eg)$/i} @files);
#my $info = "There are ".scalar @nonjpeg." non-JPEGs in $actdir:\n\n";
#foreach (sort @nonjpeg) {
# my $size = getFileSize("$actdir/$_", NO_FORMAT);
# $info .= sprintf "%-45s %12s Bytes\n", $_, $size;
#}
#showText("Non-JPEGs", $info, WAIT);
if (@nonjpeg) {
# open window
my $myDiag = $top->Toplevel();
$myDiag->title(lang('Hidden files'));
$myDiag->iconimage($mapiviicon) if $mapiviicon;
$myDiag->Label(-anchor => 'w', -justify => 'left', -text => lang('List of hidden files in folder ').$actdir)->pack(-fill => 'x', -padx => 3, -pady => 3);
my $listBoxY = @nonjpeg;
$listBoxY = 30 if ($listBoxY > 30); # maximum 30 entries
my $listBox =
$myDiag->Scrolled('Listbox',
-scrollbars => 'osoe',
-selectmode => 'extended',
-exportselection => 0,
-width => 80,
-height => $listBoxY,
)->pack(-expand => 1, -fill =>'both', -padx => 3, -pady => 3);
$listBox->insert('end', @nonjpeg);
#$listBox->bind('', sub {
# @$sellist = $listBox->curselection();
# } );
my $ubutF = $myDiag->Frame()->pack(-fill =>'x', -padx => 3, -pady => 3);
$ubutF->Button(-text => lang('Select all'),
-command => sub {
$listBox->selectionSet(0, 'end');
})->pack(-side => 'left', -padx => 3, -pady => 3);
$ubutF->Button(-text => lang('Select videos'),
-command => sub {
$listBox->selectionClear(0, 'end');
my @list = $listBox->get(0, 'end');
my $index = 0;
foreach my $file (@list) {
print "check file: $file\n";
if (is_a_video($file)) {
$listBox->selectionSet($index);
}
$index++;
}
})->pack(-side => 'left', -padx => 3, -pady => 3);
$ubutF->Button(-text => lang('Select none'),
-command => sub {
$listBox->selectionClear(0, 'end');
})->pack(-side => 'left', -padx => 3, -pady => 3);
my $ButF = $myDiag->Frame()->pack(-fill =>'x', -padx => 3, -pady => 3);
my $playB = $ButF->Button(-text => lang('Play video'),
-command => sub {
my @sellist = $listBox->curselection();
return unless checkSelection($myDiag, 1, 0, \@sellist, lang("video(s)"));
my $command = $conf{video_player}{value}.' ';
foreach my $file (@sellist) {
$command .= '"'.$actdir.'/'.$nonjpeg[$file].'" ';
}
print "video command: - $command -\n";
execute($command);
})->pack(-side => 'left', -expand => 1, -fill => 'x', -padx => 3, -pady => 3);
$balloon->attach($playB, -msg => lang("Play selected videos with ").$conf{video_player}{value}.lang("\nTool can be changed in Options->Tools."));
my $editB = $ButF->Button(-text => lang('Edit picture'),
-command => sub {
my @sellist = $listBox->curselection();
return unless checkSelection($myDiag, 1, 0, \@sellist, lang("picture(s)"));
my @piclist;
foreach my $file (@sellist) {
push @piclist, $actdir.'/'.$nonjpeg[$file];
}
edit_pic($myDiag, @piclist);
})->pack(-side => 'left', -expand => 1, -fill => 'x', -padx => 3, -pady => 3);
$balloon->attach($editB, -msg => lang("Edit selected pictures with ").$conf{external_pic_editor}{value}.lang("\nTool can be changed in Options->Tools."));
$myDiag->bind('', sub { $editB->Invoke; } );
$ButF->Button(-text => lang('Delete'),
-command => sub {
my @sellist = $listBox->curselection();
my $rc = myButtonDialog("Really delete?",
"Press Ok to delete these ".scalar @sellist." files in $actdir.\nThere is no undelete!",
undef, 'OK', 'Cancel');
if ($rc eq 'OK') {
foreach my $file (@sellist) {
log_it("removing $nonjpeg[$file]");
removeFile($actdir.'/'.$nonjpeg[$file]);
}
# reread files and update lists
@files = getFiles($actdir);
@nonjpeg = sort(grep {!m/.*\.jp(g|eg)$/i} @files);
$listBox->delete(0, 'end'); # clear all
$listBox->insert('end', @nonjpeg); # insert new list
}
})->pack(-side => 'left', -expand => 0, -padx => 3, -pady => 3);
my $XB = $ButF->Button(-text => lang('Close'),
-command => sub { $myDiag->destroy(); }
)->pack(-side => 'left', -expand => 1, -fill => 'x', -padx => 3, -pady => 3);
$XB->bind('', sub { $XB->Invoke; } );
$myDiag->Popup;
if ($EvilOS) { # sometimes to dialog disappears when clicked on, so we need a short grab
$myDiag->grab;
$myDiag->after(50, sub{$myDiag->grabRelease});
}
$XB->focus;
$myDiag->waitWindow();
}
}
##############################################################
# convertNonJPEGS
##############################################################
sub convertNonJPEGS {
my @files = getFiles($actdir);
# put just the files not matching jpg, jpeg, JPG or JPEG in the file list
my @nonjpeg = grep {!m/.*\.jp(g|eg)$/i} @files;
handleNonJPEG($actdir, @nonjpeg);
updateThumbs();
}
##############################################################
# getPics - returns the piclist of the given dir
##############################################################
sub getPics {
my $dir = shift;
my $with_path = shift; # bool: WITH_PATH or JUST_FILE
my $check_for_non_jpegs = shift; # bool: CHECK_JPEG or NO_CHECK_JPEG
my @other;
my @files = getFiles($dir);
# are there non-JPEG pictures in this directory?
if ($check_for_non_jpegs == CHECK_JPEG) {
@other = grep {m/.*\.($nonJPEGsuffixes)$/i} @files;
my @otherNoJPEG;
foreach (@other) {
$_ =~ m/(.*)\.($nonJPEGsuffixes)$/i; # separate the name from the suffix
my $jpeg = "$1.jpg"; # built the corresponding jpeg file name
if (!-f "$dir/$jpeg") { # if this doesn't exists
push @otherNoJPEG, $_ # we push it to this list
}
}
# are there some non-JPEGs without corresponding JPEGs?
if (@otherNoJPEG > 0) {
my $reread = handleNonJPEG($dir, @otherNoJPEG); # ask the user to convert them
@files = getFiles($dir) if $reread; # reread file list if necessary
}
}
my @pics;
if ($config{supportOtherPictureFormats}) { # add "|(avi)" below to include AVI videos
# see also @raw_suffix at top of this file! .NEF .CRW .CR2 .DNG .NRW
# 2016-10: GIMP *.xcf works fine for e.g. thumbnail generation, but commands like
# ImageMagick -rotate destroy the GIMP file (file size -> 0kB). Thus dangerous!
@pics = grep {m/.*\.(jp(g|eg))|(crw)|(cr2)|(dng)|(nrw)|(gif)|(xpm)|(ppm)|(xbm)|(ti(f|ff))|(svg)|(png)|(bmp)|(nef)|(raw)$/i} @files;
}
else {
# put just the files matching jpg, jpeg, JPG or JPEG in the file list
@pics = grep {m/.*\.jp(g|eg)$/i} @files;
}
# if we are in the actual dir, display the number of non-JPEG files
if ($dir eq $actdir) {
$otherFiles = @files - @pics;
$otherFiles = '' if ($otherFiles == 0);
}
$dir =~ s|/*$||; # remove trailing slashes
if ($with_path == WITH_PATH) {
foreach (@pics) { $_ = "$dir/$_"; } # add the path to each file
}
return @pics;
}
##############################################################
# sortPics - sorts a list of pictures according to $sortby
##############################################################
sub sortPics {
my $sortby = shift;
my $sortreverse = shift;
my $pics = shift; # reference on array to sort
# todo: check if this causes problems in light table (no sorting possible?)
if ($act_modus == COLLECTION) {
#print "mode = COLLECTION: skipping sortPics()!\n";
return;
}
print "sortby = $sortby\n" if $verbose;
my $str = langf("Sorting %d pictures by %s",scalar(@$pics),$sortby);
$str .= ' '.lang('(reverse)') if $sortreverse;
log_it("$str ...");
clearQuickSortHashes(); # remove old values
$quickSortSwitch = 1; # activate quick sort/buffering
if ($sortby eq 'name') { # sort alphabetical with no case
@$pics = sort { uc(basename($a)) cmp uc(basename($b)) } @$pics;
}
elsif ($sortby eq 'date') { # sort by file date and name
#@$pics = sort { getFileDate($b, NO_FORMAT) <=> getFileDate($a, NO_FORMAT) ||
#uc($a) cmp uc($b) } @$pics;
@$pics = sort { $searchDB{$b}{MOD} <=> $searchDB{$a}{MOD} ||
uc($a) cmp uc($b) } @$pics;
}
elsif ($sortby eq 'exifdate') {
#@$pics = sort { getEXIFDate($b) cmp getEXIFDate($a) ||
#uc($a) cmp uc($b) } @$pics;
@$pics = sort { $searchDB{$b}{TIME} <=> $searchDB{$a}{TIME} ||
uc($a) cmp uc($b) } @$pics;
}
elsif ($sortby eq 'aperture') {
@$pics = sort { getEXIFAperture($a, NUMERIC) <=> getEXIFAperture($b, NUMERIC) ||
uc($a) cmp uc($b) } @$pics;
}
elsif ($sortby eq 'exposuretime') {
@$pics = sort { getEXIFExposureTime($a, NUMERIC) <=> getEXIFExposureTime($b, NUMERIC) ||
uc($a) cmp uc($b) } @$pics;
}
elsif ($sortby eq 'model') {
@$pics = sort { uc(getEXIFModel($a)) cmp uc(getEXIFModel($b)) ||
uc($a) cmp uc($b) } @$pics;
}
elsif ($sortby eq 'artist') {
@$pics = sort { uc(getEXIFArtist($a)) cmp uc(getEXIFArtist($b)) ||
uc($a) cmp uc($b) } @$pics;
}
elsif ($sortby eq 'size') {
#@$pics = sort { getFileSize($a, NO_FORMAT) <=> getFileSize($b, NO_FORMAT) ||
#uc($b) cmp uc($a) } @$pics;
@$pics = sort { $searchDB{$b}{SIZE} <=> $searchDB{$a}{SIZE} ||
uc($a) cmp uc($b) } @$pics;
}
elsif ($sortby eq 'pixel') {
@$pics = sort { getPixels($a) <=> getPixels($b) ||
uc($b) cmp uc($a) } @$pics;
}
elsif ($sortby eq 'bitpix') {
@$pics = sort { getBitPix($a) <=> getBitPix($b) ||
uc($b) cmp uc($a) } @$pics;
}
elsif ($sortby eq 'urgency') {
@$pics = sort { getIPTCurgencyDB($a) <=> getIPTCurgencyDB($b) ||
uc($a) cmp uc($b) } @$pics;
}
elsif ($sortby eq 'popularity') {
@$pics = sort { $searchDB{$b}{POP} <=> $searchDB{$a}{POP} ||
uc($a) cmp uc($b) } @$pics;
}
elsif ($sortby eq 'flag') {
@$pics = sort { getFlag($b) <=> getFlag($a) ||
uc($a) cmp uc($b) } @$pics;
}
elsif ($sortby eq 'byline') {
@$pics = sort { uc(getIPTCByLine($a)) cmp uc(getIPTCByLine($b)) ||
uc($a) cmp uc($b) } @$pics;
}
elsif ($sortby eq 'random') {
fisher_yates_shuffle($pics);
#@$pics = @$pics;
}
else {
my $sort = 'undefined!';
$sort = $sortby if (defined $sortby);
warn "sortPics: error: wrong sort: $sort - sorting by name";
@$pics = sort { uc($a) cmp uc($b); } @$pics;
}
clearQuickSortHashes(); # free mem
$quickSortSwitch = 0; # stop quick search
if ($sortreverse and ($sortby ne 'random')) {
@$pics = reverse @$pics;
}
}
##############################################################
# get FLAG info from database, retun 0 if no flag is set
##############################################################
sub getFlag {
my $dpic = shift;
my $flag = 0;
$flag = $searchDB{$dpic}{FLAG} if (defined $searchDB{$dpic}{FLAG});
return $flag;
}
##############################################################
# clearQuickSortHashes - reset all sort hashes
##############################################################
sub clearQuickSortHashes {
undef %quickSortHash;
undef %quickSortHashSize;
undef %quickSortHashPixel;
undef %quickSortHashBitsPixel;
}
##############################################################
# getFileDate - parameter: file (with absolute path)
# format
##############################################################
sub getFileDate {
my $dpic = shift;
my $format = shift; # FORMAT = the date is returned in this date format (dd.mm.yyyy hh:mm:ss); NO_FORMAT
return $quickSortHash{$dpic} if ($quickSortSwitch and defined $quickSortHash{$dpic});
unless (-f $dpic) {
warn "$dpic is no file!" if $verbose;
return 0;
}
my $filedate = (lstat $dpic)[9]; # 9 is the modify time
$filedate = getDateTimeDINString($filedate) if ((defined $format) and ($format == FORMAT));
$quickSortHash{$dpic} = $filedate if $quickSortSwitch;
return $filedate;
}
##############################################################
# getEXIFDate - parameter: file (with absolute path)
# image info (optional)
# returns yyyy:mm:dd hh:mm:ss
##############################################################
sub getEXIFDate {
my $dpic = shift;
my $er = shift; # optional, the EXIF hash ref if available
return '' unless (is_a_JPEG($dpic));
return $quickSortHash{$dpic} if ($quickSortSwitch and defined $quickSortHash{$dpic});
if (!defined($er)) {
my $meta = getMetaData($dpic, 'APP1$', 'FASTREADONLY') ;
$er = $meta->get_Exif_data('ALL', 'TEXTUAL');
if (!defined($er)) {
warn "$dpic has no exif info" if $verbose;
return '';
}
}
my $date = [];
my $datestr = '';
if (defined $er->{'SUBIFD_DATA'}->{DateTimeOriginal}) {
$datestr = ${$er->{'SUBIFD_DATA'}->{DateTimeOriginal}}[0];
}
elsif (defined $er->{'SUBIFD_DATA'}->{DateTimeDigitized}) {
$datestr = ${$er->{'SUBIFD_DATA'}->{DateTimeDigitized}}[0];
}
elsif (defined $er->{'IFD0_DATA'}->{DateTime}) {
$datestr = ${$er->{'IFD0_DATA'}->{DateTime}}[0];
}
else {
}
$datestr =~ tr/\000/ /; # remove null termination (\000) chars
$datestr =~ s/( )*$//g; # remove trailing space
printf "getEXIFDate: -%s- (%s)\n", $datestr, basename($dpic) if $verbose;
$quickSortHash{$dpic} = $datestr if $quickSortSwitch;
return $datestr;
}
##############################################################
# getEXIFModel - parameter: file (with absolute path)
# image info (optional)
##############################################################
sub getEXIFModel {
my $dpic = shift;
my $er = shift; # optional, the EXIF hash ref if available
return $quickSortHash{$dpic} if ($quickSortSwitch and defined $quickSortHash{$dpic});
unless (defined($er)) {
my $meta = getMetaData($dpic, 'APP1$', 'FASTREADONLY') ;
if (defined $meta) {
$er = $meta->get_Exif_data('ALL', "TEXTUAL");
if (! defined $er) {
warn "$dpic has no exif info";
return;
}
}
else {
warn "$dpic has no meta data" unless (defined $er);
return;
}
}
my $maker = '';
if (defined $er->{'IFD0_DATA'}->{'Make'}) {
$maker = ${$er->{'IFD0_DATA'}->{'Make'}}[0];
$maker =~ s/( co\.,ltd)//i; # some companies are a little to verbose here,
$maker =~ s/( co\., ltd\.)//i;
$maker =~ s/( optical)//i; # so we try to short some words
$maker =~ s/( electric)//i;
$maker =~ s/(\.)//i;
$maker =~ s/( corporation)//i;
$maker =~ s/(eastman kodak company)/KODAK/i;
$maker =~ s/(hewlett-packard company)/Hewlett-Packard/i;
$maker =~ s/(konica)/Konica/i;
$maker =~ s/(pentax)/Pentax/i;
$maker =~ s/(nikon)/Nikon/i;
}
my $model = '';
if (defined $er->{'IFD0_DATA'}->{'Model'}) {
$model = ${$er->{'IFD0_DATA'}->{'Model'}}[0];
$model =~ s/(digital camera )//i; # uh, really! :) - ok it could also be a scanner ...
$model =~ s/(digital camera)//i; # sometimes with trailing space, sometimes not ...
$model =~ s/(digital science )//i; # this is really to verbose ...
$model =~ s/(digital science)//i; # sometimes with trailing space, sometimes not ...
$model =~ s/( digital)//i; #
$model =~ s/(kodak )//i; # hello! we already had this in the Make field ...
$model =~ s/(canon )//i;
$model =~ s/(konica )//i;
$model =~ s/(pentax )//i;
$model =~ s/(nikon )//i;
$model =~ s/(sigma )//i;
$model =~ s/(HP )//;
}
# store result for quick access
$quickSortHash{$dpic} = "$maker $model" if $quickSortSwitch;
return if ($maker eq '' and $model eq ''); # return undef
return "$maker $model";
}
##############################################################
# getEXIFArtist - parameter: file (with absolute path)
# image info (optional)
##############################################################
sub getEXIFArtist {
my $dpic = shift;
my $er = shift; # optional, the EXIF hash ref if available
return $quickSortHash{$dpic} if ($quickSortSwitch and defined $quickSortHash{$dpic});
unless (defined($er)) {
my $meta = getMetaData($dpic, 'APP1$', 'FASTREADONLY') ;
$er = $meta->get_Exif_data('ALL', "TEXTUAL");
warn "$dpic has no exif info" unless (defined $er);
}
my $artist = '';
if (defined $er->{'IFD0_DATA'}->{Artist}) {
$artist = ${$er->{'IFD0_DATA'}->{Artist}}[0];
}
$quickSortHash{$dpic} = $artist if $quickSortSwitch;
print "Artist: $artist pic:$dpic\n" if $verbose;
return $artist;
}
##############################################################
# getEXIFAperture - parameter: file (with absolute path)
# format (boolean)
# image info (optional)
##############################################################
sub getEXIFAperture {
my $dpic = shift;
my $format = shift; # NUMERIC or STRING
my $er = shift; # optional, the EXIF hash ref if available
return $quickSortHash{$dpic} if ($quickSortSwitch and defined $quickSortHash{$dpic});
unless (defined($er)) {
my $meta = getMetaData($dpic, 'APP1$', 'FASTREADONLY') ;
$er = $meta->get_Exif_data('ALL', "TEXTUAL") if (defined $meta);
warn "$dpic has no exif info" unless (defined $er);
}
# FNumber: The actual F-number (F-stop) of lens when the image was taken.
my $aperture = 0;
if (defined $er->{'SUBIFD_DATA'}->{FNumber}) {
$aperture = calc($er->{'SUBIFD_DATA'}->{FNumber});
}
elsif (defined $er->{'SUBIFD_DATA'}->{ApertureValue}) {
$aperture = calc($er->{'SUBIFD_DATA'}->{ApertureValue});
}
else { }
$aperture = sprintf("F%02.1f ", $aperture) if (($format == STRING) and ($aperture != 0));
$quickSortHash{$dpic} = $aperture if $quickSortSwitch;
return $aperture;
}
##############################################################
# getEXIFExposureTime - parameter: file (with absolute path)
# format (boolean)
# image info (optional)
##############################################################
sub getEXIFExposureTime {
my $dpic = shift;
my $format = shift; # STRING -> return a string ("1/20s "), NUMERIC -> return a value (0,05)
my $er = shift; # optional, EXIF hash ref
my $exti = ''; # exposure time as string
my $extiN = 0; # exposure time as number
return $quickSortHash{$dpic} if ($quickSortSwitch and defined $quickSortHash{$dpic});
unless (defined($er)) {
my $meta = getMetaData($dpic, 'APP1$', 'FASTREADONLY') ;
$er = $meta->get_Exif_data('ALL', "TEXTUAL");
if ($verbose) { warn "$dpic has no exif info" unless (defined $er); }
}
if (defined $er->{'SUBIFD_DATA'}->{'ExposureTime'}) {
my $time = $er->{'SUBIFD_DATA'}->{'ExposureTime'};
warn "getEXIFExposureTime: not enough numbers!" if (@{$time} < 2);
# this should not happen
if ($$time[1] == 0) {
warn "error ".basename($dpic)." wrong EXIF exposure time t0:$$time[0] t1:$$time[1]";
$format == STRING ? return '' : return 0;
}
if (($$time[0]/$$time[1]) >= 1) { # handle long time exposure (e.g. 800/100)
$exti = sprintf "%.2f",($$time[0]/$$time[1]);
$extiN = $exti;
}
else { # handle everything faster than one second
if ($$time[0] != 1) { # some cameras use the format 10/600
if ($$time[0] == 0) {
print "error ".basename($dpic)." div by zero exti:$exti t0: $$time[0] t1:$$time[1]\n" if $verbose;
$exti = "1/$$time[1]?";
$extiN = 0;
}
else {
$exti = "1/".int($$time[1]/$$time[0]); # instead of 1/60 so we have to normalize this
$extiN = 1/int($$time[1]/$$time[0]);
}
}
else {
$exti = "1/".$$time[1];
$extiN = 1/$$time[1];
}
}
}
elsif (defined $er->{'SUBIFD_DATA'}->{'ShutterSpeedValue'}) {
my $time = $er->{'SUBIFD_DATA'}->{'ShutterSpeedValue'};
$exti = ($$time[0]/$$time[1]);
$exti = int(2**$exti);
$extiN = 1/$exti;
$exti = "1/".$exti;
}
else {
$exti = '';
$extiN = 0;
}
my $rc = 0;
if ($format == STRING) {
if ($exti eq '') {
$rc = '';
} else {
$rc = $exti."s "; # add the time unit (s = second)
}
} else { #$format == NUMERIC
$rc = $extiN;
}
$quickSortHash{$dpic} = $rc if $quickSortSwitch;
return $rc;
}
##############################################################
# getFiles - returns the filelist of the given dir
##############################################################
sub getFiles {
my $dir = shift;
print " getFiles: in $dir\n" if $verbose;
my @fileDirList = readDir($dir);
my @fileList;
foreach (@fileDirList) {
# put only files which are not empty into the filelist
push @fileList, $_ if ((-f "$dir/$_") and (!-z "$dir/$_"));
}
return @fileList;
}
##############################################################
# getDirs - returns the sorted dir list of the given dir
##############################################################
sub getDirs {
my $dir = shift;
my @fileDirList = readDir($dir);
my @dirList;
foreach (@fileDirList) {
next if (($_ eq '.') or ($_ eq '..'));
my $item = Encode::encode('iso-8859-1', "$dir/$_");
#my $d2 = Encode::encode('iso-8859-1', $d);
#print "getDirs: encoded: $item";
#if (-d $item) { print " is a dir\n"; }
#else { print " is not a dir\n"; }
push @dirList, $item if (-d $item);
}
@dirList = sort { uc($a) cmp uc($b) } @dirList;
return @dirList;
}
##############################################################
# getDirsRecursive - returns all subdirs of the given dir
# $dir is also included in list
# mapivi and gimp subdirs are skipped
# dirs starting with "." are skipped
##############################################################
sub getDirsRecursive {
my $dir = shift;
my @dirs;
find(sub {
if (-d and ($_ !~ m|^\.|) and ($_ ne $thumbdirname) and ($_ ne $exifdirname)) {
push @dirs, $File::Find::name;
}
}, $dir);
return @dirs;
}
##############################################################
# readDir - reads the contents of the given directory
##############################################################
sub readDir {
my $dir = shift;
$dir = Encode::encode('iso-8859-1', $dir);
if (! -d $dir) {
warn "readDir: $dir is no dir!: $!" unless (($dir =~ m/.*$thumbdirname$/));
return 0;
}
my @fileDirList;
# open the directory
if (!opendir ACTDIR, $dir) {
warn "Can't open folder $dir: $!";
return 0;
}
# show no files starting with a '.', but '..'
@fileDirList = grep /^(\.\.)|^[^\.]+.*$/, readdir ACTDIR;
closedir ACTDIR;
return @fileDirList;
}
##############################################################
# quitMain
##############################################################
sub quitMain {
log_it(lang('Saving for exit').' ...');
$top->update();
my $ok = saveAllConfig();
return 0 if (not $ok);
diff_database_statistic() if $conf{show_statistic}{value};
freeMem();
exit;
}
##############################################################
# freeMem
##############################################################
sub freeMem {
# clean up all photo objects
log_it("free mem ...");
foreach ($top->imageNames) {
if (defined $_) {
print "cleaning up: $_\n" if $verbose;
$_->delete;
}
else {
warn "image $_ is not defined!";
}
}
log_it("exit ...");
}
##############################################################
# saveAllConfig
##############################################################
sub saveAllConfig {
# check if the light table window is still open and ask to save it.
if (Exists($ltw)) {
my $ok = light_table_close();
return 0 if (not $ok);
}
log_it("saving configuration ...");
$config{Geometry} = $top->geometry;
saveAdjusterPos();
$config{LastDir} = $actdir if (-d $actdir);
$config{ActPic} = $actpic;
# we don't want to start in full screen mode
# so if we've been in fullscreen mode, we save the settings from before the fullscreen switch
if ((defined $top->{my_fullscreen_flag}) and ($top->{my_fullscreen_flag} == 1)) {
print "saveAllConfig called in full screen mode\n" if $verbose;
$config{Geometry} = $top->{my_last_geometry};
}
else { print "saveAllConfig called in normal screen mode\n" if $verbose; }
log_it("saving options to $configFile ...");
# old config
saveConfig($configFile, \%config);
# new config
my ($ok, $err) = configuration_store($conf_file, \%conf);
if (not $ok) {
log_it($err);
warn $err;
}
if ($config{SaveDatabase}) {
log_it("saving search database ...");
nstore(\%searchDB, $searchDBfile) or warn "could not store searchDB in file $user_data_path/SearchDataBase: $!";
}
log_it("saving dir folder hotlist ...");
nstore(\%dirHotlist, "$user_data_path/hotlist") or warn "could not store $user_data_path/hotlist: $!";
my $datetime = getDateTimeShortString(time());
# save a copy of the old hash in the trash # todo: remove very old backups
log_it("saving dir check list ...");
mycopy("$user_data_path/dirProperties", "$trashdir/dirProperties-$datetime", OVERWRITE) if (-f "$user_data_path/dirProperties");
nstore(\%dirProperties, "$user_data_path/dirProperties") or warn "could not store $user_data_path/dirProperties: $!";
nstore(\%ignore_keywords, "$user_data_path/keywords_ignore") or warn "could not store $user_data_path/keywords_ignore: $!";
nstore(\%hot_keywords, "$user_data_path/keywords_hot") or warn "could not store $user_data_path/keywords_hot: $!";
save_slideshows();
if (MatchEntryAvail) {
log_it("saving entry values ...");
nstore(\%entryHistory, $file_Entry_values) or warn "could not store $file_Entry_values: $!";
}
# save the mode of the trees (opened, closed branches)
if ($nav_F->{key_frame}) {
saveTreeMode($nav_F->{key_frame}->{tree});
if (defined $nav_F->{key_frame}->{tree}->{m_mode}) {
nstore($nav_F->{key_frame}->{tree}->{m_mode}, "$user_data_path/keywordMode") or warn "could not store $user_data_path/keywordMode: $!";
}
}
log_it("saving categories ...");
saveArrayToFile("$user_data_path/categories", \@precats);
log_it("saving keywords ...");
saveArrayToFile("$user_data_path/keywords", \@prekeys);
log_it(lang('Ready!'));
return 1;
}
##############################################################
# persist slideshows hash to a file
##############################################################
sub save_slideshows {
#nstore(\%slideshows, "$user_data_path/slideshows") or warn "could not store $user_data_path/slideshows: $!";
my $ok;
my $result = eval { nstore( \%slideshows, $collectionsFile ) };
if( $@ )
{ $ok = 0; warn "Serious error from Storable: $@"; }
elsif( not defined $result )
{ $ok = 0; warn "I/O error from Storable: $!"; }
else { $ok = 1; }
return $ok;
}
##############################################################
# getComment - returns a string containing all Comments
# (if available) of the given pic (up to 64K per
# block, nr of blocks is not limited, so this can
# get pretty huge!)
##############################################################
sub getComment {
my $dpic = shift;
my $format = shift; # LONG or SHORT
my $meta = shift; # optional, the Image::MetaData::JPEG object of $dpic if available
return '' unless is_a_JPEG($dpic); # todo support GIF and PNG comments
my @comments = getComments($dpic, $meta);
return '' if (@comments <= 0);
my $comment = '';
# put the comments togehter, adding a newline after each comment
foreach (@comments) {
$comment .= "$_\n";
}
$comment =~ s/\r*//g; # remove \r (carriage return)
$comment =~ s/\n+$//; # cut off last newline(s)
$comment = formatString($comment, $config{LineLength}, $config{LineLimit}) if ($format == SHORT);
print "getComment: $comment $dpic\n" if $verbose;
return $comment;
}
##############################################################
# getComments - returns an array containing all Comments
# (if available) of the given pic (up to 64K per
# block, nr of blocks is not limited, so this can
# get pretty huge!)
##############################################################
sub getComments {
my $dpic = shift;
my $meta = shift; # optional, the Image::MetaData::JPEG object of $dpic if available
$meta = getMetaData($dpic, "COM", 'FASTREADONLY') unless (defined($meta));
my @coms = ();
if ($meta) {
@coms = $meta->get_comments();
#print "getComments: $dpic:\n"; foreach (@coms) { print " com: $_\n"; } print "\n";
#foreach (@coms) {
# if (Encode::is_utf8($_)) {
# $_ = decode("utf8", $_);
# #print "getComments: decoded UTF8: $_\n";
# }
#}
}
else {
warn "*** getComments: no meta for $dpic available!" if ($verbose);
}
#foreach (@coms) { print "getComments: $_\n"; }
return @coms;
}
##############################################################
# getShortEXIF - returns a string containing some of the
# EXIF-Data (if available) of the given pic
# if wrap is true the string is broken in
# several lines (for thumbnail view)
##############################################################
sub getShortEXIF {
my $dpic = shift;
my $wrap = shift; # WRAP or NO_WRAP
my $meta = shift; # optional
my $exif = '';
return $exif unless is_a_JPEG($dpic);
$meta = getMetaData($dpic, 'APP1$', 'FASTREADONLY') unless (defined($meta));
# add a symbol ([s]) to the exif column for each picture with saved EXIF data
$exif .= '[s] ' if (-f dirname($dpic)."/$exifdirname/".basename($dpic)) ;
return unless (defined($meta));
my $er = $meta->get_Exif_data('ALL', 'TEXTUAL'); # er = exif hash ref todo: use IMAGE_DATA instead of ALL?
return $exif unless (defined $er);
# Some cameras store settings in Maker Notes, so it is important to know the maker of the camera.
my $make = '';
$make = ${$er->{IFD0_DATA}->{Make}}[0] if (defined $er->{IFD0_DATA}->{Make});
# check for thumbnail add a [t] if there is one
$exif .= '[t] ' if (defined $er->{ROOT_DATA}->{ThumbnailData});
my $datestr = '';
$datestr = getEXIFDate($dpic, $er);
if ($datestr ne '') {
if (my ($y, $M, $d, $h, $m, $s) = $datestr =~ m/(\d\d\d\d):(\d\d):(\d\d) (\d\d):(\d\d):(\d\d)/) {
#$exif .= "$d.$M.$y $h:$m:$s "; # german date format
#$exif .= "$M/$d/$y $h:$m:$s "; # american date format
$exif .= "$y-$M-$d $h:$m:$s "; # ISO 8601 date format
$exif .= "\n" if ($wrap and $exif ne '');
}
else {
warn "picture has an unusual EXIF date: \"$datestr\" ($dpic)\n" if $config{MetadataWarn};
}
}
if (defined $er->{SUBIFD_DATA}->{FocalLength}) {
my $flength = int(calc($er->{SUBIFD_DATA}->{FocalLength}));
$exif .= $flength."mm ";
}
if (defined $er->{SUBIFD_DATA}->{FocalLengthIn35mmFilm}) {
$exif .= "(".join('', @{$er->{SUBIFD_DATA}->{FocalLengthIn35mmFilm}})."mm) ";
}
my $aperture = getEXIFAperture($dpic, STRING, $er);
$exif .= $aperture if ($aperture ne '0');
$exif .= getEXIFExposureTime($dpic, STRING, $er);
if (defined $er->{SUBIFD_DATA}->{ExposureBiasValue}) {
my $bias = calc($er->{SUBIFD_DATA}->{ExposureBiasValue});
if (($bias eq '-') and $config{MetadataWarn}) {
warn "unusal EXIF ExposureBiasValue (".$er->{SUBIFD_DATA}->{ExposureBiasValue}.") in picture $dpic\n";
}
$exif .= sprintf("+%1.1f ", $bias) if (($bias ne '-') and ($bias > 0));
$exif .= sprintf( "%1.1f ", $bias) if (($bias ne '-') and ($bias < 0));
}
my $iso = get_ISO_value($dpic, $er, $meta, $make);
$exif .= "ISO$iso " if ($iso ne '');
$exif .= "\n" if ($wrap and $exif ne '');
my $exposureStr = get_EXIF_exposure($er, $meta, $make);
$exif .= $exposureStr.' ' if ($exposureStr ne '');
if (defined $er->{SUBIFD_DATA}->{Flash}) {
if (${$er->{SUBIFD_DATA}->{Flash}}[0] & 1) {
$exif .= 'flash ';
}
}
if ($conf{exif_plus}{value}) { # show contrast sharpness saturation metering white balance lens
my $exifplus = get_EXIF_plus($dpic);
$exifplus = formatString($exifplus, 80, -1) if ($wrap);
$exif .= $exifplus if ($exifplus ne '');
}
my $exmod = getEXIFModel($dpic, $er);
$exif .= "\n$exmod" if (defined $exmod);
my ($lat, $lon, $latRef, $lonRef) = gps_get($dpic);
if (defined $lat and defined $lon) {
$latRef = '?' if (!defined $latRef);
$lonRef = '?' if (!defined $lonRef);
# %.1s truncates string, while %1s does not
$exif .= sprintf(" GPS: %.4f%.1s %.4f%.1s",$lat, $latRef, $lon, $lonRef);
}
$exif =~ tr/\000/ /; # remove null termination (\000) chars
$exif =~ s/( )+/ /g; # replace more than one space with one space
my $tmp = $exif;
$tmp =~ s/\n//g; # remove newlines
$tmp =~ s/\s//g; # remove whitespaces
# if there are just newlines and spaces we return an empty string
$exif = '' if ($tmp eq '');
return $exif;
}
##############################################################
# geMicroEXIF - returns a string containing only the most
# relevant EXIF-Data
##############################################################
sub getMicroEXIF {
my $dpic = shift;
my $meta = shift; # optional
my $exif = '';
return $exif unless is_a_JPEG($dpic);
$meta = getMetaData($dpic, 'APP1$', 'FASTREADONLY') unless (defined($meta));
return unless (defined($meta));
my $er = $meta->get_Exif_data('ALL', 'TEXTUAL'); # er = exif hash ref todo: use IMAGE_DATA instead of ALL?
return $exif unless (defined $er);
# Some cameras store settings in Maker Notes, so it is important to know the maker of the camera.
my $make = '';
$make = ${$er->{IFD0_DATA}->{Make}}[0] if (defined $er->{IFD0_DATA}->{Make});
my $datestr = '';
$datestr = getEXIFDate($dpic, $er);
if ($datestr ne '') {
if (my ($y, $M, $d, $h, $m, $s) = $datestr =~ m/(\d\d\d\d):(\d\d):(\d\d) (\d\d):(\d\d):(\d\d)/) {
$exif .= "$y-$M-$d $h:$m:$s "; # ISO 8601 date format
}
else {
warn "picture has an unusual EXIF date: \"$datestr\" ($dpic)\n" if $config{MetadataWarn};
}
}
if (defined $er->{SUBIFD_DATA}->{FocalLength}) {
my $flength = int(calc($er->{SUBIFD_DATA}->{FocalLength}));
$exif .= $flength."mm ";
}
my $aperture = getEXIFAperture($dpic, STRING, $er);
$exif .= $aperture if ($aperture ne '0');
$exif .= getEXIFExposureTime($dpic, STRING, $er);
if (defined $er->{SUBIFD_DATA}->{ExposureBiasValue}) {
my $bias = calc($er->{SUBIFD_DATA}->{ExposureBiasValue});
if (($bias eq '-') and $config{MetadataWarn}) {
warn "unusal EXIF ExposureBiasValue (".$er->{SUBIFD_DATA}->{ExposureBiasValue}.") in picture $dpic\n";
}
$exif .= sprintf("+%1.1f ", $bias) if (($bias ne '-') and ($bias > 0));
$exif .= sprintf( "%1.1f ", $bias) if (($bias ne '-') and ($bias < 0));
}
my $iso = get_ISO_value($dpic, $er, $meta, $make);
$exif .= "ISO$iso " if ($iso ne '');
my $exposureStr = get_EXIF_exposure($er, $meta, $make);
$exif .= $exposureStr.' ' if ($exposureStr ne '');
my $exmod = getEXIFModel($dpic, $er);
$exif .= "$exmod" if (defined $exmod);
$exif =~ tr/\000/ /; # remove null termination (\000) chars
$exif =~ s/( )+/ /g; # replace more than one space with one space
my $tmp = $exif;
$tmp =~ s/\n//g; # remove newlines
$tmp =~ s/\s//g; # remove whitespaces
# if there are just newlines and spaces we return an empty string
$exif = '' if ($tmp eq '');
return $exif;
}
##############################################################
##############################################################
sub get_EXIF_exposure {
my ($er, $meta, $make) = @_;
my $exposureStr = '';
# Canon places specific exposure program in maker note.
if ($make =~ m/Canon/) {
my $seg = $meta->retrieve_app1_Exif_segment();
if ($seg) {
my $makernote = $seg->get_Exif_data('MAKERNOTE_DATA', 'TEXTUAL');
if (exists $makernote->{CameraSettings}) {
my %CanonExp = (
0 => 'Easy shooting',
1 => 'Program',
2 => 'Shutter priority',
3 => 'Aperture priority',
4 => 'Manual',
5 => 'Auto-DEP',
6 => 'DEP'
);
my %CanonEasy = (
0 => 'Auto',
1 => 'Manual',
2 => 'Landscape',
3 => 'Fast shutter',
4 => 'Slow shutter',
5 => 'Night',
6 => 'B/W',
7 => 'Sepia',
8 => 'Portrait',
9 => 'Sports',
10 => 'Macro/Close-Up',
11 => 'Pan focus'
);
my $exp = $makernote->{CameraSettings}[20];
if (defined $exp) {
$exposureStr = $CanonExp{$exp} if (defined $CanonExp{$exp});
if ($exp == 0) { # Find more specific "Easy shooting" mode
$exp = $makernote->{CameraSettings}[11];
$exposureStr = '\$' . $exp;
$exposureStr = $CanonEasy{$exp} if (defined $CanonEasy{$exp});
}
}
}
}
}
# if its no Canon we look in the ExposureProgram tag
if (($exposureStr eq '') and (defined $er->{SUBIFD_DATA}->{ExposureProgram})) {
my @ExposureProgram = ('Not defined',
'Manual',
'Program',
'Aperture priority',
'Shutter priority',
'Creative program',
'Action program',
'Portrait mode',
'Landscape mode');
my $prog = ${$er->{SUBIFD_DATA}->{ExposureProgram}}[0];
$exposureStr = $ExposureProgram[$prog] if ($prog > 0);
}
# if there is also nothing defined, we take the ExposureMode tag
if ($exposureStr eq '') {
# some camera uses this tag instead of ExposureProgram
if (defined $er->{SUBIFD_DATA}->{ExposureMode}) {
my @ExposureMode = ('Auto exposure',
'Manual exposure',
'Auto bracket');
my $mode = ${$er->{SUBIFD_DATA}->{ExposureMode}}[0];
$exposureStr = $ExposureMode[$mode] if ($mode >= 0);
}
}
return $exposureStr;
}
##############################################################
# returns additional EXIF information using exiftool: contrast,
# sharpness, saturation, metering, white balance, Metering,
# focus dist, DOF, ...
##############################################################
sub get_EXIF_plus {
my ($dpic) = shift;
my $exifplus = '';
#if ($verbose and (defined $er->{SUBIFD_DATA}->{OwnerName})) { print "*** Owner $dpic: ".join('', @{$er->{'SUBIFD_DATA'}->{'OwnerName'}})."\n"; }
#if ($verbose and (defined $er->{SUBIFD_DATA}->{UserComment})) { print "*** EXIF comment $dpic: -".join('', @{$er->{'SUBIFD_DATA'}->{'UserComment'}})."-\n"; }
# what to get and in which order
my @items = qw(MeteringMode WhiteBalance Contrast Sharpness Saturation ColorSpace FocusDistance DOF LensID ShutterCount);
# how to label
my %itemlabel = ( # labels to display
'MeteringMode' => 'Metering:',
'WhiteBalance' => 'WB:',
'Sharpness' => 'Sharp:',
'Contrast' => 'Contrast:',
'Saturation' => 'Sat:',
'FocusDistance' => 'Dist:',
'DOF' => 'DOF:',
'ShutterCount' => '#', );
my $exifTool = new Image::ExifTool;
my $info = $exifTool->ImageInfo($dpic, '*:*');
foreach my $item (@items) {
if (defined $$info{$item}) {
if (defined $itemlabel{$item}) { $exifplus .= $itemlabel{$item}; }
$exifplus .= $$info{$item}." ";
}
}
return $exifplus;
}
##############################################################
##############################################################
sub get_ISO_value {
my ($dpic, $er, $meta, $make) = @_;
my $iso = '';
if (defined $er->{SUBIFD_DATA}->{ISOSpeedRatings}) {
$iso = ${$er->{SUBIFD_DATA}->{ISOSpeedRatings}}[0];
}
else { # Same as ISOSpeedRatings. Only Kodak's camera uses this tag instead of ISOSpeedRating
if (defined $er->{SUBIFD_DATA}->{ExposureIndex}) {
$iso = calc($er->{SUBIFD_DATA}->{ExposureIndex});
}
else { # Nikon and Canon hide the ISO settings in the Makernotes
my $seg = $meta->retrieve_app1_Exif_segment();
if ($seg) {
my $makernote = $seg->get_Exif_data('MAKERNOTE_DATA', 'TEXTUAL');
if ($make =~ m/Canon/) {
if (exists $makernote->{CameraSettings}) {
my $iso_int = $makernote->{CameraSettings}[16];
if ($iso_int == 15) {
$iso = '-Auto';
}
elsif (16 <= $iso_int and $iso_int <= 19) {
$iso = (50 * (1 << ($iso_int - 16)));
}
}
}
elsif (exists $makernote->{ISOSetting}) {
$iso = ${$makernote->{ISOSetting}}[1];
}
}
}
}
# if nothing helps we use exiftool
if ((!defined $iso) or ($iso eq '')) {
my $exifTool = new Image::ExifTool;
my $info = $exifTool->ImageInfo($dpic, '*:ISO'); # 'Nikon:ISO'
$iso = $$info{ISO} if defined $$info{ISO};
}
# this part will repair Nikon D70 files (ISO info is just available in the Makernotes)
# by setting the ISO value in the right EXIF tag (ISOSpeedRatings)
# but Mapivi won't modify the users pictures without asking that's why this is commented out
#if (($iso_value > 1) and ($iso_value < 30000)) {
#print "adding ISO value $iso_value to $dpic\n";
## the other $meta is read only
#my $meta2= new Image::MetaData::JPEG($dpic, 'APP1$');
#my $hash = $meta2->set_Exif_data({'ISOSpeedRatings' => $iso_value}, 'IMAGE_DATA', 'ADD');
#if (%$hash) {
# print "ISO record rejected\n";
#}
#else {
# unless ($meta2->save()) {
# print "Save ISO failed for $dpic\n";
# }
#}
return $iso;
}
##############################################################
# getEXIFMeta
##############################################################
sub getEXIFMeta {
my $dpic = shift;
my $exif = '';
return $exif unless is_a_JPEG($dpic);
my $pic = basename($dpic);
my $meta = getMetaData($dpic, 'APP1$', 'FASTREADONLY');
my $hash_ref = $meta->get_Exif_data('ALL', "TEXTUAL");
#if (defined $hash_ref->{APP1}->{ThumbnailData}) {
#printf "[t] %s\n", basename($dpic);
#}
#return unless ($verbose);
my $num = $meta->retrieve_app1_Exif_segment(-1);
print "getEXIFMeta: $pic has $num EXIF APP1 segments\n" if $verbose;
my $ref = $meta->retrieve_app1_Exif_segment();
unless (defined $ref) {
print "getEXIFMeta: $pic has no EXIF APP1 segments\n" if $verbose;
return $exif;
}
while (my ($d, $h) = each %$hash_ref) {
while (my ($t, $a) = each %$h) {
my $a2 = '';
foreach (@$a) {
$_ =~ tr/ -~//cd; # remove all non-printable chars
$a2 .= sprintf "%-5s", $_;
}
$a2 = cutString($a2, 30 , '..');
$exif .= sprintf "%-25s\t%-25s\t-> %-s\n", $d, $t, $a2;
}
}
return $exif;
}
##############################################################
# calc - make a number from an array ref containing two numbers
# input e.g. [28, 10] -> output: 2.8
##############################################################
sub calc {
my $value = shift;
if (@{$value} != 2) {
warn "calc: no separator -> no values! or division by zero\n" if $config{MetadataWarn};
return join("/", $value);
}
if ($$value[1] == 0) {
if ($$value[0] == 0) {
return 0;
}
else {
warn "calc: division by zero" if $config{MetadataWarn};
return 0;
}
}
return ($$value[0] / $$value[1]); #return the calculated number
}
##############################################################
# displayEXIFData - displays all EXIF-Data in a window
##############################################################
sub displayEXIFData {
my $lb = shift;
my @sellist = $lb->info('selection');
return unless checkSelection($top, 1, 0, \@sellist, lang("picture(s)"));
return unless askSelection(\@sellist, 10, "EXIF info");
my $selected = @sellist;
log_it("displaying EXIF data of $selected pictures");
my $pw = progressWinInit($lb, "Display EXIF data");
my $i = 0;
foreach my $dpic (@sellist) {
last if progressWinCheck($pw);
$i++;
progressWinUpdate($pw, "Display EXIF data ($i/$selected) ...", $i, $selected);
# check if file is a link and get the real target
next if (!getRealFile(\$dpic));
my $title = "EXIF info of ".basename($dpic);
my $exif = "EXIF info of $dpic\n";
my $exifs = date_iso_to_relative(getShortEXIF($dpic, NO_WRAP));
$exif .= "compact EXIF info:\n$exifs\n\n" if ($exifs ne '');
$exif .= "\ndetailed EXIF info (from Image::ExifTool):\n";
$exif .= exif_get($dpic); # exif extracted by ExifTool
$exif .= "\ndetailed EXIF info (from Image::Info):\n";
my $ii = getImageInfo($dpic);
foreach (sort { uc($a) cmp uc($b); } keys %{$ii}) {
next if (($_ eq "MakerNote") or ($_ eq "ColorComponentsDecoded") or ($_ =~ m/^App.*/));
if (ref($ii->{$_}) eq "ARRAY") { # handle array entries
$exif .= sprintf "%-25s ",$_;
foreach (@{$ii->{$_}}) {
if (ref($_) eq "ARRAY") { # handle array in array entries
foreach (@{$_}) {
$exif .= "$_, ";
}
} elsif (ref($_) eq "HASH") { # handle hash in array entries
my %hash = %{$_};
foreach (sort keys %hash) {
$exif .= "$_=".$hash{$_}.", ";
}
} else { # handle normal strings in array entries
$exif .= "$_, ";
}
}
$exif =~ s/, $//; # remove trailing comma and space
}
else { # handle normal string entries
$exif .= sprintf "%-25s %s",$_, $ii->{$_};
}
$exif .= "\n";
}
if ($config{EXIFshowApp}) {
foreach (sort { uc($a) cmp uc($b); } keys %{$ii}) {
next unless (($_ eq "MakerNote") or ($_ eq "ColorComponentsDecoded") or ($_ =~ m/^App.*/));
if (ref($ii->{$_}) eq "ARRAY") { # handle array entries
$exif .= sprintf "%-25s ",$_;
foreach (@{$ii->{$_}}) {
if (ref($_) eq "ARRAY") { # handle array in array entries
foreach (@{$_}) {
$exif .= "$_, ";
}
} elsif (ref($_) eq "HASH") { # handle hash in array entries
my %hash = %{$_};
foreach (sort keys %hash) {
$exif .= "$_=".$hash{$_}.", ";
}
} else { # handle normal strings in array entries
$exif .= "$_, ";
}
}
$exif =~ s/, $//; # remove trailing comma and space
} else { # handle normal string entries
my $part = sprintf "%-25s %s",$_, $ii->{$_};
$part =~ s/\n//g;
$exif .= $part;
}
$exif .= "\n";
}
}
$exif .= "\ndetailed EXIF info (from Image::MetaData::JPEG):\n";
$exif .= getEXIFMeta($dpic);
$exif =~ tr/\n -~//cd; # remove non-printable characters (but not \n)
showText($title, $exif, NO_WAIT, getThumbFileName($dpic));
}
progressWinEnd($pw);
log_it("ready! ($i of $selected displayed)");
}
##############################################################
# date_iso_to_relative
# input: any strings (also multiline strings with newline)
# output: same string, but contained iso date string (format: yyyy-mm-dd)
# is replaced with relative date string (e.g. "today" or "yesterday")
# if found and applicable
##############################################################
sub date_iso_to_relative {
my $string = shift;
return $string if (not defined $string);
# $1 = pre string
# $2 = years
# $3 = months
# $4 = days
# $5 = post string
# regex modifier /s = treat newline like any char (.)
if ($string =~m/(.*)(\d\d\d\d)-(\d\d)-(\d\d)(.*)/s) {
my $relative = undef;
#print "date_iso_to_relative: found ISO date $4.$3.$2 \n";
# todo: make a sub from the next 3 statements, it is used quite often in mapivi
my (undef,undef,undef,$d,$m,$y) = getDateTime(time());
if ($y == $2 and $m == $3 and $d == $4) {
$relative = 'today';
}
else {
# get yesterdays date
my ($ny,$nm,$nd) = date_relative($y,$m,$d,-1);
if ($ny == $2 and $nm == $3 and $nd == $4) {
$relative = 'yesterday';
}
}
if (defined $relative) {
$string = $1.$relative.$5;
}
}
return $string;
}
##############################################################
# adds or subtracts $relative_days from given date and returns new date
##############################################################
sub date_relative {
my ($y,$m,$d,$relative_days) = @_;
my $ctime = timelocal(12,12,12,$d,($m-1),$y);
my $seconds = 24 * $relative_days * 60 * 60;
my (undef,undef,undef,$nd,$nm,$ny) = getDateTime($ctime + $seconds);
#print "date_relative $y-$m-$d -> $ny-$nm-$nd\n";
return ($ny,$nm,$nd);
}
##############################################################
# removeEXIFData - remove all EXIF data in all selected pictures
##############################################################
sub removeEXIFData {
my $mode = shift; # 'all' or 'thumb'
if (!defined $mode) {
warn "removeEXIFData: Missing a mode, should be \"thumb\" or \"all\"!";
return;
}
my @sellist = $picLB->info('selection');
return unless checkSelection($top, 1, 0, \@sellist, lang("picture(s)"));
my $selected = @sellist;
my $text;
if ($mode eq 'all') {
$text = "Remove all EXIF infos (picture and camera data and embedded thumbnail picture) of $selected selected pictures.";
}
elsif ($mode eq 'thumb') {
$text = "Remove the embedded EXIF thumbnails and other non-camera settings from the EXIF headers of $selected selected pictures.";
}
else {
warn "removeEXIFData: Wrong mode ($mode), should be \"thumb\" or \"all\"!";
return;
}
my $rc = $top->messageBox(-icon => 'question',
-message => "$text\nOk to continue?",
-title => "Question",
-type => 'OKCancel');
return if ($rc !~ m/Ok/i);
log_it("removing EXIF data of $selected pictures");
my $i = 0;
my $errors = '';
my $pw = progressWinInit($top, "Remove EXIF data");
foreach my $dpic (@sellist) {
last if progressWinCheck($pw);
$i++;
progressWinUpdate($pw, "Remove EXIF data ($i/$selected) ...", $i, $selected);
# check if file is a link and get the real target
next if (!getRealFile(\$dpic));
next if (!checkWriteable($dpic));
next if (!removeEXIF($dpic, $mode, \$errors));
# touch the thumbnail pic (set actual time stamp), to suppress rebuilding the next time
touch(getThumbFileName($dpic));
updateOneRow($dpic, $picLB);
showImageInfo($dpic) if ($dpic eq $actpic);
}
progressWinEnd($pw);
log_it("ready! ($i of $selected infos removed)");
showText("Errors while removing EXIF data", $errors, NO_WAIT) if ($errors ne '');
}
##############################################################
# removeEXIF
##############################################################
sub removeEXIF {
my $dpic = shift;
my $mode = shift;
my $errors = shift; # reference
my $meta = getMetaData($dpic, "APP1");
unless ($meta) {
$$errors .= "No EXIF data in $dpic\n";
return 0;
}
if ($mode eq "all") {
$meta->remove_app1_Exif_info(-1);
} elsif ($mode eq "thumb") {
my $nothumb = '';
my $hash = $meta->set_Exif_data(\$nothumb, 'THUMBNAIL', 'REPLACE');
$$errors .= "Thumbnail record rejected for $dpic\n" if (keys %$hash);
} else {
die;
}
unless ($meta->save()) {
$$errors .= "Save failed $dpic\n";
return 0;
}
return 1;
}
##############################################################
# getEXIFThumb - extract the embedded EXIF thumbnail
##############################################################
sub getEXIFThumb {
my @sellist = $picLB->info('selection');
return unless checkSelection($top, 1, 0, \@sellist, lang("picture(s)"));
my $selected = @sellist;
my $rc = $top->messageBox(-icon => 'question',
-message => "Extract embedded EXIF thumbnails of $selected selected pictures and write them to a (new created) subfolder \"EXIFThumbs/\" in the current folder.\nShould I continue?",
-title => "Question",
-type => 'OKCancel');
return if ($rc !~ m/Ok/i);
log_it("extracting embedded EXIF thumbnails of $selected pictures");
if (!-d "$actdir/EXIFThumbs") {
if ( !mkdir "$actdir/EXIFThumbs", oct(755)) {
warn "makedir: can not create $actdir/EXIFThumbs: $!";
return;
}
}
my $i = 0;
my $errors = '';
my $pw = progressWinInit($top, "Extracting EXIF thumbnails");
foreach my $dpic (@sellist) {
last if progressWinCheck($pw);
$i++;
progressWinUpdate($pw, "Extracting EXIF thumbnail ($i/$selected) ...", $i, $selected);
my $pic = basename($dpic);
my $dthumb = "$actdir/EXIFThumbs/$pic";
next if (!getRealFile(\$dpic));
extractThumb($dpic, $dthumb, \$errors);
}
progressWinEnd($pw);
log_it("ready! ($i of $selected thumbs extracted)");
showText("Errors while saving EXIF thumbnail", $errors, NO_WAIT) if ($errors ne '');
}
##############################################################
# setEXIFDate - adjust the date and time field in the EXIF header
##############################################################
sub setEXIFDate {
my @sellist = $picLB->info('selection');
return unless checkSelection($top, 1, 0, \@sellist);
my $selected = @sellist;
my $count = 0;
if (!$config{setEXIFDateAskAgain}) {
my $rc = checkDialog("Change EXIF date/time?",
"Change the date and time info (EXIF: DateTimeOriginal) of $selected selected pictures. The previous information will be lost!\nShould I continue?",
\$config{setEXIFDateAskAgain},
"don't ask again",
'',
'OK', 'Cancel');
return if ($rc ne 'OK');
}
my $datetime = $config{EXIFDateAbs};
my $rc = setEXIFDateDialog(\$datetime);
return if ($rc ne 'OK');
if (($config{EXIFAbsRel} eq 'abs') and !($datetime =~ m/\d{4}:\d{2}:\d{2}-\d{2}:\d{2}:\d{2}/)) {
$top->messageBox(-icon => 'warning',
-message => "Sorry, but $datetime has a wrong format!\nShould be: yyyy:mm:dd-hh:mm:ss Aborting.",
-title => 'Error', -type => 'OK');
return;
}
$config{EXIFDateAbs} = $datetime if ($config{EXIFAbsRel} eq 'abs');
log_it("changing the date and time of $selected pictures");
my $i = 0;
my $errors = '';
my $pw = progressWinInit($top, "Changing EXIF date and time");
foreach my $dpic (@sellist) {
last if progressWinCheck($pw);
$i++;
progressWinUpdate($pw, "Changing EXIF date and time ($i/$selected) ...", $i, $selected);
# check if file is a link and get the real target
next if (!getRealFile(\$dpic));
next if (!checkWriteable($dpic));
if ($config{EXIFAbsRel} eq 'abs') {
# nothing to do, we just use $datetime
$datetime =~ s/-/ /; # replace just the "-" with a space between date and time
} elsif ($config{EXIFAbsRel} eq 'rel') {
my $exif = getEXIFDate($dpic);
if (defined($exif) and ($exif =~ m/(\d\d\d\d):(\d\d):(\d\d)\s(\d\d):(\d\d):(\d\d)/)) {
my $mon = $2;
my $year = $1;
$mon--;
$year -= 1900;
if ($mon >= 0 and $mon <= 11) {
# calculate the time as value in seconds since the Epoch (Midnight, January 1, 1970)
my $ctime = timelocal($6,$5,$4,$3,$mon,$year);
my $hours = $config{EXIFyears} * 365 * 24 + $config{EXIFdays} * 24 + $config{EXIFhours};
my $seconds = $hours * 60 * 60 + $config{EXIFmin} * 60 + $config{EXIFsec};
if ($config{EXIFPlusMin} eq "+") {
$ctime = $ctime + $seconds;
} else {
$ctime = $ctime - $seconds;
}
$datetime = getDateTimeEXIFString($ctime);
} else {
$errors .= "Wrong month in EXIF date in $dpic\n";
next;
}
} else {
$errors .= "No EXIF date in $dpic\n";
next;
}
} else {
warn "setEXIFDate: wrong value: ", $config{EXIFAbsRel};
return 0; # should not happen
}
print "set EXIF datetime: $datetime to $dpic\n" if $verbose;
next if (not setEXIFDatePic($dpic,$datetime,\$errors));
$count++;
# touch the thumbnail pic (set actual time stamp), to suppress rebuilding the next time
touch(getThumbFileName($dpic));
updateOneRow($dpic, $picLB);
showImageInfo($dpic) if ($dpic eq $actpic);
}
progressWinEnd($pw);
log_it("ready! ($i/$selected)");
showText("Errors while adjusting EXIF date", $errors, NO_WAIT) if ($errors ne '');
}
##############################################################
# setEXIFDatePic - set the date/time in the EXIF header for a single picture
##############################################################
sub setEXIFDatePic {
my $dpic = shift; # file to process
my $datetime = shift; # format: yyyy:mm:dd hh:mm:ss
my $errors = shift; # string ref
my $meta = getMetaData($dpic, 'APP1$');
if (not defined $meta) {
$$errors .= "No meta info available: $dpic\n";
return 0;
}
#date time format: 2007:04:04 11:12:13
my $hash = $meta->set_Exif_data({'DateTime' => $datetime,
'DateTimeOriginal' => $datetime,
'DateTimeDigitized' => $datetime}, 'IMAGE_DATA', 'ADD');
if (keys %$hash) {
$$errors .= "DateTime record rejeced: $dpic\n";
return 0;
}
unless ($meta->save()) {
$$errors .= "Save failed $dpic\n";
return 0;
}
return 1;
}
##############################################################
# setEXIFDate - set the year in the EXIF header from file name
##############################################################
sub setEXIFDate_from_file_name {
my @sellist = $picLB->info('selection');
return unless checkSelection($top, 1, 0, \@sellist, lang("picture(s)"));
my $selected = @sellist;
my $count = 0;
my $rc = $top->messageBox(-icon => 'warning', -message => "This function will extract the year from the file name and set the EXIF date to January, 1st of this year and the time to 12:00:00 in ".scalar @sellist." pictures.\nThe file name must start with the four year digits, else the picture is ignored.\nExample: The EXIF date of a picture named 2009_pic2.jpg will be set to 2009:01:01 12:00:00.\nOk to continue?",
-title => "Warning", -type => 'OKCancel');
return if ($rc !~ m/Ok/i);
if (!$config{setEXIFDateAskAgain}) {
my $rc = checkDialog("Change EXIF date/time?",
"Change the date and time info (EXIF: DateTimeOriginal) of $selected selected pictures. The previous information will be lost!\nShould I continue?",
\$config{setEXIFDateAskAgain},
"don't ask again",
'',
'OK', 'Cancel');
return if ($rc ne 'OK');
}
log_it("changing the date and time of $selected pictures");
my $i = 0;
my $errors = '';
my $pw = progressWinInit($top, "Changing EXIF date and time");
foreach my $dpic (@sellist) {
last if progressWinCheck($pw);
$i++;
progressWinUpdate($pw, "Changing EXIF date and time ($i/$selected) ...", $i, $selected);
my $pic = basename($dpic);
# check if file is a link and get the real target
next if (!getRealFile(\$dpic));
next if (!checkWriteable($dpic));
if ($pic =~ m|^(\d\d\d\d).*|) {
my $datetime = "$1:01:01 12:00:00";
print "set EXIF datetime: $datetime to $dpic\n"; # if $verbose;
next if (not setEXIFDatePic($dpic,$datetime,\$errors));
$count++;
# touch the thumbnail pic (set actual time stamp), to suppress rebuilding the next time
touch(getThumbFileName($dpic));
updateOneRow($dpic, $picLB);
showImageInfo($dpic) if ($dpic eq $actpic);
}
else {
$errors .= "$pic doesn't start with 4 digits. Skipping.\n";
}
}
progressWinEnd($pw);
log_it("ready! ($i/$selected)");
showText("Errors while adjusting EXIF date", $errors, NO_WAIT) if ($errors ne '');
}
##############################################################
# remap_abs_rel
##############################################################
sub remap_abs_rel {
my $tf = shift;
my $af = shift;
my $rf = shift;
if ($config{EXIFAbsRel} eq 'abs') {
$rf->packForget if ($rf->ismapped);
$af->pack(-in => $tf, -fill => 'both', -padx => 3, -pady => 3) unless ($af->ismapped);
}
else {
$af->packForget if ($af->ismapped);
$rf->pack(-in => $tf, -fill => 'both', -padx => 3, -pady => 3) unless ($rf->ismapped);
}
}
##############################################################
# setEXIFDateDialog - get the date/time info from the user
# returns 'OK' or 'Cancel'
##############################################################
sub setEXIFDateDialog {
my $datetime = shift; # var ref date time string (absolute)
my $rc = 'Cancel';
# open window
my $dtw = $top->Toplevel();
$dtw->title('Set EXIF date and time');
$dtw->iconimage($mapiviicon) if $mapiviicon;
$dtw->Label(-text => "You may set the date and time to an absolute or relative value")->pack(-anchor => 'w');
# frame for the absolute/relative radio buttons
my $arf = $dtw->Frame(-bd => 1, -relief => 'raised')->pack(-fill => 'both', -padx => 3, -pady => 3);
# frame for the time/date adjustment
my $tf = $dtw->Frame(-bd => 1, -relief => 'raised')->pack(-fill => 'both', -padx => 3, -pady => 3);
my $af = $tf->Frame();
my $rf = $tf->Frame();
$arf->Radiobutton(-text => "use absolute value", -variable => \$config{EXIFAbsRel}, -value => 'abs', -command => sub { remap_abs_rel($tf, $af, $rf); })->pack(-anchor => 'w', -side => 'left');
$arf->Radiobutton(-text => "use relative value", -variable => \$config{EXIFAbsRel}, -value => 'rel', -command => sub {remap_abs_rel($tf, $af, $rf); })->pack(-anchor => 'w', -side => 'left');
remap_abs_rel($tf, $af, $rf);
######### absolute
$af->Label(-text => "Please enter the new date and time to store\nin the selected pictures\n(please use the format: yyyy:mm:dd-hh:mm:ss\nexample: 2009:11:21-11:07:59)", -justify => 'left')->pack(-anchor => 'w');
my $entry = $af->Entry(-textvariable => \$$datetime,
-width => 40,
)->pack(-fill => 'x', -padx => 3, -pady => 3);
# todo that's not enough to switch when focusIn
#$entry->bind('', sub { $config{EXIFAbsRel} = 'abs'; $af->update(); } );
$entry->selectionRange(0,'end'); # select all
$entry->icursor('end');
$entry->xview('end');
######### relative
$rf->Radiobutton(-text => "+ (add time)", -variable => \$config{EXIFPlusMin}, -value => "+")->pack(-anchor => 'w');
$rf->Radiobutton(-text => "- (subtract time)", -variable => \$config{EXIFPlusMin}, -value => "-", -command => sub {$config{EXIFAbsRel} = 'rel'})->pack(-anchor => 'w');
labeledScale($rf, 'top', 8, 'years', \$config{EXIFyears}, 0, 100, 1);
labeledScale($rf, 'top', 8, 'days', \$config{EXIFdays}, 0, 365, 1);
labeledScale($rf, 'top', 8, 'hours', \$config{EXIFhours}, 0, 24, 1);
labeledScale($rf, 'top', 8, 'minutes', \$config{EXIFmin}, 0, 59, 1);
labeledScale($rf, 'top', 8, 'seconds', \$config{EXIFsec}, 0, 59, 1);
my $OKB;
$entry->bind('', sub { $OKB->Invoke; } );
$entry->focus;
my $ButF = $dtw->Frame()->pack(-fill =>'x', -padx => 3, -pady => 3);
$OKB = $ButF->Button(-text => lang('OK'),
-command => sub {
$rc = 'OK';
$dtw->destroy();
})->pack(-side => 'left', -expand => 1, -fill => 'x',
-padx => 3, -pady => 3);
my $XBut = $ButF->Button(-text => lang('Cancel'),
-command => sub {
$rc = 'Cancel';
$dtw->destroy();
}
)->pack(-side => 'left', -expand => 1, -fill => 'x',
-padx => 3, -pady => 3);
bind_exit_keys_to_button($dtw, $XBut);
$dtw->Popup;
$dtw->waitWindow();
return $rc;
}
##############################################################
# showEXIFThumb - displays the embedded EXIF thumbnail
##############################################################
sub showEXIFThumb {
my $noThumbIn = '';
my @sellist = $picLB->info('selection');
return unless checkSelection($top, 1, 0, \@sellist, lang("picture(s)"));
return unless askSelection(\@sellist, 10, "EXIF thumbnail");
if (!-d $trashdir) { # we need the trash dir for the temp files
$top->messageBox(-icon => 'warning', -message => "Trash folder $trashdir not found!\nPlease create this folder (shell: mkdir $trashdir) and retry.\n\nAborting.",
-title => "No trash folder", -type => 'OK');
return;
}
my $pw = progressWinInit($top, "Show EXIF thumbnail");
my $i = 0;
foreach my $dpic (@sellist) {
last if progressWinCheck($pw);
$i++;
progressWinUpdate($pw, "Show EXIF thumbnail ($i/".scalar @sellist.") ...", $i, scalar @sellist);
my $pic = basename($dpic);
my $exifthumb = "$trashdir/EXIFthumb-$pic";
if (-f $exifthumb) {
$top->messageBox(-icon => 'warning', -message => "There is something wrong, $exifthumb already exists.\nPlease delete it first.\nSkipping!",
-title => 'Warning', -type => 'OK');
next;
}
my $errors = '';
extractThumb($dpic, $exifthumb, \$errors);
if (!-f $exifthumb) {
$noThumbIn .= "$pic\n";
next;
}
showPicInOwnWin($exifthumb); # show the thumb
# remove the thumb
removeFile($exifthumb);
}
progressWinEnd($pw);
showText("No EXIF thumbnail",
"Sorry, there seems to be no embedded EXIF thumbnail in the following pictures:\n\n$noThumbIn"
,NO_WAIT) if ($noThumbIn ne '');
log_it("ready! ($i of ".scalar @sellist." thumbs)");
}
{ # encapsulate data structure with access methods
my $copyEXIFDataSource; # local variable for copy/pasteEXIFdata source
##############################################################
# copyEXIFData - copy the EXIF info from one picture to others
##############################################################
sub copyEXIFData {
my @sellist = $picLB->info('selection');
if (@sellist != 1) {
$top->messageBox(-icon => 'warning', -message => "Please select exactly one picture (the picture from which the EXIF info should be taken) for this function!",
-title => 'Error', -type => 'OK');
return;
}
$copyEXIFDataSource = $sellist[0]; # save source pic to global variable
log_it(lang("Copy meta information from ").basename($copyEXIFDataSource));
return; # that's all for now ;-)
}
##############################################################
# pasteEXIFData - paste the EXIF info from one picture to others
##############################################################
sub pasteEXIFData {
my @sellist = $picLB->info('selection');
my $selected = @sellist;
my $errors = '';
my $i = 0;
return unless checkSelection($top, 1, 0, \@sellist, lang("picture(s)"));
if ((not defined $copyEXIFDataSource) or (not -f $copyEXIFDataSource)) {
$top->messageBox(-icon => 'warning', -message => "Please select a source picture (the picture from which the EXIF info should be copied) first by using EXIF info->copy from!",
-title => 'Error', -type => 'OK');
return;
}
# get EXIF info and thumbnail for dialog
my $exif = getShortEXIF($copyEXIFDataSource, WRAP);
my $EXIFthumb = ''; # temp file holding the embedded EXIF thumbnail
$EXIFthumb = "$user_data_path/".basename($copyEXIFDataSource);
extractThumb($copyEXIFDataSource, $EXIFthumb, \$errors);
my $message = "Copy the EXIF infos:\
-------------\
$exif\
-------------\
and the embedded thumbnail from\
\"".basename($copyEXIFDataSource)."\"\
to $selected selected pictures.\
The original EXIF infos and thumbnails of these pictures will be lost!\
Ok to continue?";
my $rc = myButtonDialog('Copy EXIF data', $message, $EXIFthumb, 'OK', 'Cancel');
removeFile($EXIFthumb); # remove temp thumbnail file
return if ($rc ne 'OK');
log_it("transfering EXIF infos from ".basename($copyEXIFDataSource)." to $selected pictures");
my $pw = progressWinInit($picLB, 'Copy EXIF data');
foreach my $dpic (@sellist) {
last if progressWinCheck($pw);
$i++;
progressWinUpdate($pw, "transfering EXIF info ($i/$selected) ...", $i, $selected);
# check if file is a link and get the real target
next if (!getRealFile(\$dpic));
next if (!checkWriteable($dpic));
my $rc = copyEXIF( $copyEXIFDataSource, $dpic);
$errors .= "$rc\n" if ($rc ne "1");
updateOneRow($dpic, $picLB);
showImageInfo($dpic) if ($dpic eq $actpic);
#showImageInfoCanvas($dpic) if ($dpic eq $actpic);
# touch the thumbnail pic (set actual time stamp), to suppress rebuilding the next time
touch(getThumbFileName($dpic));
}
progressWinEnd($pw);
log_it("ready! ($i/$selected copied)");
showText('Errors while copying EXIF infos', $errors, NO_WAIT) if ($errors ne '');
}
##############################################################
# copyThumbnail
##############################################################
sub copyThumbnail {
my @sellist = $picLB->info('selection');
my $selected = @sellist;
return unless checkSelection($top, 1, 0, \@sellist, lang("picture(s)"));
if ((!defined $copyEXIFDataSource) or (!-f $copyEXIFDataSource)) {
$top->messageBox(-icon => 'warning', -message => 'Please select a source picture first. This picture will be used as thumbnail, you may use "Save thumbnail ..." first. Than choose EXIF info->copy from!',
-title => 'No source picture', -type => 'OK');
return;
}
my $size = getFileSize($copyEXIFDataSource, NO_FORMAT); # file size in bytes
if ($size > 65535) {
$top->messageBox(-icon => 'warning', -message => "Sorry, the thumbnail picture is too big ($size bytes). The thumbnail picture must have less than 65535 bytes.",
-title => "Thumbnail too big", -type => 'OK');
return;
}
my $message = "Copy this thumbnail from\
\"".basename($copyEXIFDataSource)."\"\
to $selected selected pictures.\
The original thumbnails of these pictures will be lost!\
Ok to continue?";
my $rc = myButtonDialog("Copy EXIF data", "$message", $copyEXIFDataSource, 'OK', 'Cancel');
return if ($rc ne 'OK');
log_it("transfering thumbnail to $selected pictures");
my $errors = '';
my $i = 0;
my $pw = progressWinInit($top, "Copy thumbnail");
foreach my $dpic (@sellist) {
last if progressWinCheck($pw);
$i++;
progressWinUpdate($pw, "transfering thumbnail ($i/$selected) ...", $i, $selected);
# check if file is a link and get the real target
next if (!getRealFile(\$dpic));
next if (!checkWriteable($dpic));
my $rc = writeThumb($dpic, $copyEXIFDataSource);
$errors .= "$rc\n" if ($rc ne '1');
updateOneRow($dpic, $picLB);
# touch the thumbnail pic (set actual time stamp), to suppress rebuilding the next time
touch(getThumbFileName($dpic));
}
progressWinEnd($pw);
log_it("ready! ($i/$selected thumbnails transfered)");
showText("Errors while transfering thumbnails", $errors, NO_WAIT) if ($errors ne '');
}
} # end encapsulation
##############################################################
# copyEXIF
##############################################################
sub copyEXIF {
my $from = shift;
my $to = shift;
if (!-f $from) {
warn "copyEXIF: file $from does not exists!\n";
return;
}
if (!-f $to) {
warn "copyEXIF: file $to does not exists!\n";
return;
}
# from file
my $meta = getMetaData($from, '^APP1$', 'FASTREADONLY');
return "Could not get EXIF info of source $from!" unless (defined $meta);
# to file
my $meta2 = getMetaData($to, '^APP1$');
return "Could not get EXIF info of target $to!" unless (defined $meta2);
# find the EXIF segment
my $seg = extract_app1_Exif_segment($meta);
return "Could not get EXIF segment of source $from!" unless (defined $seg);
# insert the segment and save the picture
insert_app1_Exif_segment($meta2, $seg);
my $result = $meta2->save();
return "save failed for $to" unless ($result);
return 1;
}
##############################################################
# extract_app1_Exif_segment - sub supplied from Stefano Bettelli
##############################################################
sub extract_app1_Exif_segment {
my ($this) = @_;
my $segment = $this->retrieve_app1_Exif_segment();
return unless $segment;
# this removes the segment from the picture (in memory)
# you could skip this if the picture is no more used
@{$this->{segments}} = grep { $_ != $segment } @{$this->{segments}};
# this unlinks the picture from the segment, orphaning it
$segment->{parent} = undef;
return $segment;
}
##############################################################
# insert_app1_Exif_segment - sub supplied from Stefano Bettelli
##############################################################
sub insert_app1_Exif_segment {
my ($this, $segment) = @_;
# this locates or produces an Exif segment
my $old = $this->provide_app1_Exif_segment();
for (@{$this->{segments}}) {
# looking for the segment to replace ...
next unless $_ == $old;
# tell the segment it now belongs to the picture
$segment->{parent} = $this;
# tell the picture it now owns the segment
$_ = $segment;
last;
}
}
##############################################################
# restoreComments - remove existing comments and store the
# given list of comments
##############################################################
sub restoreComments {
my $dpic = shift;
my @comments = @_;
my $meta = getMetaData($dpic, "COM");
if ($meta) {
# remove all existing comments, we want to restore exactly
$meta->remove_all_comments();
# write the old comments back
if (@comments) {
foreach (@comments) {
$meta->add_comment($_);
}
}
unless ($meta->save()) {
warn "restoreComments: save $dpic failed!";
}
}
}
##############################################################
# EXIFsave - make a new subdir .exif, copy the thumbnail of
# the selected pics to this dir, copy the EXIF
# info from the original pics to the thumbs
##############################################################
sub EXIFsave {
my @sellist = $picLB->info('selection');
return unless checkSelection($top, 1, 0, \@sellist, lang("picture(s)"));
# make EXIF subdir
return if (!makeDir("$actdir/$exifdirname", ASK));
my $errors = '';
my $i = 0;
my $pw = progressWinInit($top, "Save EXIF infos");
foreach my $dpic (@sellist) {
last if progressWinCheck($pw);
$i++;
progressWinUpdate($pw, "Saving EXIF info ($i/".scalar @sellist.") ...", $i, scalar @sellist);
my $pic = basename($dpic);
my $exiffile = "$actdir/$exifdirname/$pic";
# check if file is a link and get the real target
next if (!getRealFile(\$dpic));
my $meta = getMetaData($dpic, '^APP1$', 'FASTREADONLY');
unless (defined $meta) {
$errors .= "Could not get EXIF info of $pic!\n";
next;
}
my $seg = extract_app1_Exif_segment($meta);
unless (defined $seg) {
$errors .= "Could not get EXIF segment of $pic!\n";
next;
}
unless (nstore($seg, $exiffile)) {
$errors .= "could not store EXIF segment in file $exiffile: $!\n";
next;
}
updateOneRow($dpic, $picLB); # display the new exif info (flag [s] is now set)
showImageInfo($dpic) if ($dpic eq $actpic);
}
progressWinEnd($pw);
log_it("ready! ($i/".scalar @sellist." saved)");
showText("Errors while saving EXIF infos", $errors, NO_WAIT) if ($errors ne '');
}
##############################################################
# EXIFrestore - copy the saved EXIF info back to the selected
# pics
##############################################################
sub EXIFrestore {
my @sellist = $picLB->info('selection');
return unless checkSelection($top, 1, 0, \@sellist, lang("picture(s)"));
if (!-d "$actdir/$exifdirname") {
$top->messageBox(-icon => 'warning', -message => "Found no saved EXIF infos in this folder!",
-title => "No EXIF infos", -type => 'OK');
return;
}
# message for one picture
my $message = "Restore saved EXIF infos to ".basename($sellist[0]).".\nThe actual EXIF infos of this picture will be lost!\nOk to continue?";
# message for more than one picture
if (@sellist > 1) {
$message = "Restore saved EXIF infos\nto the ".scalar @sellist." pictures.\nThe actual EXIF infos of this picture will be lost!\nOk to continue?"
}
return if (myButtonDialog("Restore EXIF data", "$message", undef, 'OK', 'Cancel') ne 'OK');
my $errors = '';
my $i = 0;
my $pw = progressWinInit($top, "Restore EXIF info");
foreach my $dpic (@sellist) {
last if progressWinCheck($pw);
$i++;
progressWinUpdate($pw, "Restore EXIF info ($i/".scalar @sellist.") ...", $i, scalar @sellist);
my $pic = basename($dpic);
my $exiffile = "$actdir/$exifdirname/$pic";
unless (-f $exiffile) {
$errors .= "Found no saved EXIF infos for $dpic!\n";
next;
}
# check if file is a link and get the real target
next if (!getRealFile(\$dpic));
next if (!checkWriteable($dpic));
my $meta = getMetaData($dpic, '^APP1$');
unless (defined $meta) {
$errors .= "Could not get EXIF info of $dpic!\n";
next;
}
# load stored EXIF segment from the file
my $exif = retrieve($exiffile);
unless (defined $exif) {
$errors .= "could not retrieve saved EXIF info\n";
next;
}
insert_app1_Exif_segment($meta, $exif);
unless ($meta->save()) {
$errors .= "save failed for $dpic\n";
next;
}
updateOneRow($dpic, $picLB);
showImageInfo($dpic) if ($dpic eq $actpic);
# touch the thumbnail pic (set actual time stamp), to suppress rebuilding the next time
touch(getThumbFileName($dpic));
}
progressWinEnd($pw);
log_it("ready! ($i/".scalar @sellist."restored)");
showText("Errors while restoring EXIF data", $errors, NO_WAIT) if ($errors ne '');
}
##############################################################
# EXIFremoveSaved - remove the saved exif info file
##############################################################
sub EXIFremoveSaved {
my @sellist = $picLB->info('selection');
return unless checkSelection($top, 1, 0, \@sellist, lang("picture(s)"));
if (!-d "$actdir/$exifdirname") {
$top->messageBox(-icon => 'warning', -message => "Sorry, but there are no saved EXIF infos in this folder!",
-title => "no EXIF infos", -type => 'OK');
return;
}
my $rc = $top->messageBox(-icon => 'warning', -message => "Remove the saved EXIF infos and the embedded thumbnails of ".scalar @sellist." pictures.\nOk to continue?",
-title => "Warning", -type => 'OKCancel');
return if ($rc !~ m/Ok/i);
my $i = 0;
my $pw = progressWinInit($top, "Remove saved EXIF infos");
foreach my $dpic (@sellist) {
last if progressWinCheck($pw);
$i++;
progressWinUpdate($pw, "Removing saved EXIF info ($i/".scalar @sellist.") ...", $i, scalar @sellist);
my $pic = basename($dpic);
my $exifthumb = "$actdir/$exifdirname/$pic";
if ((!-f $exifthumb) and (@sellist == 1)) { # show this info only when removing from one file
$top->messageBox(-icon => 'warning', -message => "Sorry, but there are no saved EXIF infos for $pic!",
-title => "no EXIF infos", -type => 'OK');
next;
}
# check if file is a link and get the real target
next if (!getRealFile(\$dpic));
# remove the saved EXIF info file
removeFile($exifthumb );
updateOneRow($dpic, $picLB);
showImageInfo($dpic) if ($dpic eq $actpic);
}
progressWinEnd($pw);
log_it("ready! ($i/".scalar @sellist." exif removed)");
}
##############################################################
# copyComment - copy the comment from one picture to others
##############################################################
sub copyComment {
my $direction = shift; # "from" or "to"
if (!defined $direction) {
warn "copyComment: Missing a direction, should be \"from\" or \"to\"!";
return;
}
my @sellist = $picLB->info('selection');
my $selected = @sellist;
my $i = 0;
if ($direction eq 'from') { # set the copy source
if (@sellist != 1) {
$top->messageBox(-icon => 'warning', -message => "Please select exactly one picture (the picture from which comments should be taken) for this function!",
-title => 'Error', -type => 'OK');
return;
}
$copyCommentSource = $sellist[0]; # save source pic to global variable
log_it("copy source set to ".basename($copyCommentSource));
return; # that's all for now ;-)
}
elsif ($direction eq 'to') {
return unless checkSelection($top, 1, 0, \@sellist, lang("picture(s)"));
if ((!defined $copyCommentSource) or (!-f $copyCommentSource)) {
$top->messageBox(-icon => 'warning', -message => "Please select a source picture (the picture from which comments should be taken) first, and than choose comments->copy from!",
-title => 'Error', -type => 'OK');
return;
}
my $com = getComment($copyCommentSource, SHORT);
my $thumb = getThumbFileName($copyCommentSource);
my $message = "Add the comments:\
-------------\
$com\
-------------\
from\
\"".basename($copyCommentSource)."\"\
to $selected selected pictures.\
The original comments won't be lost!\
Ok to continue?";
my $rc = myButtonDialog("Copy comments", $message, $thumb, 'OK', 'Cancel');
return if ($rc ne 'OK');
log_it("transfering comments to $selected pictures");
my $pw = progressWinInit($top, "Transfer comments");
foreach my $dpic (@sellist) {
last if progressWinCheck($pw);
$i++;
progressWinUpdate($pw, "transfering comments ($i/$selected) ...", $i, $selected);
next if (!checkWriteable($dpic));
# check if file is a link and get the real target
next if (!getRealFile(\$dpic));
my @comments = getComments($copyCommentSource);
my $meta = getMetaData($dpic, "COM");
next unless ($meta);
# add the comments
foreach (@comments) {
$meta->add_comment($_);
}
unless ($meta->save()) { warn "copyComment: save $dpic failed!"; }
updateOneRow($dpic, $picLB);
# touch the thumbnail pic (set actual time stamp), to suppress rebuilding the next time
touch(getThumbFileName($dpic));
} # foreach end
progressWinEnd($pw);
}
else {
warn "copyComment: Wrong direction ($direction), should be \"from\" or \"to\"!";
return;
}
log_it("ready! ($i of $selected copied)");
}
##############################################################
# displayIPTCData - displays all IPTC-Data in a window
##############################################################
sub displayIPTCData {
my $lb = shift;
my @sellist = $lb->info('selection');
return unless checkSelection($top, 1, 0, \@sellist, lang("picture(s)"));
return unless askSelection(\@sellist, 10, "IPTC info");
my $i = 0;
my $pw = progressWinInit($lb, "Display IPTC data");
foreach my $dpic (@sellist) {
last if progressWinCheck($pw);
$i++;
my $iptc = '';
progressWinUpdate($pw, "displaying IPTC data ($i/".scalar @sellist.") ...", $i, scalar @sellist);
my $pic = basename($dpic);
# check if file is a link and get the real target
next if (!getRealFile(\$dpic));
my $title = "IPTC/IIM information of $pic";
$iptc = getIPTC($dpic, LONG);
if ($iptc eq '') {
$iptc = "Found no IPTC/IIM information in \"$pic\"\n";
}
showText($title, $iptc, NO_WAIT, getThumbFileName($dpic));
}
progressWinEnd($pw);
if ($lb == $picLB) {
log_it("ready! ($i/".scalar @sellist." IPTC displayed)");
}
}
##############################################################
# saveIPTC - save IPTC info hash as template to a file
##############################################################
sub saveIPTC {
my $lb = shift;
my @sellist = getSelection($lb);
return unless checkSelection($lb, 1, 1, \@sellist, lang("picture(s)"));
my $dpic = $sellist[0];
my ($ok, $iptc) = get_IPTC_info($dpic);
if (not $ok) {
$top->messageBox(-icon => 'warning', -message => "Could not open IPTC segment of $dpic!",
-title => "Save IPTC info", -type => 'OK');
return;
}
if (!-d $iptcdir) {
if ( !mkdir $iptcdir, oct(755) ) {
$top->messageBox(-icon => 'warning', -message => "Error making IPTC template folder $iptcdir: $!",
-title => "Save IPTC template", -type => 'OK');
return;
}
}
my $types = [ ['IPTC Template', '.iptc2',], ['All Files', '*',], ];
my $file = $top->getSaveFile(-title => 'Save IPTC template (please use the .iptc2 suffix)', -defaultextension => 'iptc2', -initialfile => "template.iptc2", -initialdir => $iptcdir, -filetypes => $types);
return if ((!defined $file) or ($file eq ''));
my $rc = nstore($iptc, $file) or warn "could not store IPTC in file $file: $!";
log_it("IPTC template saved ($rc)");
}
{ # encapsulate data structure with access methods
my $iptcCopySource; # local variable to store path and picture name for copyIPTC/pasteIPTC
##############################################################
# copyFromIPTC
##############################################################
sub copyIPTC {
my @sellist = $picLB->info('selection');
if (@sellist != 1) {
$top->messageBox(-icon => 'warning', -message => "Please select exactly one picture.",
-title => "Copy IPTC info", -type => 'OK');
return;
}
$iptcCopySource = $sellist[0];
log_it("IPTC copy from $iptcCopySource");
}
##############################################################
# pasteIPTC
##############################################################
sub pasteIPTC {
my @sellist = $picLB->info('selection');
return unless checkSelection($top, 1, 0, \@sellist, lang("picture(s)"));
if (not defined $iptcCopySource or not -f $iptcCopySource) {
$top->messageBox(-icon => 'warning', -message => "Please select a copy source picture first.",
-title => "Paste IPTC info", -type => 'OK');
return;
}
# get IPTC info from source picture (set by copyIPTC)
my $meta = getMetaData($iptcCopySource, 'APP13');
my $iptcCopy = $meta->get_app13_data('TEXTUAL', 'IPTC');
unless (defined $iptcCopy) {
$top->messageBox(-icon => 'warning', -message => "There is no IPTC info in source picture $iptcCopySource! Stopping.",
-title => "Paste IPTC info", -type => 'OK');
return;
}
applyIPTC($picLB, $iptcCopy, \@sellist);
my $sel_pics = scalar(@sellist);
log_it(langf("Meta information from %s added to %d picture(s).",basename($iptcCopySource),$sel_pics));
}
}
##############################################################
# mergeIPTC - merge a IPTC info hash template to a file
##############################################################
sub mergeIPTC {
my @sellist = $picLB->info('selection');
return unless checkSelection($top, 1, 0, \@sellist, lang("picture(s)"));
my $types = [ ['IPTC Template', '.iptc2',], ['All Files', '*',], ];
my $file = $top->getOpenFile(-title => 'Merge IPTC template', -defaultextension => 'iptc2', -initialdir => $iptcdir, -filetypes => $types);
return if ((!defined $file) or ($file eq '') or (!-f $file));
my $iptc = retrieve($file);
unless (defined $iptc) {
warn langf("Could not retrieve %s",$file);
return;
}
applyIPTC($picLB, $iptc, \@sellist);
}
##############################################################
# applyIPTC - apply a IPTC info hash to a list of pics
##############################################################
sub applyIPTC {
my $lb = shift; # reference to listbox widget
my $iptc = shift; # reference to an IPTC hash as provided by Image::MetaData::JPEG
my $piclist = shift; # picture list reference
my $errors = '';
my $pw = 0;
$pw = progressWinInit($lb, 'Apply IPTC template') if (@$piclist > 1);
my $i = 0;
foreach my $dpic (@$piclist) {
last if ($pw and progressWinCheck($pw));
$i++;
progressWinUpdate($pw, "applying IPTC template ($i/".scalar @$piclist.") ...", $i, scalar @$piclist) if $pw;
my ($ok, $error) = applyIPTCint($dpic, $iptc);
if ($ok) {
my $dirthumb = getThumbFileName($dpic);
# touch the thumbnail pic (set actual time stamp), to suppress rebuilding the next time
touch($dirthumb);
updateOneRow($dpic, $lb);
showImageInfoCanvas($dpic) if ($dpic eq $actpic);
}
else {
$errors .= $error;
}
}
progressWinEnd($pw) if $pw;
log_it("ready! ($i of ".scalar @$piclist." processed)");
showText('Errors while applying IPTC infos', $errors, NO_WAIT) if ($errors ne '');
}
##############################################################
##############################################################
sub applyIPTCint {
my $dpic = shift;
my $iptc = shift; # reference to an IPTC hash as provided by Image::MetaData::JPEG
my $error = '';
if (not checkWriteable($dpic)) {
$error .= "File $dpic is not writable! Skipping.\n";
return (0, $error);
}
my $meta = getMetaData($dpic, 'APP13');
if (not defined $meta) {
$error .= "Could not get IPTC info of $dpic!";
return (0, $error);
}
# todo, we could also use UPDATE or REPLACE here
$meta->set_app13_data($iptc, 'ADD', 'IPTC');
# make the SupplementalCategories and Keywords unique and sorted
uniqueIPTC($meta);
if (not $meta->save()) {
$error .= "Saving IPTC info failed for $dpic\n";
return (0, $error);
}
return (1, $error);
}
##############################################################
# uniqueArray
##############################################################
sub uniqueArray {
my $listR = shift;
my %d; # build a hash
foreach (@{$listR}) { $d{$_} = 1; }
@{$listR} = (sort { uc($a) cmp uc($b); } keys %d);
}
##############################################################
# uniqueIPTC - remove double entries from SupplementalCategories
# and Keywords and sort them alphabetically
# !Function will not save IPTC!
##############################################################
sub uniqueIPTC {
my $meta = shift;
my $iptc = $meta->get_app13_data('TEXTUAL', 'IPTC');
# replace (german) umlaute by corresponding letters and
# replace all non-printable chars, but not newline etc.
if ($config{onlyASCII}) {
foreach my $key (keys %{$iptc}) {
if (${$iptc->{$key}}[0]) {
# test some encodings
#my $utf8code = Encode::decode('utf8',${$iptc->{$key}}[0]);
#my $isocode = Encode::decode('iso-8859-1',${$iptc->{$key}}[0]);
#if ($utf8code =~ m/Ö/) {
# print "Found Ö in utf8code $utf8code ${$iptc->{$key}}[0]\n";
#}
#if ($isocode =~ m/Ö/) {
# print "Found Ö in isocode $isocode ${$iptc->{$key}}[0]\n";
#}
# end test encodings
${$iptc->{$key}}[0] =~ s/([$umlaute])/$umlaute{$1}/g;
${$iptc->{$key}}[0] =~ tr/\n\t\r\f -~//cd;
}
}
}
my %d; # build a hash
foreach (@{$iptc->{SupplementalCategory}}) {
$_ =~ tr/ -~//cd; # replace all non-printable chars
$d{$_} = 1;
}
@{$iptc->{SupplementalCategory}} = (sort { uc($a) cmp uc($b); } keys %d);
%d = (); # completely empty %d
foreach (@{$iptc->{Keywords}}) {
$_ =~ tr/ -~//cd; # replace all non-printable chars (Picasa adds one to each keyword)
$d{$_} = 1;
}
@{$iptc->{Keywords}} = (sort { uc($a) cmp uc($b); } keys %d);
$meta->set_app13_data($iptc, 'REPLACE', 'IPTC');
}
##############################################################
# editIPTCCategories
##############################################################
sub editIPTCCategories {
my $lb = shift;
if (Exists($catw)) {
$catw->deiconify;
$catw->raise;
$catw->focus;
return;
}
# open window
$catw = $lb->Toplevel();
$catw->withdraw;
$catw->title('Categories');
$catw->iconimage($mapiviicon) if $mapiviicon;
my $cattree;
my $XBut = $catw->Button(-text => lang('Close'),
-command => sub {
saveTreeMode($cattree);
nstore($cattree->{m_mode}, "$user_data_path/categoryMode") or warn "could not store $user_data_path/categoryMode: $!";
$catw->destroy;
})->pack(-expand => 0,-fill => 'x',-padx => 1,-pady => 1);
my $af = $catw->Frame()->pack(-fill =>'x', -padx => 3, -pady => 3);
$af->Radiobutton(-text => "all", -variable => \$config{CategoriesAll}, -value => 1)->pack(-side => 'left');
$af->Radiobutton(-text => "join", -variable => \$config{CategoriesAll}, -value => 2)->pack(-side => 'left');
$af->Radiobutton(-text => "last", -variable => \$config{CategoriesAll}, -value => 0)->pack(-side => 'left');
my $addB =
$af->Button(-text => lang('add'),
-command => sub {
my @cats = $cattree->info('selection');
return unless checkSelection($catw, 1, 0, \@cats);
my @sellist = $lb->info('selection');
return unless checkSelection($catw, 1, 0, \@sellist);
my $warning = '';
my @catlist;
foreach my $cat (@cats) {
my @items;
if ($config{CategoriesAll} == 1) { # all, separated
@items = getAllItems($cat);
}
elsif ($config{CategoriesAll} == 2) { # all, joined
@items = getAllItems($cat);
my $joined = join('.', @items);
if (length($joined) > 32) {
$warning .= "Category $joined has ".length($joined)." characters";
next;
}
undef @items;
push @items, $joined;
}
elsif ($config{CategoriesAll} == 0) { # last
@items = getLastItem($cat);
}
else {
warn "editIPTCCategories: should never be reached ($config{CategoriesAll})!";
}
push @catlist, @items;
}
if (@catlist) {
my $iptc = { SupplementalCategory => \@catlist };
applyIPTC($lb, $iptc, \@sellist);
}
if ($warning ne '') {
$warning = "IPTC supp. categories are limited to 32 characters. Please shorten category.\n$warning";
showText("Warnings while adding keywords", $warning, NO_WAIT);
}
} )->pack(-side => 'left', -expand => 0, -fill => 'x', -padx => 1, -pady => 1);
$balloon->attach($addB, -msg => "Add the selected categories to the selected pictures");
my $rmB =
$af->Button(-text => lang('remove'),
-command => sub {
my @cats = $cattree->info('selection');
return unless checkSelection($catw, 1, 0, \@cats);
my @sellist = $lb->info('selection');
return unless checkSelection($catw, 1, 0, \@sellist);
my $pw = progressWinInit($catw, "Remove category");
my $i = 0;
my $sum = @sellist;
foreach my $dpic (@sellist) {
last if progressWinCheck($pw);
$i++;
progressWinUpdate($pw, "removing category ($i/$sum) ...", $i, $sum);
foreach my $cat (@cats) {
last if progressWinCheck($pw);
progressWinUpdate($pw, "removing category $cat ($i/$sum) ...", $i, $sum);
my $item;
if ($config{CategoriesAll} == 2) { # all, joined
my @items = getAllItems($cat);
$item = join('.', @items);
}
else { # last
$item = getLastItem($cat);
}
print "remove category $item ($cat) from $dpic\n" if $verbose;
removeIPTCItem($dpic, 'SupplementalCategory', $item);
updateOneRow($dpic, $lb);
}
}
progressWinEnd($pw);
})->pack(-side => 'left', -expand => 0, -fill => 'x', -padx => 1, -pady => 1);
$balloon->attach($rmB, -msg => "Remove the selected categories from the selected pictures");
$cattree = $catw->Scrolled('Tree',
-separator => '/',
-scrollbars => 'osoe',
-selectmode => 'extended',
-exportselection => 0,
-width => 25,
-height => 25,
)->pack(-expand => 1, -fill =>'both', -padx => 4, -pady => 2);
$balloon->attach($cattree, -msg => "Double click on a category to add it to the selected pictures.\nIt's possible to edit the categories, use the\nright mouse button to open the edit menu.");
# try to get the saved mode
if (-f "$user_data_path/categoryMode") {
my $hashRef = retrieve("$user_data_path/categoryMode");
warn "could not retrieve mode" unless defined $hashRef;
$cattree->{m_mode} = $hashRef;
}
$cattree->bind('', sub { $addB->Invoke; });
addTreeMenu($cattree, \@precats);
insertTreeList($cattree, @precats);
bind_exit_keys_to_button($catw, $XBut);
$catw->Popup;
$catw->waitWindow;
}
##############################################################
# format given keyword list (reference) according to the configured format (all, joined, or last)
# return formated list
##############################################################
sub keyword_format {
my $keys = shift; # list reference
my $warning = shift; # string reference
my @keylist;
foreach my $key (@$keys) {
my @items;
if ($config{KeywordsAll} == 1) { # all, separated
@items = getAllItems($key);
}
elsif ($config{KeywordsAll} == 2) { # all, joined
@items = getAllItems($key);
my $joined = join('.', @items);
if (length($joined) > 64) {
$$warning .= "Keyword $joined has ".length($joined)." characters";
next;
}
undef @items;
push @items, $joined;
}
elsif ($config{KeywordsAll} == 0) { # last
@items = getLastItem($key);
}
else {
warn "keyword_format: \$config{KeywordsAll} has wrong value: $config{KeywordsAll} should never be reached!";
}
push @keylist, @items;
}
return @keylist;
}
##############################################################
# editCommentKeywords
##############################################################
sub editCommentKeywords {
my $lb = shift;
if (Exists($keycw)) {
$keycw->deiconify;
$keycw->raise;
$keycw->focus;
return;
}
# open window
$keycw = $top->Toplevel();
$keycw->withdraw;
$keycw->title('Keywords for comments');
$keycw->iconimage($mapiviicon) if $mapiviicon;
my $keytree;
my $XBut = $keycw->Button(-text => lang('Close'),
-command => sub {
saveTreeMode($keytree);
nstore($keytree->{m_mode}, "$user_data_path/keywordMode") or warn "could not store $user_data_path/keywordMode: $!";
$keycw->destroy;
})->pack(-expand => 0,-fill => 'x',-padx => 1,-pady => 1);
my $af = $keycw->Frame()->pack(-fill =>'x', -padx => 3, -pady => 3);
$af->Radiobutton(-text => "all", -variable => \$config{KeywordsAll}, -value => 1)->pack(-side => 'left');
$af->Radiobutton(-text => "last", -variable => \$config{KeywordsAll}, -value => 0)->pack(-side => 'left');
my $addB =
$af->Button(-text => 'add',
-command => sub {
my @keys = $keytree->info('selection');
return unless checkSelection($keycw, 1, 0, \@keys, lang("keyword(s)"));
my @sellist = $lb->info('selection');
return unless checkSelection($keycw, 1, 0, \@sellist, lang("keyword(s)"));
my $comment;
foreach my $key (@keys) {
my @items;
if ($config{KeywordsAll}) {
@items = getAllItems($key);
}
else {
@items = getLastItem($key);
}
$comment .= "$_ " foreach (@items);
}
# todo add to end of existing comment or as new comment
foreach my $dpic (@sellist) {
# todo progressbar
addCommentToPic($comment, $dpic, TOUCH);
updateOneRow($dpic, $lb);
showImageInfo($dpic) if ($dpic eq $actpic);
}
} )->pack(-side => 'left', -expand => 0, -fill => 'x', -padx => 1, -pady => 1);
$balloon->attach($addB, -msg => "Add the selected keywords to the selected pictures");
$keytree = $keycw->Scrolled('Tree',
-separator => '/',
-scrollbars => 'osoe',
-selectmode => 'extended',
-exportselection => 0,
-width => 25,
-height => 25,
)->pack(-expand => 1, -fill =>'both', -padx => 4, -pady => 2);
$balloon->attach($keytree, -msg => "Double click on a keyword to insert it.\nIt's possible to edit the keywords, use the\nright mouse button to open the edit menu.");
# try to get the saved mode
if (-f "$user_data_path/keywordMode") {
my $hashRef = retrieve("$user_data_path/keywordMode");
warn "could not retrieve mode" unless defined $hashRef;
$keytree->{m_mode} = $hashRef;
}
$keytree->bind('', sub { $addB->Invoke; });
addTreeMenu($keytree, \@prekeys);
insertTreeList($keytree, @prekeys);
bind_exit_keys_to_button($keycw, $XBut);
$keycw->Popup;
$keycw->waitWindow;
}
##############################################################
# addTreeMenu - add a menu to a tree widget to edit a tree
##############################################################
sub addTreeMenu {
my $tree = shift; # tree widget
my $listRef = shift; # the list displayed in the tree
my $hot = shift; # the hotlist widget (optional, if available the additional menu entry "add to clipboard" will be shown)
my $menu = $tree->Menu(-title => lang('Tree edit menu'));
if (defined $hot and Exists($hot)) {
$menu->command(-label => lang('add to clipboard'), -command => sub {
my @keys = $tree->info('selection');
return unless checkSelection($tree, 1, 0, \@keys);
add_keyword_to_hotlist($hot, \@keys);
});
$menu->separator;
}
$menu->command(-label => lang('add new item'), -command => sub {
my @keys = $tree->info('selection');
return unless checkSelection($tree, 1, 1, \@keys);
my $item = '';
my $parent = '';
$parent = $keys[0] if (@keys);
if ($parent !~ m/.*\/.*/) {
$parent = '';
}
else {
# cut of last element
$parent = $1 if ($parent =~ m/(.*\/).*/);
$parent .= '/' if (($parent ne '') and ($parent !~ m/.*\/$/));
}
my $rc = myEntryDialog(lang('New item'),
langf("Please enter the new item (below %s)",$parent),
\$item);
return if ($rc ne 'OK');
return if ($item eq '');
# avoid slash and backslash
if (($item =~ m|.*\/.*|) or ($item =~ m|.*\\.*|)) {
$tree->messageBox(-icon => 'info',
-message => 'Sorry, but the slash (/) and the backslash (\) are not allowed.',
-title => 'Wrong character', -type => 'OK');
return;
}
# avoid double entries
if (isInList($parent.$item, $listRef)) {
$tree->messageBox(-icon => 'info',
-message => "Sorry, but $parent$item is already in the list.",
-title => 'Double entry', -type => 'OK');
return;
}
push @{$listRef}, $parent.$item;
insertTreeList($tree, @{$listRef});
# show new keywords
filter_tree_open($tree, '', $item);
});
$menu->command(-label => lang('add new sub item'), -command => sub {
my @keys = $tree->info('selection');
return unless checkSelection($tree, 1, 1, \@keys);
my $item = '';
my $parent = $keys[0];
my $rc = myEntryDialog(lang('New sub item'),
langf("Please enter the new sub item (below %s)",$parent),
\$item);
return if ($rc ne 'OK');
return if ($item eq '');
# avoid slash and backslash
if (($item =~ m|.*\/.*|) or ($item =~ m|.*\\.*|)) {
$tree->messageBox(-icon => 'info',
-message => 'Sorry, but the slash (/) and the backslash (\) are not allowed.',
-title => 'Wrong character', -type => 'OK');
return;
}
$parent .= '/' if (($parent ne '') and ($parent !~ m/.*\/$/));
# avoid double entries
if (isInList($parent.$item, $listRef)) {
$tree->messageBox(-icon => 'info',
-message => "Sorry, but $parent$item is already in the list.",
-title => 'Double entry', -type => 'OK');
return;
}
push @{$listRef}, $parent.$item;
insertTreeList($tree, @{$listRef});
# show new keywords
filter_tree_open($tree, '', $item);
});
$menu->separator;
$menu->command(-label => lang('rename or move item'), -command => sub {
my @keys = $tree->info('selection');
return unless checkSelection($tree, 1, 1, \@keys);
my $parent = $keys[0];
my $rc = myEntryDialog('Rename item',
"Please enter the new name for item $parent",
\$parent);
return if ($rc ne 'OK');
return if ($parent eq '');
$parent =~ s|^/||; # cut leading slash
foreach my $t (0 .. @{$listRef}-1) {
# find index and change list entry
if ($$listRef[$t] =~ m/^$keys[0](.*)/) {
print "rename: $$listRef[$t] ($t) to $parent$1\n" if $verbose;
$$listRef[$t] = $parent.$1;
}
}
insertTreeList($tree, @{$listRef});
});
$menu->separator;
$menu->command(-label => lang('delete item(s)'), -command => sub {
my @keys = $tree->info('selection');
return unless checkSelection($tree, 1, 0, \@keys);
for my $t (reverse 0 .. (scalar @{$listRef} - 1) ) {
foreach my $key (@keys) {
if ($$listRef[$t] =~ m/^$key.*/) {
print " trow out: $$listRef[$t] ($t) key = $key\n" if $verbose;
splice @{$listRef}, $t, 1; # remove it from list
}
}
}
insertTreeList($tree, @{$listRef});
});
$menu->separator;
$menu->command(-label => lang('search for item(s)'), -command => sub {
my @keys = $tree->info('selection');
return unless checkSelection($tree, 1, 0, \@keys);
my @keywords;
# here we consider all selected keywords for the search
foreach (@keys) {
push @keywords, split(/\//, $_);
}
my @keywords_ex;
my @list = get_pics_with_keywords(\@keywords, \@keywords_ex);
my $title = 'Keywords: '; $title .= "$_ " foreach (@keywords);
showThumbList(\@list, $title);
});
$menu->separator;
$menu->command(-label => lang('collapse all'), -command => sub { tree_fold(CLOSE, $tree); });
$menu->command(-label => lang('collapse to first sub level'), -command => sub {
my @keys = $tree->info('selection');
return unless checkSelection($tree, 1, 0, \@keys);
for my $key (@keys) {
my @childs = $tree->child_entries($key, 1); # path, depth
foreach my $child (@childs) {
$tree->close($child);
}
}
});
$menu->command(-label => lang('expand all'), -command => sub { tree_fold(OPEN, $tree); });
#$menu->command(-label => lang("expand item(s)"), -command => sub {
# my @keys = $tree->info('selection');
# return unless checkSelection($tree, 1, 0, \@keys);
# for my $key (@keys) {
# print "expand: $key\n";
# my @childs = $tree->child_entries($key, 1); # path, depth
# foreach my $child (@childs) {
# print " child: $child\n";
# $tree->open($child);
# }
# }
#});
$tree->bind('', sub {
$menu->Popup(-popover => 'cursor', -popanchor => 'nw');
} );
}
##############################################################
##############################################################
sub add_keyword_to_hotlist {
my ($hot, $keys) = @_;
foreach my $key (@{$keys}) {
$hot_keywords{$key}++;
}
$hot->delete(0, 'end');
$hot->insert('end', (sort keys %hot_keywords));
return;
}
##############################################################
# getLastItem - returns the last item of a scalar separated with
# a slash: family/Miller/Robert -> Robert
##############################################################
sub getLastItem {
my $item = shift;
my @names = split /\//, $item;
my $name = $names[-1];
$name = $item if ((!defined $name) or ($name eq ''));
return $name;
}
##############################################################
# getAllItems - returns a list of all items of a scalar
# separated with a slash:
# family/Miller/Robert -> family, Miller, Robert
##############################################################
sub getAllItems {
my $item = shift;
return split /\//, $item;
}
##############################################################
# insertTreeList
##############################################################
sub insertTreeList {
my $tree = shift;
my %mode;
saveTreeMode($tree);
%mode = %{$tree->{m_mode}} if (defined $tree->{m_mode});
$tree->delete('all');
# insert the list (@_)
foreach (sort { uc($a) cmp uc($b); } @_ ) {
my @names = split /\//, $_;
my $name = $names[-1];
$name = $_ if ((!defined $name) or ($name eq ''));
$tree->add($_, -text=>$name);
}
$tree->autosetmode;
# reset mode to the the old setting for the first 3 levels
foreach ($tree->info('children')) {
$tree->close($_) if ((defined $mode{$_}) and ($mode{$_} eq 'open'));
$tree->open($_) if ((defined $mode{$_}) and ($mode{$_} eq 'close'));
foreach ($tree->info('children', $_)) {
$tree->close($_) if ((defined $mode{$_}) and ($mode{$_} eq 'open'));
$tree->open($_) if ((defined $mode{$_}) and ($mode{$_} eq 'close'));
foreach ($tree->info('children', $_)) {
$tree->close($_) if ((defined $mode{$_}) and ($mode{$_} eq 'open'));
$tree->open($_) if ((defined $mode{$_}) and ($mode{$_} eq 'close'));
}
}
}
}
##############################################################
# saveTreeMode - save the mode (open, close status) of the first 3
# levels of a tree in $widget->{m_mode}
# {m_mode} is mapivi private data stored in the
# widget hash
##############################################################
sub saveTreeMode {
my $tree = shift;
print "saveTreeMode: Error no widget\n" unless Exists($tree);
my %mode;
%mode = %{$tree->{m_mode}} if (defined $tree->{m_mode});
# save mode (open, close) of existing items for the first 3 levels
foreach ($tree->info('children')) {
$mode{$_} = $tree->getmode($_);
foreach ($tree->info('children', $_)) {
$mode{$_} = $tree->getmode($_);
foreach ($tree->info('children', $_)) {
$mode{$_} = $tree->getmode($_);
}
}
}
$tree->{m_mode} = \%mode;
}
##############################################################
# removeIPTCItem
##############################################################
sub removeIPTCItem {
my $dpic = shift;
my $kind = shift;
my $item = shift;
if (($kind ne 'Keywords') and ($kind ne 'SupplementalCategory')) {
warn "removeIPTCItem: $kind is wrong kind";
return;
}
print "removeIPTCItem: kind:$kind item:$item pic:$dpic\n" if $verbose;
my $meta = getMetaData($dpic, 'APP13');
unless (defined $meta) {
print "removeIPTCItem: Could not create IPTC info for $dpic!\n";
return;
}
my $iptc = $meta->get_app13_data('TEXTUAL', 'IPTC');
my %d; # build a hash
foreach (@{$iptc->{$kind}}) { $d{$_} = 1; }
return unless (defined $d{$item});
delete $d{$item}; # remove item from list
@{$iptc->{$kind}} = (sort { uc($a) cmp uc($b); } keys %d);
$meta->set_app13_data($iptc, 'REPLACE', 'IPTC');
if ($meta->save()) {
my $dirthumb = getThumbFileName($dpic);
# touch the thumbnail pic (set actual time stamp), to suppress rebuilding the next time
touch($dirthumb);
}
else {
print "removeIPTCItem: save failed for $dpic\n";
}
}
#my %get_encoding_name_from_tag = (
# "0x1b0x250x47" => "UTF8",
# stolen from Image::ExifTool (thanks to Phil Harvey)
#------------------------------------------------------------------------------
# Print conversion for CodedCharacterSet
# Inputs: 0) value
sub PrintCodedCharset {
my $val = shift;
return $iptcCharset{$val} if $iptcCharset{$val};
$val =~ s/(.)/ $1/g;
$val =~ s/ \x1b/, ESC/g;
$val =~ s/^,? //;
return $val;
}
##############################################################
# getIPTC - returns all IPTC-Data of the given picture
##############################################################
sub getIPTC {
# the pic with complete path
my $dpic = shift;
# bool, if = LONG a better complete readable output,
# if = SHORT a compact but complete IPTC info for e.g. the search database
# if = MICRO compact, only values no key names
my $format = shift;
my $meta = shift; # optional, the Image::MetaData::JPEG object of $pic if available
my $iptc = '';
my $indent = ''; # space to indent multi key values
return $iptc unless is_a_JPEG($dpic);
my $shortkey;
# todo: is , 'FASTREADONLY' here possible?
$meta = getMetaData($dpic, 'APP13') unless (defined($meta));
if ($meta) {
my $seg = $meta->retrieve_app13_segment(undef, 'IPTC');
if ($seg) {
my $hashref = $seg->get_app13_data('TEXTUAL', 'IPTC');
foreach my $key (@IPTCAttributes) {
# this causes trouble (cuts off the rest) because it's binary
next if ($key eq "RecordVersion");
if (defined($hashref->{$key})) {
if ($format == LONG) {
my $shortkey = $key;
$shortkey = substr($shortkey, 0, 13)."." if (length($shortkey) > 14);
$iptc .= sprintf "%-14s: ", $shortkey;
#$iptc .= sprintf "%-31s: ", $key;
$indent = "\n ";
#$indent = "\n ";
} elsif ($format == MICRO) { # show only content, no key names
$indent = " ";
} else {
my $shortkey = $key;
$shortkey =~ s/SupplementalCategory/SuppCategories/;
$shortkey = substr($shortkey, 0, 7)."." if (length($shortkey) > 8);
$iptc .= sprintf "%-8s: ", $shortkey;
$indent = " ";
}
# add IPTC value
for (@{$hashref->{$key}}) {
# show rating/urgency using stars (*) at least in MICRO output
# todo : could make sense also for the other outputs, but check consequences first
# e.g. on IPTC values of search db!!!
if (($format == MICRO) and ($key eq 'Urgency')) {
$iptc .= iptc_rating_stars_urg($_).$indent;
}
else {
$iptc .= "$_$indent";
}
}
$iptc =~ s/$indent$//; # remove last indent (newline/space after last value)
$iptc .= "\n"; # newline for each defined IPTC attribute
}
}
# add Coded Character Set info
my $hash_1 = $seg->get_app13_data('TEXTUAL', 'IPTC_1');
if (defined $hash_1->{'CodedCharacterSet'}) {
my $encoding = PrintCodedCharset(${$hash_1->{'CodedCharacterSet'}}[0]);
if (($format == LONG)) {
$iptc .= sprintf "%-31s: ", 'CodedCharacterSet';
} elsif ($format == MICRO) { # show only content, no key names
} else {
$iptc .= 'CCharSet: ';
}
$iptc .= "$encoding\n";
#print "found Coded character set in $dpic: [$encoding][${$hash_1->{'CodedCharacterSet'}}[0]]\n";
}
}
}
$iptc =~ s/\s+$//; # cut trailing whitespace
$iptc =~ tr/\n -~//cd; # remove all non-printable chars, but not newline
return $iptc;
}
##############################################################
# getShortIPTC - get just one attribute of the IPTC comment
# I decided to use the caption/abstract, but
# I am not sure if this is the best attribute
# here?
# if there is no file or no IPTC info in the file
# an empty string is returned
##############################################################
sub getShortIPTC {
my $dpic = shift;
# optional, if set to LONG the complete contents of the @iptcs attributes
# (see below) will be returned
# else (SHORT) it will be cut to fit in the hlist
my $format = shift; # LONG or SHORT
return '' unless (-f $dpic);
my $info = getIPTC($dpic, SHORT);
$info = formatString($info, $config{LineLength}, $config{LineLimit}) if ((defined $format) and ($format == SHORT));
return $info;
}
##############################################################
# getImageInfo - returns a hash containing the image info
##############################################################
sub getImageInfo {
my $pic = shift;
if (!-f $pic) {
return '';
}
my $ii = image_info($pic);
if (!$ii) {
return '';
}
if ($ii->{Errno} and $ii->{Errno} ne "0") {
return '';
}
return $ii;
}
##############################################################
# getNearestItem - finds the nearest item to the mouse pointer
# in a listbox
##############################################################
sub getNearestItem {
my($LB) = @_;
my ($X,$Y) = $LB->pointerxy();
my $y = $LB->rooty();
my $yy = $Y - $y;
return ($LB->nearest($yy));
}
##############################################################
# processARGV - handels the command line arguments (if any)
##############################################################
sub processARGV {
getopts('iv'); # sets $opt_i if switch -i is found - import pictures
#getopts('v'); # sets $opt_v if switch -v is found - verbose logging
#getopts('h'); # sets $opt_h if switch -h is found - help
$verbose = 1 if ($opt_v);
my $nr = @ARGV;
if ($nr < 1) { # no arguments - open the last dir
$actdir = $config{LastDir};
dirSave($actdir);
return;
}
if ($nr > 1) { # too many arguments
print "Mapivi error: to many command line options\n";
printUsage();
exit;
}
#if ($opt_h) { # -h flag -> help
# printUsage();
# exit;
#}
my $item = abs_path($ARGV[0]);
#print "processARGV: -e $item = ", -e $item, "\n";
$item = Encode::encode('iso-8859-1', $item);
#print "processARGV: item: $item item2: $item2\n";
#print "processARGV: -e $item = ", -e $item, "\n";
if (-f $item) {
$actpic = $item;
$actdir = dirname($item);
}
elsif (-d $item) {
$actdir = $item;
}
else {
printUsage();
exit;
}
dirSave($actdir);
}
##############################################################
# re-read all meta information from picture files
##############################################################
sub reread_pics {
my $lb = shift;
my @sellist = $lb->info('selection');
# check selection args: widget, min, max, listref, itemkind (e.g. "picture")
return unless checkSelection($top, 1, 0, \@sellist, lang("picture(s)"));
$lb->Busy;
log_it("Reading meta-info of ".scalar @sellist." files ...");
foreach my $dpic (@sellist) {
updateOneRow($dpic, $lb);
}
$lb->Unbusy;
log_it("ready! (re-read ".scalar @sellist." files)");
}
##############################################################
# open_pic_folder - open the folder containing the selected pictures
##############################################################
sub open_pic_folder {
my $lb = shift;
my @sellist = $lb->info('selection');
# check selection args: widget, min, max, listref, itemkind (e.g. "picture")
return unless checkSelection($top, 1, 0, \@sellist, lang("picture(s)"));
my %folders;
# check for all possible folders
foreach my $dpic (@sellist) {
$folders{dirname($dpic)}++;
}
my $folder;
# all selected pictures are located in the same folder
if (scalar keys %folders == 1) {
$folder = $_ foreach (keys %folders);
}
# picture from different folders have been selected
else {
# todo: let the user choose which folder to open
# take the folder of the first pic
$folder = dirname($sellist[0]);
my $rc = $top->messageBox(-icon => 'question', -message => "The selected pictures are stored in ".scalar(keys(%folders))." different folders. Proceed with first folder: $folder?",
-title => "Proceed?", -type => 'OKCancel');
return if ($rc !~ m/Ok/i);
}
openDirPost($folder);
}
##############################################################
# openDir - let the user select a new dir and open it
# with a dir dialog
##############################################################
sub openDir {
my $dir = dirDialog($actdir);
openDirPost($dir);
}
##############################################################
# openDirPost - things to do when opening a new dir
##############################################################
sub openDirPost {
my $dir = shift;
$dir = Encode::encode('iso-8859-1', $dir);
$dir =~ s|\\|/|g; # perl likes slashes (/ = UNIX style) instead of backslash (\ = Windows style)
$dir =~ s/\/\//\//g; # replace all double slashes (//) with single slashes (/)
return unless (defined $dir);
return unless (-d $dir);
$actdir = $dir;
my $path = cutString($dir, -22, '..');
log_it(lang('Opening')." $path ...");
$actpic = ''; # reset var $actpic - needed to get a correct window title
setDirProperties();
dirSave($dir);
clearLabels();
clear_canvas_thumbs($c);
showImageInfoCanvas();
setTitle();
$commentText->delete( 0.1, 'end') if ($config{ShowCommentField} and defined $commentText);
# update_IPTC_frame_content(''); # now included in showImageInfoCanvas
$dirtree->configure(-directory => $actdir);
# Set the folder
exists &Tk::DirTree::chdir ? $dirtree->chdir($actdir) : $dirtree->set_dir($actdir);
selectDirInTree($actdir);
# switch display modus to folder
$act_modus = FOLDER;
updateThumbs();
}
##############################################################
# setDirProperties
##############################################################
sub setDirProperties {
$dirPropSORT = 0;
$dirPropMETA = 0;
$dirPropPRIO = 0;
$dirPropSORT = $dirProperties{$actdir}{SORT} if (defined $dirProperties{$actdir}{SORT});
$dirPropMETA = $dirProperties{$actdir}{META} if (defined $dirProperties{$actdir}{META});
$dirPropPRIO = $dirProperties{$actdir}{PRIO} if (defined $dirProperties{$actdir}{PRIO});
}
##############################################################
# showDirProperties
##############################################################
sub showDirProperties {
if (Exists($dpw)) {
$dpw->deiconify;
$dpw->raise;
$dpw->focus;
return;
}
# open window
$dpw = $top->Toplevel();
$dpw->withdraw;
$dpw->title(lang('Folder Checklist'));
$dpw->iconimage($mapiviicon) if $mapiviicon;
my $topf = $dpw->Frame()->pack();
my $topf2 = $dpw->Frame()->pack();
my $window_label = '...';
my $dplb = $dpw->Scrolled("HList",
-header => 1,
-separator => ';', # todo here we hope that ; will never be in a folder or file name
-pady => 1,
-columns => 5,
-scrollbars => 'osoe',
#-selectmode => "dragdrop", todo
-selectmode => "extended",
-background => $conf{color_bg}{value}, #8fa8bf
-width => 40,
-height => 60,
)->pack(-expand => 1, -fill => 'both');
my $count = 0;
$dplb->{dircol} = $count;
$dplb->header('create', $count++, -text => lang('Folder'), -headerbackground => $conf{color_entry}{value});
$dplb->{sortcol} = $count;
$dplb->header('create', $count++, -text => lang('1 Sort'), -headerbackground => $conf{color_entry}{value});
$dplb->{metacol} = $count;
$dplb->header('create', $count++, -text => lang('2 Meta'), -headerbackground => $conf{color_entry}{value});
$dplb->{priocol} = $count;
$dplb->header('create', $count++, -text => lang('3 Rating'), -headerbackground => $conf{color_entry}{value});
$dplb->{commcol} = $count;
$dplb->header('create', $count++, -text => lang('Comment'), -headerbackground => $conf{color_entry}{value});
my $Xbut = $topf->Button(-text => lang("Close"),
-command => sub { $dpw->withdraw; $dpw->destroy; }
)->pack(-side => 'left', -expand => 0,-fill => 'x',-padx => 3,-pady => 3);
my $upd_but = $topf->Button(-text => lang("Update"),
-command => sub {
my @dirs = $dplb->info('selection');
my $last = $dirs[-1];
$dplb->delete("all");
insertDirProperties($dplb, \$window_label);
reselect($dplb, @dirs);
$dplb->see($last) if ($dplb->info("exists", $last));;
})->pack(-side => 'left', -expand => 0,-padx => 3,-pady => 3);
$topf->Checkbutton(-text => lang("Show unfinished"),
-variable => \$config{ShowUnfinishedDirs},
-command => sub { $upd_but->Invoke; },
)->pack(-side => 'left', -expand => 0,-fill => 'x',-padx => 3,-pady => 3);
$topf->Checkbutton(-text => lang("Show finished"),
-variable => \$config{ShowFinishedDirs},
-command => sub { $upd_but->Invoke; },
)->pack(-side => 'left', -expand => 0,-fill => 'x',-padx => 3,-pady => 3);
$topf->Button(-image => $mapivi_icons{Help}, -pady => 0, -padx => 0,
-command => sub {
showText("Help for Folder Checklist", "The purpose of this list is to give an overview about all picture folders.\nThe green folders are finshed (all three merkers are set), the blue folders are unfinsihed, the red folders are missing (may have been deleted or renamed).\n\nDouble click on any folder to open it in the main window or use the context menu to set or reset any markers.", NO_WAIT);
})->pack(-expand => 0, -side => 'left', -fill => 'x', -padx => 3, -pady => 3);
$topf2->Label(-textvariable => \$window_label)->pack(-side => 'left', -expand => 0,-fill => 'x',-padx => 3,-pady => 3);
my $dpmenu = $dpw->Menu(-title => lang("Folder Checklist Menu"));
$dpmenu->command(-label => lang("Open folder"),
-command => sub {
my @dirs = $dplb->info('selection');
return unless checkSelection($dpw, 1, 1, \@dirs);
if (-d $dirs[0]) {
openDirPost($dirs[0]);
# show main window
$top->deiconify;
$top->raise;
} else {
$dplb->messageBox(-icon => 'info', -message => "Sorry, but this folder is currently not available!", -title => "Folder not available", -type => 'OK');
}
} );
$dpmenu->command(-label => lang("Add all sub folders to list"),
-command => sub {
my @dirs = $dplb->info('selection');
return unless checkSelection($dpw, 1, 1, \@dirs);
@dirs = getDirsRecursive($dirs[0]);
my $nr = 0;
foreach (@dirs) {
# todo skip empty dirs
if (!defined $dirProperties{$_}) {
print "adding $_\n" if $verbose;
$dirProperties{$_}{SORT} = 0 ;
$dirProperties{$_}{META} = 0 ;
$dirProperties{$_}{PRIO} = 0 ;
$nr++;
}
}
$upd_but->Invoke;
$dplb->messageBox(-icon => 'info', -message => "Added $nr folders.",
-title => "Added sub folders", -type => 'OK');
} );
$dpmenu->command(-label => lang("Remove selected from list"),
-command => sub {
my @dirs = $dplb->info('selection');
return unless checkSelection($dpw, 1, 0, \@dirs);
foreach my $dir (@dirs) {
delete $dirProperties{$dir};
$dplb->delete("entry", $dir) if ($dplb->info('exists', $dir));
}
} );
$dpmenu->command(-label => lang("Edit folder comment"),
-command => sub {
my @dirs = $dplb->info('selection');
return unless checkSelection($dpw, 1, 1, \@dirs);
my $text = '';
$text = $dirProperties{$dirs[0]}{COMM} if (defined $dirProperties{$dirs[0]}{COMM});
my $rc = myTextDialog("Edit comment", "Please edit comment of $dirs[0]", \$text);
return if ($rc ne 'OK');
# replace (german) umlaute by corresponding letters
$text =~ s/([$umlaute])/$umlaute{$1}/g if ($config{ConvertUmlaut});
$dirProperties{$dirs[0]}{COMM} = $text;
$dplb->itemConfigure($dirs[0], $dplb->{commcol}, -text => $dirProperties{$dirs[0]}{COMM}, -style => $fileS);
} );
my $sort_menu = $dpmenu->cascade(-label => lang("1 Sort"));
my $meta_menu = $dpmenu->cascade(-label => lang("2 Meta"));
my $prio_menu = $dpmenu->cascade(-label => lang("3 Rating"));
my $all_menu = $dpmenu->cascade(-label => lang("All"));
$sort_menu->command(-label => lang("set"), -command => sub { setProperty($dplb, 'SORT', 1); } );
$sort_menu->command(-label => lang("reset"), -command => sub { setProperty($dplb, 'SORT', 0); } );
$meta_menu->command(-label => lang("set"), -command => sub { setProperty($dplb, 'META', 1); } );
$meta_menu->command(-label => lang("reset"), -command => sub { setProperty($dplb, 'META', 0); } );
$prio_menu->command(-label => lang("set"), -command => sub { setProperty($dplb, 'PRIO', 1); } );
$prio_menu->command(-label => lang("reset"), -command => sub { setProperty($dplb, 'PRIO', 0); } );
$all_menu->command( -label => lang("set"), -command => sub { setProperty($dplb, 'ALL', 1); } );
$all_menu->command( -label => lang("reset"), -command => sub { setProperty($dplb, 'ALL', 0); } );
$dplb->bind('', sub {
$dpmenu->Popup(-popover => "cursor", -popanchor => "nw");
} );
$dplb->bind('', sub {
my @dirs = $dplb->info('selection');
return unless checkSelection($dpw, 1, 1, \@dirs);
if (-d $dirs[0]) {
openDirPost($dirs[0]);
# show main window
$top->deiconify;
$top->raise;
} else {
$dplb->messageBox(-icon => 'info', -message => "Sorry, but this folder is currently not available!", -title => "Folder not available", -type => 'OK');
}
} );
bind_exit_keys_to_button($dpw, $Xbut);
$dpw->Popup;
my $ws = 0.7; # window size is 70% of screen
my $w = int($ws * $dpw->screenwidth);
my $h = int($ws * $dpw->screenheight);
my $x = int(($dpw->screenwidth - $w)/3);
my $y = int(($dpw->screenheight - $h)/3);
$dpw->geometry("${w}x${h}+${x}+${y}");
insertDirProperties($dplb, \$window_label);
$dpw->waitWindow;
return;
}
##############################################################
# insertDirProperties
##############################################################
sub insertDirProperties {
my $lb = shift;
my $labelref = shift;
# todo: for a bright background we should use #009 #090 #900
my $normal_S = $lb->ItemStyle('text', -anchor=>'nw', -foreground=>'#88F', -background=>$conf{color_bg}{value});
my $finished_S = $lb->ItemStyle('text', -anchor=>'nw', -foreground=>'#8F8', -background=>$conf{color_bg}{value});
my $not_avail_S = $lb->ItemStyle('text', -anchor=>'nw', -foreground=>'#F88', -background=>$conf{color_bg}{value});
my $last_time;
my $finished = 0;
my $unfinished = 0;
foreach my $dir (sort { uc($a) cmp uc($b); } keys %dirProperties) {
my $style = $normal_S;
if (defined $dirProperties{$dir}{SORT} and
defined $dirProperties{$dir}{META} and
defined $dirProperties{$dir}{PRIO} and
$dirProperties{$dir}{SORT} == 1 and
$dirProperties{$dir}{META} == 1 and
$dirProperties{$dir}{PRIO} == 1) {
$style = $finished_S;
$finished++;
}
else {
$unfinished++;
}
next if (!$config{ShowFinishedDirs} and $style == $finished_S);
next if (!$config{ShowUnfinishedDirs} and $style != $finished_S);
$style = $not_avail_S unless (-d $dir);
# create new row
$lb->add($dir);
$lb->itemCreate($dir, $lb->{dircol}, -text => $dir, -style => $style);
$lb->itemCreate($dir, $lb->{sortcol}, -text => $dirProperties{$dir}{SORT}, -style => $comS);
$lb->itemCreate($dir, $lb->{metacol}, -text => $dirProperties{$dir}{META}, -style => $iptcS);
$lb->itemCreate($dir, $lb->{priocol}, -text => $dirProperties{$dir}{PRIO}, -style => $comS);
$lb->itemCreate($dir, $lb->{commcol}, -text => $dirProperties{$dir}{COMM}, -style => $iptcS);
# show progress every 0.5 seconds - idea from Slaven
if (!defined $last_time || Tk::timeofday()-$last_time > 0.5) {
$lb->update;
$last_time = Tk::timeofday();
}
}
# total number of folders
my $total = keys %dirProperties;
my $percent_finished = $finished/$total*100;
my $percent_unfinished = $unfinished/$total*100;
$$labelref = langf("%d (%2.1f%%) finished and %d (%2.1f%%) unfinished folders", $finished, $percent_finished, $unfinished, $percent_unfinished);
}
##############################################################
# showDirSizes
##############################################################
sub showDirSizes {
if (Exists($dsw)) {
$dsw->deiconify;
$dsw->raise;
$dsw->focus;
return;
}
my @dirs = @_; # just one dir at the moment, because the dir tree is configured to single selection
# will contain all dirs
my @alldirs;
my $break = 0;
my $pw = progressWinInit($top, lang("Calculate folder size"));
foreach my $dir (@dirs) {
progressWinUpdate($pw, "Collecting folders below $dir ...", 0, scalar @dirs);
# the selected folder should also been shown
push @alldirs, $dir;
# thumbnail folders and folders starting with "." are skipped
push @alldirs, getDirsRecursive($dir);
}
my %dirsize;
my %files;
my $max = 0;
my $allsize = 0;
my $dirCount = 0;
my $i = 0;
foreach my $dir (@alldirs) {
if (progressWinCheck($pw)) {
$break = 1;
last;
}
$i++;
progressWinUpdate($pw, "in folder $dir ($i/".scalar @alldirs.") ...", $i, scalar @alldirs);
my $dirsize = 0;
$dirCount++;
# get non-empty files only
my @files = getFiles($dir);
foreach my $file (@files) {
$dirsize += getFileSize("$dir/$file", NO_FORMAT);
}
$dirsize{$dir} = $dirsize;
# thumbnail folders like (.thumbs) are already excluded, see above
$files{$dir} = scalar(@files);
$max = $dirsize if ($dirsize > $max);
$allsize += $dirsize;
}
progressWinEnd($pw);
return if ($break);
# open window
$dsw = $top->Toplevel();
$dsw->title(lang('Folder Sizes'));
$dsw->iconimage($mapiviicon) if $mapiviicon;
my $label = "Starting soon";
my $Xbut = $dsw->Button(-text => lang('Close'),
-command => sub { $dsw->withdraw; $dsw->destroy; }
)->pack(-expand => 0,-fill => 'x',-padx => 1,-pady => 1);
$dsw->Label(-textvariable => \$label,
)->pack(-expand => 0,-fill => 'x',-padx => 1,-pady => 1);
my $dc_width = 700;
my $dc = $dsw->Scrolled('Canvas',
-scrollbars => 'osoe',
-width => $dc_width,
-height => 400,
-relief => 'sunken',
-bd => $config{Borderwidth})->pack(-expand => 1,-fill => 'both',-padx => 1, -pady => 1);
my $height = 16;
$dc->configure(-scrollregion => [0, 0, $dc_width, ($#alldirs * $height)]);
$max = 1 if ($max <= 0); # avoid divison by zero
my $scale = ($dc_width - 2)/$max;
my $y = 2;
my $x = 2;
my $file_total = 0;
foreach my $dir (sort keys %dirsize) {
$dc->createRectangle( $x, $y, $x + ($dirsize{$dir} * $scale), $y+$height,
-tags => ['RECT'],
#-outline => undef,
-outline => 'black',
-fill => 'goldenrod3',
);
my $filestr = sprintf "%5s", $files{$dir}; $filestr .= ' '.lang('files');
my $text = sprintf "%6s", computeUnit($dirsize{$dir});
$dc->createText( $x+1, $y+1, -text => $filestr, -anchor => 'nw');
$dc->createText( $x+80, $y+1, -text => $text, -anchor => 'nw');
$dc->createText( $x+130, $y+1, -text => $dir, -anchor => 'nw');
$y += $height;
$file_total += $files{$dir};
}
$max = computeUnit($max);
$allsize = computeUnit($allsize);
$label = scalar(@alldirs)." folders, total: $file_total files with $allsize, biggest folder size: $max";
$dsw->waitWindow;
}
##############################################################
# setProperty
##############################################################
sub setProperty {
my $lb = shift;
my $prop = shift;
my $value = shift;
my @dirs = $lb->info('selection');
return unless checkSelection($dpw, 1, 0, \@dirs);
if ((!defined $value) or ($value < 0) or ($value > 1)) {
warn "wrong value $value";
return;
}
if ((!defined $prop) or (($prop ne 'SORT') and ($prop ne 'META') and ($prop ne 'PRIO') and ($prop ne 'ALL'))) {
warn "wrong property $prop";
return;
}
foreach my $dir (@dirs) {
# set property to given value
unless ($prop eq 'ALL') {
$dirProperties{$dir}{$prop} = $value;
}
else {
$dirProperties{$dir}{SORT} = $value;
$dirProperties{$dir}{META} = $value;
$dirProperties{$dir}{PRIO} = $value;
}
# show changed property
my $style = $iptcS;
$style = $exifS if (defined $dirProperties{$dir}{SORT} and
defined $dirProperties{$dir}{META} and
defined $dirProperties{$dir}{PRIO} and
$dirProperties{$dir}{SORT} == 1 and
$dirProperties{$dir}{META} == 1 and
$dirProperties{$dir}{PRIO} == 1);
$lb->itemConfigure($dir, $lb->{dircol}, -text => $dir, -style => $style);
$lb->itemConfigure($dir, $lb->{sortcol}, -text => $dirProperties{$dir}{SORT}, -style => $comS);
$lb->itemConfigure($dir, $lb->{metacol}, -text => $dirProperties{$dir}{META}, -style => $iptcS);
$lb->itemConfigure($dir, $lb->{priocol}, -text => $dirProperties{$dir}{PRIO}, -style => $comS);
$lb->itemConfigure($dir, $lb->{commcol}, -text => $dirProperties{$dir}{COMM}, -style => $iptcS);
}
}
##############################################################
# selectDirInTree
##############################################################
sub selectDirInTree {
my $dir = shift;
$dir = Encode::encode('iso-8859-1', $dir);
$dir =~ s/\//\\/g if $EvilOS; # windows needs backslashes
$dirtree->selectionClear();
if ($dirtree->info('exists', $dir)) {
$dirtree->selectionSet($dir);
$dirtree->show('entry', $dir);
}
else {
print "selectDirInTree: neither dir $dir does not exists!\n"; # debugging
}
}
##############################################################
# dirSave - save the last used dirs, build a hotlist of
# often used dirs and update the dir menu
##############################################################
sub dirSave {
my $dir = shift;
return if ($dir eq $trashdir);
# check if dir is already in history list
my $i = 0;
foreach (@dirHist) {
if ($_ eq $dir) {
splice @dirHist, $i, 1; # throw old entry away
last;
}
$i++;
}
# add dir to history list
push @dirHist, $dir;
# no more than 10 entries in history list
if (@dirHist > 10) {
shift @dirHist;
}
# count the number of accesses to each dir
if (defined $dirHotlist{$dir}) {
$dirHotlist{$dir}++;
}
else {
$dirHotlist{$dir} = 1;
}
updateDirMenu();
}
##############################################################
# clearLabels - clear the labels containing infos about the
# actual picture
##############################################################
sub clearLabels {
# show index number in window
$nrof = '0/0 (0)';
$widthheight = '';
$size = '';
$zoomFactorStr = '';
$rating_but->configure(-image => $mapivi_icons{Rating0});
}
##############################################################
# dirDialog - open a window and a dir tree
##############################################################
sub dirDialog {
my $dir = shift;
$dir = Encode::encode('iso-8859-1', $dir);
if ($EvilOS) {
if ($win32FOAvail) {
print "FileOp is available!\n" if $verbose;
# this is untested!!! todo
$dir = BrowseForFolder("Choose folder", "CSIDL_DESKTOP");
}
else { # windows, but no win32 FileOp available
print "FileOp is not available!\n" if $verbose;
$dir = $top->chooseDirectory(-title => "Select folder", -initialdir => $dir);
}
# At least under Windows XP both encodings seem to work: 'iso-8859-1' 'windows-1252'
# todo: the correct encoding should be determined using:
# I18N::Langinfo->import(qw(langinfo CODESET));
# $codeset = langinfo(CODESET()); # note the ()
$dir = Encode::encode('windows-1252', $dir);
$dir = '' unless (defined $dir);
$dir = '' unless (-d $dir);
$dir =~ s|\\|/|g; # perl likes slashes (UNIX style) instead of backslash (Windows style)
} else { # non windows system
# code based on Tk::chooseDirectory
my $t = $top->Toplevel;
$t->withdraw;
$t->title('Open folder ...');
$t->iconimage($mapiviicon) if $mapiviicon;
my $ok = 0; # flag: "1" means OK, "0" means cancelled
# Create Frame widget before the DirTree widget, so it's always visible
# if the window gets resized.
my $f = $t->Frame->pack(-fill => 'x', -side => "bottom");
my $d;
my $mkdB = $t->Button(-text => lang('Make new folder'),
-command => sub {
my $new_dir = makeNewDir($dir, $d);
if (-d $new_dir) {
$d->see($new_dir)
}
})->pack(-fill => 'x');
$balloon->attach($mkdB, -msg => "The new folder will be created in the selected folder.\nPlease select a folder in the tree.");
$d = $t->Scrolled('DirTree',
-scrollbars => 'osoe',
-showhidden => $config{ShowHiddenDirs},
-selectmode => 'browse',
-exportselection => 1,
-browsecmd => sub {
# this function will show all subdirs when pressing on the + sign
$dir = shift;
$dir = Encode::encode('iso-8859-1', $dir);
return if (@_ >= 1);
if (!-d $dir) { print "dirDialog: $dir does not exists!\n"; return; }
$t->Busy;
my @dirs = getDirs($dir);
$t->Unbusy;
return if (@dirs < 1);
$t->Busy;
my $lastdir = $dir.'/'.$dirs[-1];
if ($d->info('exists', $lastdir)) {
$d->see($lastdir) if (-d $lastdir);
}
$t->Unbusy;
},
# With this version of -command a double-click will
# select the folder
-command => sub { $ok = 1; $t->destroy; },
# With this version of -command a double-click will
# open a folder. Selection is only possible with
# the Ok button.
#-command => sub { $d->opencmd($_[0]) },
)->pack(-fill => 'both', -expand => 1);
# Set the initial folder
exists &Tk::DirTree::chdir ? $d->chdir($dir) : $d->set_dir($dir);
$f->Button(-text => lang('Ok'),
-command => sub { $ok = 1; $t->destroy; })->pack(-side => 'left',-fill => 'x', -expand => 1);
$f->Button(-text => lang('Cancel'),
-command => sub { $ok = 0; $t->destroy; })->pack(-side => 'left',-fill => 'x', -expand => 1);
# file and dir requester should always be big! (50% of screenwidth and 90% of screenheight)
my $w = int(0.5 * $t->screenwidth);
my $h = int(0.9 * $t->screenheight);
$t->geometry("${w}x${h}+0+0");
$t->deiconify;
$t->raise;
$f->waitWindow();
$t->destroy() if (Exists($t));
$dir = '' if ($ok != 1);
}
#print "dirDialog: \"$dir\"\n";
return $dir;
}
##############################################################
# printUsage - show the user how to use mapivi
##############################################################
sub printUsage {
print "\nUsage: mapivi [-i] [file|folder]\n";
print "\n -i start with import wizard\n";
}
##############################################################
# touch - set the modification date of the given file to the
# actual date and time
##############################################################
sub touch {
my $file = shift;
my $now = time;
utime($now, $now, $file);
}
##############################################################
# addComment - add a comment to all selected pics in the given
# listbox
##############################################################
sub addComment {
my $lb = shift; # the reference to the active listbox widget
my @sellist = $lb->info('selection');
return unless checkSelection($top, 1, 0, \@sellist, lang("picture(s)"));
log_it("adding comments to ".scalar @sellist." pictures");
# check if some files are links
return if (!checkLinks($lb, @sellist));
my $info = "Please enter comment to add to the ".scalar @sellist." selected pictures";
my $text = '';
my $thumb = '';
# if just one pic should be commented we show the thumbnail and the real name
if (@sellist == 1) {
$thumb = getThumbFileName($sellist[0]);
$info = "Please enter comment to add to ".basename($sellist[0]);
}
my $rc = myTextDialog("Add comment", $info, \$text, $thumb);
return if ($rc ne 'OK' or $text eq '');
# replace (german) umlaute by corresponding letters
# (a lot of programs seem to have problems with Umlauten in comments)
$text =~ s/([$umlaute])/$umlaute{$1}/g if ($config{ConvertUmlaut});
$config{Comment} = $text; # save changed comment to global config hash
my $pw = progressWinInit($lb, "Add comment");
my $i = 0;
foreach my $dpic (@sellist) {
last if progressWinCheck($pw);
$i++;
progressWinUpdate($pw, "adding comment ($i/".scalar @sellist.") ...", $i, scalar @sellist);
next if (!checkWriteable($dpic));
addCommentToPic($text, $dpic, TOUCH); # touch thumbnail
updateOneRow($dpic, $lb);
showImageInfo($dpic) if ($dpic eq $actpic);
}
progressWinEnd($pw);
log_it("ready! ($i of ".scalar @sellist." commented)");
}
##############################################################
# black and white conversion preview
# takes one picture as input, scales it to $config{FilterPrevSize}
# and converts it to different black and white versions
# therefore all entries of %channel_mixer are used.
# Each converted picture is then displayed in a new window.
##############################################################
sub grayscale_preview {
my $dpic = shift;
return unless -f $dpic;
# check if ImageMagick convert version is at least or bigger than 6
if ((`convert 2>&1` =~ m/.*ImageMagick (\d+)\.(\d+)\.(\d+).*/) and ($1 < 6)) {
$top->messageBox(-icon => 'warning', -message => "Sorry, but for these function you need at least ImageMagick (convert) in version 6.x.x. You have $1.$2.$3.\nPlease download at http://www.imagemagick.org.", -title => "Wrong ImageMagick version ($1.$2.$3)", -type => 'OK');
return;
}
my ($pic,$dir,$suffix) = fileparse($dpic, '\.[^.]*'); # suffix = . and not-. (one dot and zero or more non-dots)
my $preview_start_pic = $trashdir.'/'.$pic.'-start';
return if (!mycopy($dpic, $preview_start_pic, OVERWRITE));
return if (!resizePic($preview_start_pic, $config{FilterPrevSize}, $config{FilterPrevSize}, 80));
# save actual values
my $red = $config{ChannelRed};
my $green = $config{ChannelGreen};
my $blue = $config{ChannelBlue};
my $versions = scalar(keys(%channel_mixer));
my $message = langf("Converting %s using all %d presets. Press %s to stop.\n",$pic,$versions,lang("Cancel"));
my $pw = progressWinInit($top, lang('Black and white preview'));
my $i = 0;
foreach my $key (sort keys %channel_mixer) {
last if progressWinCheck($pw);
$i++;
progressWinUpdate($pw, $message.langf("Converting to %s (%d/%d) ...",$key,$i,$versions),$i,$versions);
my $key_no_whitespace = $key;
$key_no_whitespace =~ s/\s+//g;
my $preview_pic = $trashdir.'/'.$pic.'_'.$key_no_whitespace.$suffix;
last if (!mycopy($preview_start_pic, $preview_pic, OVERWRITE));
# grayscalePicInt is controlled by $config{ChannelRed|Green|Blue}
$config{ChannelRed} = @{$channel_mixer{$key}}[0];
$config{ChannelGreen} = @{$channel_mixer{$key}}[1];
$config{ChannelBlue} = @{$channel_mixer{$key}}[2];
grayscalePicInt($preview_pic, PREVIEW);
showPicInOwnWin($preview_pic);
}
# restore old values
$config{ChannelRed} = $red;
$config{ChannelGreen} = $green;
$config{ChannelBlue} = $blue;
progressWinEnd($pw);
}
##############################################################
# grayscalePic
##############################################################
sub grayscalePic {
my $lb = shift; # the reference to the active listbox widget
# check if ImageMagick convert version is at least or bigger than 6
if ((`convert 2>&1` =~ m/.*ImageMagick (\d+)\.(\d+)\.(\d+).*/) and ($1 < 6)) {
$top->messageBox(-icon => 'warning', -message => "Sorry, but for these function you need at least ImageMagick (convert) in version 6.x.x. You have $1.$2.$3.\nPlease download at http://www.imagemagick.org.", -title => "Wrong ImageMagick version ($1.$2.$3)", -type => 'OK');
return;
}
my @sellist = $lb->info('selection');
return unless checkSelection($top, 1, 0, \@sellist, lang("picture(s)"));
# check if some files are links
return if (!checkLinks($lb, @sellist));
my $rc = 0;
# open window
my $win = $top->Toplevel();
$win->title(lang('Convert to black and white'));
$win->iconimage($mapiviicon) if $mapiviicon;
my $topF = $win->Frame()->pack(-expand => 1, -fill =>'both', -padx => 5);
my $picF = $topF->Frame(-height => $config{FilterPrevSize}, -width => $config{FilterPrevSize})->pack(-side => 'left', -expand => 1, -fill =>'both');
my $presetF = $topF->Frame()->pack(-side => 'left', -expand => 1, -fill =>'both');
$win->{status} = $picF->Label(-textvariable => \$win->{label})->pack();
my $w = 18;
labeledScale($win, 'top', $w, lang("Red channel (%)"), \$config{ChannelRed}, -100, 200, 1);
labeledScale($win, 'top', $w, lang("Green channel (%)"), \$config{ChannelGreen}, -100, 200, 1);
labeledScale($win, 'top', $w, lang("Blue channel (%)"), \$config{ChannelBlue}, -100, 200, 1);
my $original_pic = $sellist[0];
my $preview_start_pic = $trashdir.'/'.basename($original_pic).'-start';
my $preview_pic = $trashdir.'/'.basename($original_pic);
my $preview_photo;
my $update_button =
$win->Button(-text => lang("Update"),
-command => sub {
$win->Busy;
$win->{label} = lang("Processing preview ...");
$win->update;
return if (!mycopy($preview_start_pic, $preview_pic, OVERWRITE));
grayscalePicInt($preview_pic, PREVIEW);
$preview_photo = $win->Photo(-file => $preview_pic, -gamma => $config{Gamma});
if (not $win->{photo}) {
$win->{photo} = $picF->Label(-image => $preview_photo, -relief => 'sunken',
)->pack(-padx => 3, -pady => 3);
}
else {
$win->{photo}->configure(-image => $preview_photo);
}
$win->{label} = lang("Preview finished");
$win->Unbusy;
})->pack();
$presetF->Label(-text => lang('Presets'))->pack();
my $preset_list = $presetF->Scrolled('Listbox',
-scrollbars => 'osoe',
-selectmode => 'single',
-exportselection => 0,
-width => 20,
-height => 10,
)->pack(-expand => 1, -fill =>'both', -padx => 2, -pady => 2);
$preset_list->insert('end', (sort keys %channel_mixer));
$preset_list->bind('', sub {
my ($preset) = $preset_list->curselection();
my $key = $preset_list->get($preset);
$config{ChannelRed} = @{$channel_mixer{$key}}[0];
$config{ChannelGreen} = @{$channel_mixer{$key}}[1];
$config{ChannelBlue} = @{$channel_mixer{$key}}[2];
$update_button->invoke();
} );
$win->Checkbutton(-variable => \$config{ChannelBright}, -text => lang("Keep brightness"))->pack(-anchor=>'w', -padx => 5, -pady => 3);
my $decoF = $win->Frame()->pack(-fill =>'x', -padx => 5);
$decoF->Checkbutton(-variable => \$config{ChannelDeco},
-anchor => 'w',
-text => lang("Add border or text (not visible in preview)"))->pack(-side => 'left', -anchor => 'w', -fill => 'x', -expand => 1);
$decoF->Button(-text => lang("Options"),
-anchor => 'w',
-command => sub {decorationDialog(scalar @sellist,0);
})->pack(-side => 'left', -anchor => 'w', -padx => 3);
buttonBackup($win, 'top');
my $qs = labeledScale($win, 'top', 18, lang("Quality (%)"), \$config{PicQuality}, 10, 100, 1);
qualityBalloon($qs);
$win->Label(-text => langf("Convert %d picture(s) to black and white.\nPress OK to continue.",scalar(@sellist)))->pack();
my $but_frame = $win->Frame()->pack(-fill =>'x');
my $ok_but = $but_frame->Button(-text => 'OK',
-command => sub {
$rc = 1;
$win->withdraw();
$win->destroy();
})->pack(-side => 'left', -expand => 1, -fill => 'x', -padx => 2, -pady => 3);
my $x_but =
$but_frame->Button(-text => lang('Cancel'),
-command => sub {
$win->withdraw();
$win->destroy();
})->pack(-side => 'left', -expand => 1, -fill => 'x', -padx => 2, -pady => 3);
$win->Popup(-popover => 'cursor');
repositionWindow($win);
return if (!mycopy ($original_pic, $preview_start_pic, OVERWRITE));
return if (!resizePic($preview_start_pic, $config{FilterPrevSize}, $config{FilterPrevSize}, 80));
return if (!mycopy ($preview_start_pic, $preview_pic, OVERWRITE));
$update_button->invoke();
$win->waitWindow;
$preview_photo->delete if $preview_photo;
grayscale_pics($lb, \@sellist) if ($rc);
return;
}
##############################################################
# convert a list of pictures to black and white
##############################################################
sub grayscale_pics {
my $lb = shift; # the reference to the active listbox widget
my $pic_list = shift; # array ref
log_it("converting ".scalar @$pic_list." picture(s) to black and white");
my $pw = progressWinInit($lb, lang('Convert to black and white'));
my $i = 0;
foreach my $dpic (@$pic_list) {
last if progressWinCheck($pw);
progressWinUpdate($pw, "converting ($i/".scalar @$pic_list.") this may take a while ...", $i, scalar @$pic_list);
next if (!checkWriteable($dpic));
next if (!makeBackup($dpic));
grayscalePicInt($dpic, NO_PREVIEW);
$i++;
progressWinUpdate($pw, "converting ($i/".scalar @$pic_list.") ...", $i, scalar @$pic_list);
updateOneRow($dpic, $lb);
showImageInfo($dpic) if ($dpic eq $actpic);
showPic($dpic) if ($dpic eq $actpic); # redisplay the picture if it is the actual one
}
progressWinEnd($pw);
reselect($lb, @$pic_list);
log_it("ready! ($i of ".scalar @$pic_list." converted)");
generateThumbs(ASK, SHOW);
}
##############################################################
# grayscalePicInt - $dpic will be overwritten!
##############################################################
sub grayscalePicInt {
my $dpic = shift;
my $preview = shift;
my $sum = 100;
if ($config{ChannelBright}) {
$sum = $config{ChannelRed}+$config{ChannelGreen}+$config{ChannelBlue};
}
$sum = 1 if ($sum == 0); # avoid division by zero
my $command = "convert ";
$command .= " \"$dpic\" -fx \"(r*$config{ChannelRed}+g*$config{ChannelGreen}+b*$config{ChannelBlue})/$sum\" ";
# windows needs the " instead of '
#\'(r*$config{ChannelRed}+g*$config{ChannelGreen}+b*$config{ChannelBlue})/$sum\' ";
$command .= makeDrawOptions($dpic) if ($config{ChannelDeco} and !$preview);
$command .= " \"$dpic\" ";
print "grayscalePicInt: command: $command\n" if $verbose;
execute($command);
}
##############################################################
# updateOneRow - update the (changed) metainfo of one picture
# in the given listbox and store them in the
# search database
##############################################################
sub updateOneRow {
my $dpic = shift; # pic with path
my $lb = shift; # the listbox reference
# reselect does not work for the light table
return if (ref($lb) eq 'Tk::Canvas');
return unless (-f $dpic);
# check if listbox entry exists
unless ($lb->info('exists', $dpic)) {
#warn "entry $dpic not found in listbox!";
return;
}
my $meta = addToSearchDB($dpic); # save meta data of picture into the search data base
my $com = $searchDB{$dpic}{COM};
my $exif = date_iso_to_relative($searchDB{$dpic}{EXIF});
my $iptc = displayIPTC($dpic);
$com = formatString($com, $config{LineLength}, $config{LineLimit}); # format the comment for the list
$iptc = formatString($iptc, $config{LineLength}, $config{LineLimit}); # format the IPTC info for the list
my $rating_size = get_rating_and_size($dpic, $lb);
# update the metainfo in the listbox
$lb->itemConfigure($dpic, $lb->{thumbcol}, -text => getThumbCaption($dpic)) if (defined $lb->{thumbcol});
$lb->itemConfigure($dpic, $lb->{comcol}, -text => $com) if (defined $lb->{comcol});
$lb->itemConfigure($dpic, $lb->{exifcol}, -text => $exif) if (defined $lb->{exifcol});
$lb->itemConfigure($dpic, $lb->{iptccol}, -text => $iptc) if (defined $lb->{iptccol});
#$lb->itemConfigure($dpic, $lb->{filecol}, -text => $size) if (defined $lb->{filecol});
$lb->itemConfigure($dpic, $lb->{filecol}, -itemtype => "image", -image => $rating_size, -style => $fileS) if (defined $lb->{filecol});
}
##############################################################
# addCommentToPic - add a comment to a single picture
##############################################################
sub addCommentToPic {
my $com = shift;
my $dpic = shift;
my $touch = shift; # TOUCH = touch thumbnail, NO_TOUCH
return if (!-f $dpic);
# check if file is a link and get the real target
return if (!getRealFile(\$dpic));
my $meta = getMetaData($dpic, "COM");
return unless ($meta);
printf "addCommentToPic: %-30s %s\n", cutString($com,30,".."), $dpic if $verbose;
#$com = encode("utf8", $com);
$meta->add_comment($com);
unless ($meta->save()) { warn "addCommentToPic: save $dpic failed!"; }
# touch the thumbnail pic (set actual time stamp), to suppress rebuilding the next time
touch(getThumbFileName($dpic)) if ($touch == TOUCH);
addToSearchDB($dpic);
}
##############################################################
# replaceComment - search/replace a string in a comment to all
# selected pics in the given listbox
##############################################################
sub replaceComment {
my $lb = shift; # the reference to the active listbox widget
my @sellist = $lb->info('selection');
return unless checkSelection($top, 1, 0, \@sellist, lang("picture(s)"));
log_it("replacing comments in ".scalar @sellist." pictures");
# check if some files are links
return if (!checkLinks($lb, @sellist));
my $info = "Please enter the string to replace in the ".scalar @sellist." selected pictures";
my $stext = $config{SearchPattern}; # search string
my $rtext = ''; # replace string
# if just one pic should be commented we show the real name
if (@sellist == 1) {
$info = "Please enter the string to replace in ".basename($sellist[0]);
}
my $test = 1;
my $i = 0;
while ($test) {
# todo: one search/replace dialog with upper/lower case support
my $rc = myReplaceDialog("Replace comment", $info, \$stext, \$rtext);
return if (($rc eq 'Cancel') or ($stext eq ''));
$test = 0 if ($rc eq 'OK');
$config{SearchPattern} = $stext;
# replace (german) umlaute by corresponding letters
# (a lot of programs seem to have problems with Umlauten in comments)
$stext =~ s/([$umlaute])/$umlaute{$1}/g if ($config{ConvertUmlaut});
$rtext =~ s/([$umlaute])/$umlaute{$1}/g if ($config{ConvertUmlaut});
my $spat = makePattern($stext);
$config{Comment} = $rtext; # save changed comment to global config hash
my $nocom = '';
my $nostr = '';
my $countComments = 0;
my $countFiles = 0;
my $pw = progressWinInit($lb, "Replace comments");
foreach my $dpic (@sellist) {
last if progressWinCheck($pw);
$i++;
progressWinUpdate($pw, "replacing comments ($i/".scalar @sellist.") ...", $i, scalar @sellist);
my $pic = basename($dpic);
print "replaceComment: pic:$pic\n" if $verbose;
next if (!checkWriteable($dpic));
my $meta = getMetaData($dpic, "COM");
unless ($meta) {
$nocom .= "$dpic\n";
next;
}
my @com = getComments($dpic, $meta); # get all comments from the file
unless (@com) {
$nocom .= "$dpic\n";
next;
}
my $replace = 0;
for my $j (0 .. $#com) {
if ($com[$j] =~ m/$spat/) { # todo handle lower/uppercase
unless ($test) {
print "replacing $stext with $rtext in $pic: -$com[$j]- " if $verbose;
$com[$j] =~ s/$spat/$rtext/g;
print "to -$com[$j]-\n" if $verbose;
$meta->set_comment($j, $com[$j]);
}
$replace++;
$countComments++;
}
}
if ($replace > 0) {
unless ($test) {
unless ($meta->save()) {
warn "replaceComment: save $pic failed!";
}
# touch the thumbnail pic (set actual time stamp), to suppress rebuilding the next time
touch(getThumbFileName($dpic));
updateOneRow($dpic, $lb);
}
$countFiles++;
} else {
$nostr .= "$dpic\n";
}
}
progressWinEnd($pw);
# short the strings for better output
my $stextd = cutString($stext, 20, "..");
my $rtextd = cutString($rtext, 20, "..");
my $text = "Replaced ";
$text = "Test mode:\nMapivi would replace " if $test;
$text .= "the string \"$stextd\" with \"$rtextd\"\nin $countComments comments of $countFiles pictures\n\n";
if (($nocom ne '') or ($nostr ne '')) {
$text .= "Found no comments in these pictures:\n$nocom\n" if ($nocom ne '');
$text .= "Found no string matching \"$stextd\" in these pictures:\n$nostr\n" if ($nostr ne '');
}
showText("Replace comment log", $text, WAIT);
}
log_it("ready! ($i of ".scalar @sellist." pictures processed)");
}
##############################################################
# nameToComment - add the filename as comment to all selected
# pictures
##############################################################
sub nameToComment {
my @sellist = $picLB->info('selection');
return unless checkSelection($top, 1, 0, \@sellist, lang("picture(s)"));
my $selected = @sellist;
my $dia = $top->DialogBox(-title => "Add filename to comment",
-buttons => ['OK', 'Cancel']);
$dia->add("Label", -text => "This function will add a comment containing\nthe individual filename of $selected pictures!", -bg => $conf{color_bg}{value}, -justify => 'left')->pack;
$dia->add("Checkbutton", -text => "Remove suffix (.jpg)", -variable => \$config{NameComRmSuffix})->pack;
my $rc = $dia->Show();
$top->focusForce;
return if ($rc ne 'OK');
log_it("adding filename as comment of $selected pictures");
# check if some files are links
return if (!checkLinks($picLB, @sellist));
my $pw = progressWinInit($top, "Adding file name as comment");
my $i = 0;
foreach my $dpic (@sellist) {
last if progressWinCheck($pw);
$i++;
progressWinUpdate($pw, "Adding file name ($i/$selected) ...", $i, $selected);
my $pic = basename($dpic);
my $com = $pic;
next if (!checkWriteable($dpic));
if (($config{NameComRmSuffix}) and ($pic =~ /(.*)(\.jp(g|eg))/i)) {
$com = $1; # remove .jp(e)g suffix
}
# check if file is a link and get the real target
next if (!getRealFile(\$dpic));
my $meta = getMetaData($dpic, "COM");
next unless ($meta);
$meta->add_comment($com);
unless ($meta->save()) { warn "nameToComment: save $pic failed!"; }
# touch the thumbnail pic (set actual time stamp), to suppress rebuilding the next time
touch(getThumbFileName($dpic));
updateOneRow($dpic, $picLB);
showImageInfo($dpic) if ($dpic eq $actpic);
}
progressWinEnd($pw);
log_it("ready! ($i of $selected processed)");
}
##############################################################
# showComment - show the comment of all selected pictures
##############################################################
sub showComment {
my @sellist = $picLB->info('selection');
return unless checkSelection($top, 1, 0, \@sellist, lang("picture(s)"));
return unless askSelection(\@sellist, 10, "comment");
my $selected = @sellist;
my $nocomment = '';
log_it("displaying JPEG comments of $selected pictures");
my $pw = progressWinInit($top, "Display comments");
my $i = 0;
foreach my $dpic (@sellist) {
last if progressWinCheck($pw);
$i++;
progressWinUpdate($pw, "displaying comment ($i/$selected) ...", $i, $selected);
my $pic = basename($dpic);
# check if file is a link and get the real target
next if (!getRealFile(\$dpic));
my @comments = getComments($dpic);
my $comment = '';
foreach (@comments) {
$comment .= "$_\n";
}
my $plural;
(@comments > 1) ? ($plural = "s") : ($plural = '');
if ($comment ne '') {
showText("$pic contains ".scalar @comments." comment$plural", $comment, NO_WAIT, getThumbFileName($dpic));
}
else {
$nocomment .= "$pic\n";
}
}
progressWinEnd($pw);
if ($nocomment ne '') {
showText("no comments", "no comments in:\n$nocomment", NO_WAIT);
}
log_it("ready! ($i of $selected displayed)");
}
my %logo; # hash to hold all logo data
# todo: just a workaround until settings are saved to the Mapivi configuration
##############################################################
##############################################################
sub logo_set_defaults {
my $logo = shift; # hash ref
$$logo{text} = $conf{logo_text}{value};
$$logo{size_x} = 500;
$$logo{size_y} = 100;
$$logo{color_bg} = 'white';
$$logo{font_size} = $conf{logo_font_size}{value};
$$logo{offset_x} = 25;
$$logo{offset_y} = 65;
$$logo{shadow} = $conf{logo_shadow}{value};
$$logo{offset_shadow} = 5;
$$logo{font} = $conf{logo_font}{value};
$$logo{outfile} = "$actdir/logo.jpg";
$$logo{color_font} = $conf{logo_font_color}{value};
$$logo{color_shadow} = $conf{logo_shadow_color}{value};
}
##############################################################
##############################################################
sub logo_save_defaults {
my $logo = shift; # hash ref
# we don't save all, but the most important settings
$conf{logo_text}{value} = $$logo{text};
$conf{logo_font_size}{value} = $$logo{font_size};
$conf{logo_shadow}{value} = $$logo{shadow};
$conf{logo_font}{value} = $$logo{font};
$$logo{outfile} = "$actdir/logo.jpg";
$conf{logo_font_color}{value} = $$logo{color_font};
$conf{logo_shadow_color}{value} = $$logo{color_shadow};
}
##############################################################
# generate a text logo using image magick - dialog window
##############################################################
sub logo_generate_win {
# open window
my $win = $top->Toplevel();
$win->title('Generate Text Logo');
$win->iconimage($mapiviicon) if $mapiviicon;
my $preview_button;
my @imfonts = getImageMagickFonts();
logo_set_defaults(\%logo) if (not defined $logo{text});
# set font to a valid value (in this case the first font in the list)
# if font is not available
$logo{font} = $imfonts[0] if (not isInList($logo{font}, \@imfonts));
# text frame
my $textf = $win->Frame(-bd => 1, -relief => 'groove')->pack(-fill => 'x', -padx => 3, -pady => 6);
my $eframe = labeledEntry($textf, 'top', 19, "Logo text", \$logo{text});
$eframe->{entry}->bind('', sub {
$logo{size_x} = int($logo{font_size}*(length($logo{text})*0.7)+1) + $logo{offset_x};
$preview_button->Invoke();
});
# font frame
my $fontf = $win->Frame(-bd => 1, -relief => 'groove')->pack(-expand => 0, -fill => 'x', -padx => 3, -pady => 3);
my $ff = $fontf->Frame()->pack(-fill => 'x', -padx => 6, -pady =>3);
$ff->Label(-text => 'Font', -width => 19, -anchor => 'w')->pack(-side => 'left');
$ff->Button(-textvariable => \$logo{font}, -command => sub {
my ($ok, $font) = image_magick_select_font();
if ($ok) {
$logo{font} = $font;
$preview_button->Invoke();
}
})->pack(-expand => 0, -side => 'left', -fill => 'x');
labeledScale($fontf, 'top', 19, 'Font size (point)', \$logo{font_size}, 6, 300, 1, sub {
$logo{offset_x} = int($logo{font_size}*0.2);
$logo{offset_y} = int($logo{font_size}*0.9);
$logo{size_x} = int($logo{font_size}*(length($logo{text})*0.7)+1) + $logo{offset_x};
$logo{size_y} = int($logo{font_size}*1.3);
$logo{offset_shadow} = int($logo{font_size}*0.06);});
labeledEntryColor($fontf,'top',19,"Font color",'Set',\$logo{color_font});
my $bgce = labeledEntryColor($fontf,'top',19,"Background color",'Set',\$logo{color_bg});
$balloon->attach($bgce, -msg => "Select logo background color.\nHint: Enter string \"none\" to get a transparent background.\nTransparent colors are not supported by JPEG, but e.g. by PNG pictures.");
# file name
labeledEntry($win, 'top', 19, "Logo file", \$logo{outfile});
# shadow frame
#my $shadf = $win->Frame(-bd => 1, -relief => 'groove')->pack(-fill => 'x', -padx => 3, -pady => 3);
# shadow options frame (optinal)
my $shadfopt = $win->Frame(-bd => 1, -relief => 'groove');
my $show_shadfopt = 0;
my $show_shadfoptb;
$show_shadfoptb = $win->Checkbutton(-text => "Show shadow settings", -variable => \$show_shadfopt,
-command => sub {
if ($show_shadfopt) {
$shadfopt->pack(-after => $show_shadfoptb, -fill => 'x', -padx => 3, -pady => 3);
}
else { $shadfopt->packForget(); }})->pack(-anchor => 'w');
$shadfopt->Checkbutton(-text => "Add a shadow", -variable => \$logo{shadow})->pack(-anchor => 'w');
labeledScale($shadfopt, 'top', 19, 'Shadow offset (pixel)', \$logo{offset_shadow}, 0, 100, 1);
labeledEntryColor($shadfopt,'top',19,"Shadow color",'Set',\$logo{color_shadow});
# position frame
my $posf = $win->Frame(-bd => 1, -relief => 'groove');
my $show_pos = 0;
my $show_posb;
$show_posb = $win->Checkbutton(-text => "Show size/position settings", -variable => \$show_pos,
-command => sub {
if ($show_pos) {
$posf->pack(-after => $show_posb,-fill => 'x', -padx => 3, -pady => 3);
}
else { $posf->packForget(); }})->pack(-anchor => 'w');
my $maxsize = 3000;
labeledScale($posf, 'top', 19, 'Logo width (pixel)', \$logo{size_x}, 10, $maxsize, 1);
labeledScale($posf, 'top', 19, 'Logo height (pixel)', \$logo{size_y}, 10, $maxsize, 1);
my $xs = labeledScale($posf, 'top', 19, 'offset x', \$logo{offset_x}, 0, $maxsize/2, 1);
$balloon->attach($xs, -msg => "Offset from first letter to left side of logo in pixel");
my $ys = labeledScale($posf, 'top', 19, 'offset y', \$logo{offset_y}, 0, $maxsize/2, 1);
$balloon->attach($ys, -msg => "Offset of text baseline from top of logo in pixel");
# preview frame
my $c; # canvas widget
my $pf = $win->Frame()->pack(-expand => 1, -fill => 'both', -padx => 3);
$preview_button = $pf->Button(-image => $mapivi_icons{'Update'},
-command => sub {
$c->delete('all');
my $outfile = $logo{outfile}; # save file name ...
$logo{outfile} = "$trashdir/logoXYZ554.jpg"; # will be overwritten
logo_generate(\%logo);
if (-f $logo{outfile}) {
$win->{preview} = $win->Photo(-file => $logo{outfile});
if ($win->{preview}) {
# insert pic
$c->createImage(0,0, -image => $win->{preview}, -anchor => 'nw');
my ($w, $h) = getSize($logo{outfile});
$c->configure(-scrollregion => [0, 0, $w, $h]);
}
else {
print "Could not create photo object from $logo{outfile}\n";
}
}
else {
print "Logo preview file $logo{outfile} not available.\n";
}
$logo{outfile} = $outfile; # ... restore file name
})->pack(-side => 'left');
$c = $pf->Scrolled("Canvas", -width => 600, -height => 250, -scrollbars => 'osoe')->pack(-expand => 1, -fill => 'both', -side => 'left');
# button frame
my $butF1 = $win->Frame()->pack(-fill =>'x', -padx => 3, -pady => 3);
# OK Button
$butF1->Button(-text => lang('Ok'),
-command => sub {
if (-f $logo{outfile}) {
my $rc = $win->Dialog( -title => "File exists",
-text => "$logo{outfile} already exists!",
-buttons => ['Overwrite', 'Cancel'])->Show();
return if ($rc ne 'Overwrite');
}
logo_generate(\%logo);
log_it("Logo generated");
deleteCachedPics($logo{outfile}); # force reloading
my $dir = dirname($logo{outfile});
if ($actdir ne $dir) {
openDirPost($dir);
}
else {
updateThumbs();
}
showPic($logo{outfile});
# clean up preview photo object (free mem)
$win->{preview}->delete if ($win->{preview});
logo_save_defaults(\%logo);
# close window
$win->destroy();
})->pack(-side => 'left', -expand => 1, -fill => 'x', -padx => 3, -pady => 3);
my $Xbut = $butF1->Button(-text => lang('Cancel'),
-command => sub {
# clean up preview photo object (free mem)
$win->{preview}->delete if ($win->{preview});
$win->destroy();
})->pack(-side => 'left', -expand => 1, -fill => 'x', -padx => 3, -pady => 3);
bind_exit_keys_to_button($win, $Xbut);
$win->Popup();
$preview_button->Invoke();
#repositionWindow($win);
$win->waitWindow;
}
##############################################################
# generate a text logo using image magick - overwrites outfile without warning!!! so better check before!
##############################################################
sub logo_generate {
my $logo = shift; # hash ref
my $font_coords = "+".($$logo{offset_x}+0)."+".($$logo{offset_y}+0); # force numeric context (+0)
my $shadow_coords = "+".($$logo{offset_x}+$$logo{offset_shadow})."+".($$logo{offset_y}+$$logo{offset_shadow});
my $command = "convert -size $$logo{size_x}x$$logo{size_y} xc:\"$$logo{color_bg}\" -font \"$$logo{font}\" ";
$command .= "-pointsize $$logo{font_size} ";
# shadow
$command .= "-fill \"$$logo{color_shadow}\" -annotate $shadow_coords \"$$logo{text}\" -blur 0x4 " if ($$logo{shadow});
# text
$command .= "-fill \"$$logo{color_font}\" -annotate $font_coords \"$$logo{text}\" ";
# outfile
$command .= "\"$$logo{outfile}\"";
print "com=$command\n" if $verbose;
execute($command);
my $comment = "Logo generated by Mapivi $version ($mapiviURL):\n".$command;
addCommentToPic($comment, $logo{outfile}, NO_TOUCH);
}
##############################################################
# addDecoration
##############################################################
sub addDecoration {
return if (!checkExternProgs("addDecoration", "mogrify"));
my $index = shift;
my @sellist;
if ((defined $index) and ($index >= 0) and ($index < $picLB->info('children'))) {
push @sellist, $index;
}
else {
@sellist = $picLB->info('selection');
}
my $selected = @sellist;
return unless checkSelection($top, 1, 0, \@sellist, lang("picture(s)"));
log_it("adding decorations to $selected pictures");
# check if some files are links
return if (!checkLinks($picLB, @sellist));
return if (!decorationDialog($selected,1));
my $pw = progressWinInit($top, "Adding decoration");
my $i = 0;
foreach my $dpic (@sellist) {
last if progressWinCheck($pw);
$i++;
progressWinUpdate($pw, "adding decorations ($i/$selected) ...", $i, $selected);
# check if file is a link and get the real target
next if (!getRealFile(\$dpic));
next if (!checkWriteable($dpic));
next if (!makeBackup($dpic));
my $command = "mogrify ".makeDrawOptions($dpic)."-quality ".$config{PicQuality}." \"$dpic\"";
execute($command);
addDropShadow($dpic);
deleteCachedPics($dpic);
showPic($dpic) if ($dpic eq $actpic); # redisplay the picture if it is the actual one
updateOneRow($dpic, $picLB);
}
progressWinEnd($pw);
reselect($picLB, @sellist);
log_it("ready! ($i of $selected)");
generateThumbs(ASK, SHOW);
}
##############################################################
# addDropShadow - to be called after makeDrawOptions and
# mogrify
# operates on the pic directly
# a backup has to be made before
##############################################################
sub addDropShadow {
my $dpic = shift;
return unless (-f $dpic);
return unless ($config{DropShadow});
my $b4 = $config{DropShadowWidth} * 4;
my $b3 = $config{DropShadowWidth} * 3;
my $command = "convert -depth 8 -colors 1 -gamma 0 \"$dpic\" -bordercolor \"".$config{DropShadowBGColor}."\" -border ${b4}x${b4} -gaussian 0x".$config{DropShadowBlur}." -shave ${b3}x${b3} - | composite -quality ".$config{PicQuality}." -gravity northwest \"$dpic\" - \"$dpic\"";
#(system "$command") == 0 or warn "$command failed: $!";
print "addDropShadow: $command\n" if $verbose;
execute($command);
}
##############################################################
# makeDrawOptions
##############################################################
sub makeDrawOptions {
my $dpic = shift;
my $command = '';
my $x = $config{CopyX};
my $y = $config{CopyY};
if ($config{BorderAdd}) {
$command .= '-bordercolor "'.$config{BorderColor1}.'" -border '.$config{BorderWidth1x}.'x'.$config{BorderWidth1y}.' ';
$command .= '-bordercolor "'.$config{BorderColor2}.'" -border '.$config{BorderWidth2x}.'x'.$config{BorderWidth2y}.' ' if (($config{BorderWidth2x} > 0) or ($config{BorderWidth2y} > 0));
$command .= '-bordercolor "'.$config{BorderColor3}.'" -border '.$config{BorderWidth3x}.'x'.$config{BorderWidth3y}.' ' if (($config{BorderWidth3x} > 0) or ($config{BorderWidth3y} > 0));
$command .= '-bordercolor "'.$config{BorderColor4}.'" -border '.$config{BorderWidth4x}.'x'.$config{BorderWidth4y}.' ' if (($config{BorderWidth4x} > 0) or ($config{BorderWidth4y} > 0));
}
if ($config{CopyAdd}) {
if ($config{CopyTextOrLogo} eq "text") { # text
$command .= "-gravity $config{CopyPosition} ";
my $geo1 = ($x+5).",".($y+5);
my $geo2 = "$x,$y";
print "drawoptions: x = $x y = $y geo1 = $geo1 geo2 = $geo2\n" if $verbose;
$command .= "-font \"$config{CopyFontFamily}\" -pointsize $config{CopyFontSize} ";
$command .= "-fill \"$config{CopyFontColBG}\" -annotate $geo1 \"$config{Copyright}\" " if $config{CopyFontShadow};
$command .= "-fill \"$config{CopyFontColFG}\" -annotate $geo2 \"$config{Copyright}\" ";
print "com=$command\n";
}
else { # logo image
my ($lw, $lh) = getSize($config{CopyrightLogo});
my ($pw, $ph) = getSize($dpic);
if ($config{BorderAdd}) { # calc new size of pic (including borders)
$pw += 2 * $config{BorderWidth1x};
$pw += 2 * $config{BorderWidth2x};
$pw += 2 * $config{BorderWidth3x};
$ph += 2 * $config{BorderWidth1y};
$ph += 2 * $config{BorderWidth2y};
$ph += 2 * $config{BorderWidth3y};
}
if ($config{CopyPosition} eq 'NorthEast') {
$x = $pw - $lw - $x;
} elsif ($config{CopyPosition} eq 'North') {
$x = $pw/2 - $lw/2 - $x;
} elsif ($config{CopyPosition} eq 'SouthWest') {
$y = $ph - $lh - $y;
} elsif ($config{CopyPosition} eq 'South') {
$y = $ph - $lh - $y;
$x = $pw/2 - $lw/2 - $x;
} elsif ($config{CopyPosition} eq 'SouthEast') {
$y = $ph - $lh - $y;
$x = $pw - $lw - $x;
}
$x = int($x); $y = int($y);
my $geo = "$x,$y";
$command .= "-draw \"image Over $geo $lw,$lh '".$config{CopyrightLogo}."'\" ";
}
}
print "command == $command\n";# if $verbose;
return $command;
}
##############################################################
# buildBackupName
##############################################################
sub buildBackupName {
my $dpic = shift;
my ($pic,$dir,$suffix) = fileparse($dpic, '\.[^.]*'); # suffix = . and not-. (one dot and zero or more non-dots)
my $bpic = "${dir}${pic}-bak$suffix";
return $bpic;
}
##############################################################
# makeBackup
##############################################################
sub makeBackup {
my $dpic = shift;
return 0 if (!-f $dpic);
return 1 if (!$config{MakeBackup});
my $dir = dirname($dpic);
my $dthumb = getThumbFileName($dpic);
my $bpic = buildBackupName($dpic);
# make a backup file
if (!mycopy($dpic, $bpic, ASK_OVERWRITE)) {
my $rc =
$top->messageBox(-icon => 'question', -message => "Proceed anyway?",
-title => "Proceed?", -type => 'OKCancel');
if ($rc =~ m/Ok/i) {
return 1;
}
else {
return 0;
}
}
# copy the thumbnail too
mycopy($dthumb, getThumbFileName($bpic), OVERWRITE);
if (!-f $bpic) {
warn "backup failed, there is no $bpic, giving up ...";
return 0;
}
else {
# copy meta info in search database (needed e.g. for nr. of views)
$searchDB{$bpic} = $searchDB{$dpic};
# insert backup bpic in listbox with thumbnail after dpic
addOneRow($picLB, $bpic, 1, $dpic);
}
return 1;
}
##############################################################
##############################################################
sub get_image_magick_version {
# get ImageMagick version
if (`convert 2>&1` =~ m/.*ImageMagick (\d+)\.(\d+)\.(\d+).*/) {
return (1,$1,$2,$3);
}
return 0;
}
##############################################################
##############################################################
sub image_magick_select_font {
# open window
my $win = $top->Toplevel();
$win->title('Select Font');
$win->iconimage($mapiviicon) if $mapiviicon;
my @imfonts = getImageMagickFonts();
my $w = 300;
my $h = 26;
$win->Label(-text => 'Click on font to select')->pack(-padx => 3, -pady => 3);
my $c = $win->Scrolled("Canvas", -width => $w+20, -height => 600, -scrollbars => 'osoe')->pack(-expand => 1, -fill => 'both');
$c->configure(-cursor => "hand2");
$win->Popup;
my %logo; # data structure
$logo{size_x} = $w;
$logo{size_y} = $h;
$logo{font_size} = int($h*4/5);
$logo{offset_x} = 2;
$logo{offset_y} = int($h*0.8);
$logo{shadow} = 0;
$logo{offset_shadow} = 5;
$logo{color_font} = 'black';
$logo{color_shadow} = 'gray20';
my $y = 0;
my %pics; # hash to store all photo object todo: delete after usage
my $pw = progressWinInit($win, 'Building font preview ...');
my $i = 0;
my $ok = 0;
my $sel_font = '';
foreach my $font (@imfonts) {
last if progressWinCheck($pw);
$i++;
progressWinUpdate($pw, "Font: $font ($i/".scalar @imfonts.") ...", $i, scalar @imfonts);
$logo{text} = $font;
$logo{font} = $font;
$logo{outfile} = "$trashdir/$font.jpg";
if (not -f $logo{outfile}) {
logo_generate(\%logo);
}
$pics{$font} = $win->Photo(-file => $logo{outfile}) if (-f $logo{outfile});
if ($pics{$font}) {
my $id = $c->createImage(0, $y, -image => $pics{$font}, -anchor => "nw", -tags => "$font");
my ($x1, $y1, $x2, $y2) = $c->bbox($id);
$c->configure(-scrollregion => [0, 0, $x2, $y2]);
$c->bind(+"$font", '', sub { $sel_font = $font; $ok = 1; $win->destroy;});
$y += $h+1;
}
}
progressWinEnd($pw);
$win->waitWindow();
return ($ok, $sel_font);
}
##############################################################
# getImageMagickFonts - get the font families supported by IM
##############################################################
sub getImageMagickFonts {
return if (!checkExternProgs('getImageMagickFonts', 'identify'));
my ($ok, $im1, $im2, $im3) = get_image_magick_version();
if (not $ok) {
warn "Could not get Image Magick version number!\n";
return;
}
# the API changed with version 6.3.5-7
my $fonts;
if ($im1*100+$im2*10+$im3 <= 635) {
print "old image magick version <= 635 $im1.$im2.$im3\n" if $verbose;
$fonts = `identify -list type`;
} else {
print "new image magick version > 635 $im1.$im2.$im3\n" if $verbose;
$fonts = `identify -list font`;
}
my %families;
my @lines = split(/\n/, $fonts);
foreach my $line (@lines) {
#print "line = $line\n";
# \s = whitespace \S = non-whitespece \d = number
if ($line =~ m |(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\d+)|) {
$families{$2} = 1;
}
if ($line =~ m |Font: (\S+)|) {
$families{$1} = 1;
}
}
my @font_families = sort keys(%families);
#print "font_families: $_\n" foreach (@font_families);
return @font_families;
}
my $decoW;
##############################################################
# decorationDialog
##############################################################
sub decorationDialog {
if (Exists($decoW)) {
$decoW->deiconify;
$decoW->raise;
return;
}
my $pics = shift;
my $QandB = shift; # bool - show Quality-Scale and Backup-Checkbutton
my $rc = 0;
my $max = 1000;
#my @fontFamilies = sort $top->fontFamilies;
my @fontFamilies = getImageMagickFonts();
# open window
$decoW = $top->Toplevel();
$decoW->title('Add border/copyright/shadow');
$decoW->iconimage($mapiviicon) if $mapiviicon;
my $addF = $decoW->Frame(-bd => $config{Borderwidth}, -relief => 'groove')->pack(-anchor => 'w', -fill => 'x', -padx => 5, -pady => 3);
$addF->Label(-text => "Process $pics pictures", -bg => $conf{color_bg}{value})->pack(-side => 'left', -anchor => 'w', -fill => 'x', -padx => 5, -pady => 3);
$addF->Label(-text => "Add ", -bg => $conf{color_bg}{value})->pack(-side => 'left', -anchor => 'w');
$addF->Checkbutton(-text => "border ", -variable => \$config{BorderAdd})->pack(-side => 'left', -anchor => 'w');
$addF->Checkbutton(-text => "copyright info ", -variable => \$config{CopyAdd})->pack(-side => 'left', -anchor => 'w');
$addF->Checkbutton(-text => "drop shadow", -variable => \$config{DropShadow})->pack(-side => 'left', -anchor => 'w');
my $notebook =
$decoW->NoteBook(#-width => 500,
-background => $conf{color_bg}{value}, # background of active page (including its tab)
-inactivebackground => $conf{color_entry}{value}, # tabs of inactive pages
-backpagecolor => $conf{color_bg}{value}, # background behind notebook
)->pack(-expand => "yes",
-fill => 'both',
-padx => 5, -pady => 5);
my $cF = $notebook->add("border", -label => "Border");
my $bF = $notebook->add("copy", -label => "Copyright");
my $dF = $notebook->add("shadow", -label => "Drop shadow");
if ($QandB) {
my $qS = labeledScale($decoW, 'top', 19, lang("Quality (%)"), \$config{PicQuality}, 10, 100, 1);
qualityBalloon($qS);
buttonBackup($decoW, 'top');
buttonComment($decoW, 'top');
}
# ### copyright ###
my $pfa = $bF->Frame()->pack(-anchor => 'w');
$pfa->Label(-text => "Position in picture", -bg => $conf{color_bg}{value})->pack(-side => 'left', -anchor => 'w', -padx => 3);
my $pf = $pfa->Frame(-bd => $config{Borderwidth}, -relief => 'groove')->pack(-side => 'left');
my $pfn = $pf->Frame()->pack();
my $pfs = $pf->Frame()->pack();
foreach my $gravity (qw(NorthWest North NorthEast)) {
my $but = $pfn->Radiobutton(-text => '', -variable => \$config{CopyPosition}, -value => $gravity)->pack(-side => 'left');
$balloon->attach($but, -msg => "Align the copyright text or logo in $gravity position");
}
foreach my $gravity (qw(SouthWest South SouthEast)) {
my $but = $pfs->Radiobutton(-text => '', -variable => \$config{CopyPosition}, -value => $gravity)->pack(-side => 'left');
$balloon->attach($but, -msg => "Align the copyright text or logo in $gravity position");
}
labeledScale($bF, 'top', 17, "x offset", \$config{CopyX}, 0, $max, 1);
labeledScale($bF, 'top', 17, "y offset", \$config{CopyY}, 0, $max, 1);
my $ctF = $bF->Frame(-bd => $config{Borderwidth}, -relief => 'groove')->pack(-anchor => 'w', -fill => 'x',-padx => 5, -pady => 5);
my $clF = $bF->Frame(-bd => $config{Borderwidth}, -relief => 'groove')->pack(-anchor => 'w', -fill => 'x', -padx => 5, -pady => 5);
$ctF->Radiobutton(-text => "add copyright text", -variable => \$config{CopyTextOrLogo}, -value => "text")->pack(-anchor => 'w');
labeledEntry($ctF, 'top', 17, "Copyright text", \$config{Copyright});
my $fontF = $ctF->Frame(-bd => 0)->pack(-anchor => 'w', -padx => 5, -pady => 3);
my $fontF2 = $ctF->Scrolled('Pane', -bd => $config{Borderwidth}, -relief => 'groove', -scrollbars => 'osoe', -height => 80, -width => 480)->pack(-anchor => 'w', -padx => 5, -pady => 3);
$fontF->Label(-text => "Font family", -bg => $conf{color_bg}{value})->pack(-side => 'left');
my $fontL = $fontF2->Label(-textvariable => \$config{Copyright}, -bg => $conf{color_bg}{value})->pack(-side => 'left');
$fontF->Optionmenu(-textvariable => \$config{CopyFontFamily},
-options => \@fontFamilies,
-command => sub {
$decoW->Busy;
my $font = $top->Font(-family => $config{CopyFontFamily},
-size => $config{CopyFontSize});
$fontL->configure(-font => $font) if (ref($font) eq 'HASH');
$fontL->update();
$decoW->Unbusy;
})->pack(-side => 'left', -anchor => 'w');
$fontF->Label(-text => "Font size", -bg => $conf{color_bg}{value})->pack(-side => 'left');
$fontF->Scale(
-variable => \$config{CopyFontSize},
-from => 5,
-to => 200,
-resolution => 1,
-sliderlength => 30,
-orient => 'horizontal',
-showvalue => 0,
-width => 15,
-bd => $config{Borderwidth},
-command => sub {
$decoW->Busy;
my $font = $top->Font(-family => $config{CopyFontFamily},
-size => $config{CopyFontSize});
$fontL->configure(-font => $font);
$fontL->update();
$decoW->Unbusy;
})->pack(-side => 'left', -expand => 1, -fill => 'x', -padx => 3, -pady => 3);
$fontF->Label(-textvariable => \$config{CopyFontSize})->pack(-side => 'left');
labeledEntryColor($ctF, 'top', 17, "Foreground color", 'Set', \$config{CopyFontColFG});
$ctF->Checkbutton(-variable => \$config{CopyFontShadow},
-anchor => 'w',
-text => "Add a shadow to the copyright text"
)->pack(-anchor => 'w', -padx => 5, -pady => 3);
labeledEntryColor($ctF, 'top', 17, "Shadow color", 'Set', \$config{CopyFontColBG});
$clF->Radiobutton(-text => "add copyright logo (image)", -variable => \$config{CopyTextOrLogo}, -value => "logo")->pack(-anchor => 'w');
labeledEntryButton($clF,'top',17,"path/name of logo",'Set',\$config{CopyrightLogo});
# ### border ###
$cF->Label(-text => "Add one or several borders around pictures", -bg => $conf{color_bg}{value})->pack(-anchor => 'w', -padx => 3);
my $wi = 25;
my $bF1 = $cF->Frame(-bd => $config{Borderwidth}, -relief => 'groove')->pack(-fill => 'x', -padx => 3, -pady => 3);
$bF1->Label(-text => "Border 1 - innermost border", -bg => $conf{color_bg}{value})->pack(-anchor => 'w', -padx => 3);
labeledScale($bF1, 'top', $wi, "Border width x-direction", \$config{BorderWidth1x}, 0, $max, 1);
labeledScale($bF1, 'top', $wi, "Border width y-direction", \$config{BorderWidth1y}, 0, $max, 1);
labeledEntryColor($bF1, 'top', $wi, "Color", 'Set', \$config{BorderColor1});
my $bF2 = $cF->Frame(-bd => $config{Borderwidth}, -relief => 'groove')->pack(-fill => 'x', -padx => 3, -pady => 3);
$bF2->Label(-text => "Border 2 - border around border 1 (use width 0 to disable)", -bg => $conf{color_bg}{value})->pack(-anchor => 'w', -padx => 3);
labeledScale($bF2, 'top', $wi, "Border width x-direction", \$config{BorderWidth2x}, 0, $max, 1);
labeledScale($bF2, 'top', $wi, "Border width y-direction", \$config{BorderWidth2y}, 0, $max, 1);
labeledEntryColor($bF2, 'top', $wi, "Color", 'Set', \$config{BorderColor2});
my $bF3 = $cF->Frame(-bd => $config{Borderwidth}, -relief => 'groove')->pack(-fill => 'x', -padx => 3, -pady => 3);
$bF3->Label(-text => "Border 3 - border around border 2 (use width 0 to disable)", -bg => $conf{color_bg}{value})->pack(-anchor => 'w', -padx => 3);
labeledScale($bF3, 'top', $wi, "Border width x-direction", \$config{BorderWidth3x}, 0, $max, 1);
labeledScale($bF3, 'top', $wi, "Border width y-direction", \$config{BorderWidth3y}, 0, $max, 1);
labeledEntryColor($bF3, 'top', $wi, "Color", 'Set', \$config{BorderColor3});
my $bF4 = $cF->Frame(-bd => $config{Borderwidth}, -relief => 'groove')->pack(-fill => 'x', -padx => 3, -pady => 3);
$bF4->Label(-text => "Border 4 - border around border 3 (use width 0 to disable)", -bg => $conf{color_bg}{value})->pack(-anchor => 'w', -padx => 3);
labeledScale($bF4, 'top', $wi, "Border width x-direction", \$config{BorderWidth4x}, 0, $max, 1);
labeledScale($bF4, 'top', $wi, "Border width y-direction", \$config{BorderWidth4y}, 0, $max, 1);
labeledEntryColor($bF4, 'top', $wi, "Color", 'Set', \$config{BorderColor4});
# ### drop shadow ###
$dF->Label(-text => "Add a drop shadow to the pictures", -bg => $conf{color_bg}{value})->pack(-anchor => 'w', -padx => 3);
$dF->Label(-text => "(conversion may take some time)", -bg => $conf{color_bg}{value})->pack(-anchor => 'w', -padx => 3);
labeledScale($dF, 'top', 17, "Border width", \$config{DropShadowWidth}, 1, $max, 1);
labeledScale($dF, 'top', 17, "Shadow blur", \$config{DropShadowBlur}, 1, 9, 1);
labeledEntryColor($dF, 'top', 17, "Background color", 'Set', \$config{DropShadowBGColor});
my $ButF =
$decoW->Frame()->pack(-fill =>'x', -padx => 3, -pady => 3);
my $OKB =
$ButF->Button(-text => lang('OK'),
-command => sub {
$decoW->withdraw();
$decoW->destroy();
$rc = 1;
})->pack(-side => 'left', -expand => 1, -fill => 'x', -padx => 3, -pady => 3);
my $Xbut = $ButF->Button(-text => lang('Cancel'),
-command => sub { $rc = 0;
$decoW->withdraw();
$decoW->destroy();
})->pack(-side => 'left', -expand => 1, -fill => 'x', -padx => 3, -pady => 3);
bind_exit_keys_to_button($decoW, $Xbut);
$decoW->Popup;
$decoW->waitWindow;
return $rc;
}
my $colw;
##############################################################
# colorDialog
##############################################################
sub colorDialog {
if (Exists($colw)) {
$colw->deiconify;
$colw->raise;
return;
}
my $rc = 0;
# open window
$colw = $top->Toplevel();
$colw->title('Color options');
$colw->iconimage($mapiviicon) if $mapiviicon;
foreach (qw(Brightness Saturation Hue)) {
labeledScale($colw, 'top', 16, "$_ (%)", \$config{"Pic$_"}, 0, 200, 1);
}
labeledScale($colw, 'top', 16, "Gamma", \$config{PicGamma}, 0.1, 10.0, 0.01);
$colw->Button(-text => "Reset",
-command => sub {
foreach (qw(Brightness Saturation Hue)) {
$config{"Pic$_"} = 100;
}
$config{PicGamma} = 1.00;
})->pack(-anchor => 'w', -padx => 3, -pady => 3);
my $OKB =
$colw->Button(-text => "Close",
-command => sub { $rc = 1; $colw->destroy; })->pack(-side => 'left', -expand => 1, -fill => 'x', -padx => 3, -pady => 3);
$colw->bind('', sub { $OKB->Invoke; });
$colw->bind('', sub { $OKB->Invoke; });
$colw->Popup;
$colw->waitWindow;
}
my $uw;
##############################################################
# unsharpDialog
##############################################################
sub unsharpDialog {
if (Exists($uw)) {
$uw->deiconify;
$uw->raise;
return;
}
my $rc = 0;
# open window
$uw = $top->Toplevel();
$uw->title('Unsharp mask options');
$uw->iconimage($mapiviicon) if $mapiviicon;
my $usr =labeledScale($uw, 'top', 16, "Radius (pixel)", \$config{UnsharpRadius}, 0, 10, 1);
$balloon->attach($usr, -msg => "The radius of the Gaussian, in pixels,
not counting the center pixel.
Use a radius of 0 and the function selects a suitable radius
for you (default 0)");
my $uss = labeledScale($uw, 'top', 16, "Sigma (pixel)", \$config{UnsharpSigma}, 0.1, 10, 0.1);
$balloon->attach($uss, -msg => "The standard deviation of the Gaussian,\nin pixels (default 1.0)");
my $usa = labeledScale($uw, 'top', 16, "amount (%)", \$config{UnsharpAmount}, 0, 100, 0.1);
$balloon->attach($usa, -msg => "The percentage of the difference between the original\nand the blur image that is added back into the original\n(default 1.0)");
my $ust = labeledScale($uw, 'top', 16, "Threshold (frac)", \$config{UnsharpThreshold}, 0, 10, 0.01);
$balloon->attach($ust, -msg => "The threshold, as a fraction of MaxRGB,\nneeded to apply the difference amount\n(default 0.05)");
$uw->Button(-text => "Default",
-command => sub {
$config{UnsharpRadius} = 0;
$config{UnsharpSigma} = 1.0;
$config{UnsharpAmount} = 1.0;
$config{UnsharpThreshold} = 0.05;
})->pack(-anchor => 'w', -padx => 3, -pady => 3);
my $OKB =
$uw->Button(-text => "Close",
-command => sub { $rc = 1; $uw->destroy; })->pack(-side => 'left', -expand => 1, -fill => 'x', -padx => 3, -pady => 3);
$uw->bind('', sub { $OKB->Invoke; });
$uw->bind('', sub { $OKB->Invoke; });
$uw->Popup;
$uw->waitWindow;
}
my $lw;
##############################################################
# levelDialog
##############################################################
sub levelDialog {
if (Exists($lw)) {
$lw->deiconify;
$lw->raise;
return;
}
my $rc = 0;
# open window
$lw = $top->Toplevel();
$lw->title('Levels');
$lw->iconimage($mapiviicon) if $mapiviicon;
my $lws = labeledScale($lw, 'top', 18, "White point (%)", \$config{LevelWhite}, 0, 100, 1);
$balloon->attach($lws, -msg => "White point specifies the lightest color in the image.
Colors brighter than the white point are set to the maximum quantum value.");
my $lms = labeledScale($lw, 'top', 18, "Mid point (gamma)", \$config{LevelGamma}, 0.1, 10.0, 0.1);
$balloon->attach($lms, -msg => "Mid point specifies a gamma correction to apply to the image.");
my $lbs = labeledScale($lw, 'top', 18, "Black point (%)", \$config{LevelBlack}, 0, 100, 1);
$balloon->attach($lbs, -msg => "The black point specifies the darkest color in the image.
Colors darker than the black point are set to zero.");
$lw->Button(-text => "Reset",
-command => sub {
$config{LevelWhite} = 100;
$config{LevelGamma} = 1.0;
$config{LevelBlack} = 0;
})->pack(-anchor => 'w', -padx => 3, -pady => 3);
my $OKB =
$lw->Button(-text => "Close",
-command => sub { $rc = 1; $lw->destroy; })->pack(-side => 'left', -expand => 1, -fill => 'x', -padx => 3, -pady => 3);
$lw->bind('', sub { $OKB->Invoke; });
$lw->bind('', sub { $OKB->Invoke; });
$lw->Popup;
$lw->waitWindow();
}
##############################################################
##############################################################
sub get_IPTC_info {
my $dpic = shift;
my $ok = 0; # default return value is false
my $iptc = {}; # hash reference
# get IPTC data
my $meta = getMetaData($dpic, 'APP13');
if ($meta) {
$ok = 1;
if (defined $meta->get_app13_data('TEXTUAL', 'IPTC')) {
$iptc = $meta->get_app13_data('TEXTUAL', 'IPTC');
warn "IPTC segment of $dpic has errors!" if ($iptc->{error});
}
}
else {
warn "get_IPTC_info: got no meta info of $dpic\n";
}
print "get_IPTC_info $dpic\n" if $verbose;
return ($ok, $iptc, $meta);
}
##############################################################
# get_IPTC_intersection
##############################################################
sub get_IPTC_intersection {
my $lb = shift;
my $pic_list = shift; # pictures to intersect, array ref
# use the IPTC info of the first picture as master
my $first_pic = @{$pic_list}[0];
my ($ok, $iptc_i) = get_IPTC_info($first_pic);
return $iptc_i if not $ok;
my $i = 0;
my $pw;
# show a progressbar only if there are more than 5 pictures selected
$pw = progressWinInit($lb, 'Analyzing IPTC data ...') if (@{$pic_list} > 5);
foreach my $dpic (@{$pic_list}) {
last if progressWinCheck($pw);
$i++;
progressWinUpdate($pw, "Collecting common data ($i/".scalar @{$pic_list}.") ...", $i, scalar @{$pic_list});
next if ($dpic eq $first_pic); # the first pic is already processed above as master
my ($ok, $iptc) = get_IPTC_info($dpic);
next if not $ok;
# compare each key from the master
foreach my $key (keys %{$iptc_i}) {
my $ref = ref($iptc_i->{$key});
my $nr = scalar @{$iptc_i->{$key}};
# if key doesn't exists in one of the pictures we remove this key
unless (exists $iptc->{$key}) {
delete $iptc_i->{$key};
next;
}
# get the intersection of the key content (this works for single elements and lists)
my @intersection = listIntersection($iptc_i->{$key}, $iptc->{$key});
# if there is something left we take the intersection
if (@intersection) {
$iptc_i->{$key} = \@intersection;
}
# else we remove the key
else {
delete $iptc_i->{$key};
}
}
}
progressWinEnd($pw);
return $iptc_i;
}
##############################################################
# editIPTC - edit IPTC info of one or multiple pictures
##############################################################
sub editIPTC {
my $lb = shift;
my @sellist = $lb->info('selection');
return unless checkSelection($top, 1, 0, \@sellist, lang("picture(s)"));
# check if some files are links
return if (!checkLinks($lb, @sellist));
# init with the first picture in list
my $dpic = $sellist[0];
my $pic = basename($dpic);
# take the first picture as master for the IPTC data
my ($ok, $iptcm) = get_IPTC_info($dpic); # $iptcm = IPTC master, hash reference
if (not $ok) {
log_it("Could not open IPTC segment of $pic");
return;
}
# handle several pictures: the IPTC dialog should just show common elements
if (@sellist > 1) {
$iptcm = get_IPTC_intersection($lb, \@sellist, $iptcm);
}
my @keywords_common = ();
my @suppcats_common = ();
foreach (@{$iptcm->{Keywords}}) {
$_ =~ tr/ -~//cd; # remove non-printables (Picasa adds one to each keyword)
}
${$iptcm->{Caption}}[0] =~ tr/\n\t\r\f -~//cd if (${$iptcm->{Caption}}[0]); # replace all non-printable chars, but not newline etc.
# these are the common items (e.g. common keywords of all selected pictures)
@keywords_common = @{$iptcm->{Keywords}} if (exists $iptcm->{Keywords});
@suppcats_common = @{$iptcm->{SupplementalCategory}} if (exists $iptcm->{SupplementalCategory});
my $rc = iptcDialog($iptcm, $pic, scalar @sellist);
return if ($rc ne 'OK');
# after user interaction in the dialog
my @keywords_master = ();
@keywords_master = @{$iptcm->{Keywords}} if (exists $iptcm->{Keywords});
my @suppcats_master = ();
@suppcats_master = @{$iptcm->{SupplementalCategory}} if (exists $iptcm->{SupplementalCategory});
# to remove keywords and categories we need to figure out what has been removed by the user
my @keywords_removed = diffList(\@keywords_common, \@keywords_master);
my @suppcats_removed = diffList(\@suppcats_common, \@suppcats_master);
my $IPTC_action = $config{IPTC_action};
# if we edit a single picture we always use the replace mode
$IPTC_action = 'REPLACE' if (@sellist == 1);
my $errors = '';
my $i = 0;
my $pw = progressWinInit($lb, "Writing IPTC info");
foreach my $dpic (@sellist) {
last if progressWinCheck($pw);
$i++;
progressWinUpdate($pw, "Writing IPTC info ($i/".scalar @sellist.") ...", $i, scalar @sellist);
# check if file is a link and get the real target
next if (!getRealFile(\$dpic));
next if (!checkWriteable($dpic));
my $meta = getMetaData($dpic, 'APP1'); # APP1 includes EXIF and IPTC (APP13)
my $er = $meta->get_Exif_data('ALL', 'TEXTUAL');
my $iptc;
# copy (clone) master iptc hash to picture iptc hash
$iptc = dclone($iptcm);
if (($config{IPTCdateEXIF}) or ($config{IPTCtimeEXIF})) {
my $date = getEXIFDate($dpic, $er); # date format YYYY:MM:DD HH:mm:SS
my ($ok, $IPTCdate, $IPTCtime) = EXIFtoIPTCdatetime($date);
if ($ok) {
# according to IPTC - NAA INFORMATION INTERCHANGE MODEL, Version No. 4, 1999, http://www.iptc.org/IIM/
${$iptc->{DateCreated}}[0] = $IPTCdate if ($config{IPTCdateEXIF}); # format CCYYMMDD
${$iptc->{TimeCreated}}[0] = $IPTCtime if ($config{IPTCtimeEXIF}); # format HHMMSS+HHMM
}
else {
warn "picture has an unusual EXIF date: \"$date\" ($dpic)\n" if $config{MetadataWarn};
}
}
if ($config{IPTCbylineEXIF}) {
if (defined $er) {
my $owner = getEXIFowner($er);
if ($owner ne '') {
print "*** Writing \"$owner\" to $dpic\n" if $verbose;
${$iptc->{ByLine}}[0] = $owner;
}
}
}
if ($config{IPTCaddMapivi}) {
${$iptc->{OriginatingProgram}}[0] = 'Mapivi';
${$iptc->{ProgramVersion}}[0] = $version;
}
# make some corrections for keywords and supp cats
# according to the documentation of Image::MetaData::JPEG this should not be needed
if ((@sellist > 1) and (($IPTC_action eq 'UPDATE') or ($IPTC_action eq 'ADD'))) {
# todo problem is still, that removed elements (where nothing is left, e.g. a headline) are not removed in Update mode
my $seg = $meta->retrieve_app13_segment(undef, 'IPTC'); # todo should be possible without segement
if ($seg) {
my $hashref = $seg->get_app13_data('TEXTUAL', 'IPTC');
my @keywords;
# take the original items and add the items from the dialog (master)
push @keywords, @{$hashref->{Keywords}} if (defined($hashref->{Keywords}));
push @keywords, @keywords_master;
# then remove items which have been removed in the dialog
@keywords = diffList(\@keywords, \@keywords_removed);
#@keywords = ('') unless (@keywords);
$iptc->{Keywords} = \@keywords;
my @suppcats;
# take the original items and add the items from the dialog (master)
push @suppcats, @{$hashref->{SupplementalCategory}} if (defined($hashref->{SupplementalCategory}));
push @suppcats, @suppcats_master;
# then remove items which have been removed in the dialog
@suppcats = diffList(\@suppcats, \@suppcats_removed);
$iptc->{SupplementalCategory} = \@suppcats;
}
}
$meta->set_app13_data($iptc, $IPTC_action, 'IPTC');
uniqueIPTC($meta);
if ($meta->save()) { # success
# if urgency / rating is not equal 0 we also modify the XMP rating tag
if (exists $iptcm->{Urgency} and ${$iptcm->{Urgency}}[0] != 0) {
xmp_set_rating($dpic, ${$iptcm->{Urgency}}[0]) if $conf{xmp_rating}{value};
}
}
else { $errors .= "save failed for $dpic\n"; }
# touch the thumbnail pic (set actual time stamp), to suppress rebuilding
touch(getThumbFileName($dpic));
updateOneRow($dpic, $lb);
if ($dpic eq $actpic) {
showImageInfoCanvas($dpic);
# update_IPTC_frame_content($dpic);
}
}
progressWinEnd($pw);
log_it("ready! ($i/".scalar @sellist." written)");
showText("Errors while editing IPTC info", $errors, NO_WAIT) if ($errors ne '');
}
##############################################################
# returns EXIF owner, or artist, or user comment, or empty string
# input: EXIF data of meta data
# here is how to get $er:
# my $meta = getMetaData($dpic, 'APP1'); # APP1 includes EXIF and IPTC (APP13)
# my $er = $meta->get_Exif_data('ALL', 'TEXTUAL');
##############################################################
sub getEXIFowner {
my $er = shift;
my $owner = '';
if (defined $er->{SUBIFD_DATA}->{OwnerName}) {
$owner = join('', @{$er->{SUBIFD_DATA}->{OwnerName}});
}
elsif (defined $er->{IFD0_DATA}->{Artist}) {
$owner = join('', @{$er->{IFD0_DATA}->{Artist}});
}
elsif (defined $er->{SUBIFD_DATA}->{UserComment}) {
$owner = join('', @{$er->{SUBIFD_DATA}->{UserComment}});
}
else { }
if ($owner ne '') {
$owner =~ tr/ -~//cd; # remove non-printable characters (but not \n)
$owner =~ s/ASCII//g; # cut 'ASCII'
$owner =~ s/^\s+//; # cut leading white
$owner =~ s/\s+$//; # cut trailing white
}
return $owner;
}
##############################################################
# convert EXIT date/time to IPTC format
##############################################################
sub EXIFtoIPTCdatetime {
my $date = shift; # EXIF date
my ($IPTCdate, $IPTCtime);
my $ok = 0;
if (my ($y, $M, $d, $h, $m, $s) = $date =~ m/(\d\d\d\d):(\d\d):(\d\d) (\d\d):(\d\d):(\d\d)/) {
$ok = 1;
my $time = timelocal($s,$m,$h,$d,($M-1),($y-1900));
my $diff = ((localtime($time))[2] - (gmtime($time))[2]);
# RJW: Correct timezone calculation in case of migration over
# 24 hour border
if ( $diff > 12 ) {
$diff -= 24;
} elsif ( $diff < -12 ) {
$diff += 24;
}
my $GMToffset = sprintf("%+03d00", $diff);
$IPTCdate = $y.$M.$d;
$IPTCtime = $h.$m.$s.$GMToffset;
}
return ($ok, $IPTCdate, $IPTCtime);
}
##############################################################
# setIPTCurgency - set the urgency flag to a given value (0 .. 8)
##############################################################
sub setIPTCurgency {
my $lb = shift; # the reference to the active listbox widget
my $urgency = shift;
return unless (defined($urgency));
return if (($urgency < 0) or ($urgency > 9)); # 9 is used to clear the urgency flag
my @sellist = getSelection($lb);
return unless checkSelection($lb, 1, 0, \@sellist, lang("picture(s)"));
# check if some files are links
return if (!checkLinks($lb, @sellist));
$urgency = '' if ($urgency == 9); # 9 is used to clear the urgency flag
my $msg = "Writing IPTC urgence $urgency";
$msg = "Deleting IPTC urgence flag" if ($urgency eq '');
my $errors = '';
my $i = 0;
my $pw;
$pw = progressWinInit($lb, $msg) if (@sellist > 1);
foreach my $dpic (@sellist) {
last if progressWinCheck($pw);
$i++;
progressWinUpdate($pw, "$msg ($i/".scalar @sellist.") ...", $i, scalar @sellist);
my $pic = basename($dpic);
# check if file is a link and get the real target
next if (!getRealFile(\$dpic));
next if (!checkWriteable($dpic));
my $ok = set_IPTC_urgency_file($dpic, $urgency, \$errors);
if ($ok) { # urgency changed successfully!
# set also XMP rating, if option is set
xmp_set_rating($dpic, $urgency) if $conf{xmp_rating}{value};
print "saved IPTC urgency $urgency to $pic\n" if $verbose;
# touch the thumbnail pic (set actual time stamp), to suppress rebuilding
touch(getThumbFileName($dpic));
updateOneRow($dpic, $lb);
if ($dpic eq $actpic) {
#showImageInfoCanvas($dpic);
showImageInfo($dpic);
}
}
}
progressWinEnd($pw);
$msg = "Urgency $urgency written to";
$msg = "Removed urgency flag in" if ($urgency eq '');
log_it("ready! $msg $i of ".scalar @sellist." pictures");
showText("Errors and infos while saving IPTC urgency", $errors, NO_WAIT) if ($errors ne '');
}
##############################################################
##############################################################
sub set_IPTC_urgency_file {
my $dpic = shift;
my $urgency = shift;
my $errors = shift; # reference to string, errors will be added
my ($ok, $iptc, $meta) = get_IPTC_info($dpic);
if (not $ok) {
$$errors .= "Could not open IPTC segment of $dpic\n";
return 0;
}
if ($config{UrgencyChangeWarning} and (defined $iptc->{Urgency}) and (${$iptc->{Urgency}}[0] ne $urgency)) {
$$errors .= "Info: Rating (Urgency) changed from ".iptc_rating_stars_urg(${$iptc->{"Urgency"}}[0])." to ".iptc_rating_stars_urg($urgency)." $dpic\n";
}
$iptc->{Urgency} = $urgency;
$meta->set_app13_data($iptc, 'REPLACE', 'IPTC');
if (!$meta->save()) {
$$errors .= "save failed for $dpic\n";
return 0;
}
return 1;
}
##############################################################
# getIPTCurgencyDB - get the urgency flag of a given file from
# the search database
# returns 9 if there is no file or no urgency
##############################################################
sub getIPTCurgencyDB {
my $dpic = shift;
my $urgency = 9;
$urgency = $searchDB{$dpic}{URG} if (defined $searchDB{$dpic}{URG});
return $urgency;
}
##############################################################
# getIPTCurgency - get the urgency flag of a given file
# returns 9 if there is no file or no urgency
##############################################################
sub getIPTCurgency {
my $dpic = shift;
my $meta = shift; # optional, the Image::MetaData::JPEG object of $dpic if available
my $urgency = 9;
return $quickSortHash{$dpic} if ($quickSortSwitch and defined $quickSortHash{$dpic});
return 9 unless (-f $dpic);
$meta = getMetaData($dpic, "APP13", 'FASTREADONLY') unless (defined($meta));
return 9 unless ($meta);
my $seg = $meta->retrieve_app13_segment(undef, 'IPTC'); # todo should be possible without segement
return 9 unless ($seg);
my $hashref = $seg->get_app13_data("TEXTUAL", 'IPTC');
if (defined($hashref->{Urgency})) {
$urgency = ${$hashref->{Urgency}}[0];
$urgency = 8 if ($urgency =~ /l/i);
$urgency = 1 if ($urgency =~ /h/i);
$urgency = 9 if ($urgency !~ /\d/);
$urgency = 9 if ( ($urgency > 9) or ($urgency < 0) );
}
$quickSortHash{$dpic} = $urgency if $quickSortSwitch;
print "getIPTCurgency: -$urgency- $dpic\n" if $verbose;
return $urgency;
}
##############################################################
# getIPTCkeywords - get the keywords of a given file
# returns empty list if there is no file or
# no keyword
##############################################################
sub getIPTCkeywords {
my $dpic = shift;
my $meta = shift; # optional, the Image::MetaData::JPEG object of $dpic if available
my @keywords = ();
return @keywords unless (-f $dpic);
$meta = getMetaData($dpic, 'APP13', 'FASTREADONLY') unless (defined($meta));
return @keywords unless ($meta);
my $seg = $meta->retrieve_app13_segment(undef, 'IPTC'); # todo should be possible without segement
return @keywords unless ($seg);
my $hashref = $seg->get_app13_data('TEXTUAL', 'IPTC');
if (defined($hashref->{Keywords})) {
@keywords = @{$hashref->{Keywords}};
}
foreach (@keywords) {
# translate it to a string if it is non-printing
#my $key = $_;
#$key =~ s/[\000-\037\177-\377]/sprintf "\\%02x",ord($&)/e;
#print "key = -$key-\n";
$_ =~ tr/ -~//cd; # replace all non-printable chars (Picasa adds one to each keyword)
}
return @keywords;
}
##############################################################
# getIPTCByLine - get the by-line info of a given file
##############################################################
sub getIPTCByLine {
my $dpic = shift;
my $byline = '';
return $quickSortHash{$dpic} if ($quickSortSwitch and defined $quickSortHash{$dpic});
return $byline unless (-f $dpic);
my $meta = getMetaData($dpic, "APP13", 'FASTREADONLY');
return $byline unless ($meta);
my $seg = $meta->retrieve_app13_segment(undef, 'IPTC'); # todo should be possible without segement
return $byline unless ($seg);
my $hashref = $seg->get_app13_data("TEXTUAL", 'IPTC');
$byline = ${$hashref->{ByLine}}[0] if (defined($hashref->{ByLine}));
$quickSortHash{$dpic} = $byline if $quickSortSwitch;
print "getIPTCByLine: $byline ($dpic)\n" if $verbose;
return $byline;
}
##############################################################
# getIPTCAttr - get an IPTC attribute of a given file
# returns empty string if attribute is not defined
##############################################################
sub getIPTCAttr {
my $dpic = shift;
my $name = shift;
my $val = '';
if (-f $dpic) {
my $meta = getMetaData($dpic, 'APP13', 'FASTREADONLY');
if ($meta) {
my $seg = $meta->retrieve_app13_segment(undef, 'IPTC'); # todo should be possible without segement
if ($seg) {
my $hashref = $seg->get_app13_data('TEXTUAL', 'IPTC');
if (defined($hashref->{$name})) {
$val = ${$hashref->{$name}}[0];
print "getIPTCAttr: $name=$val ($dpic)\n" if $verbose;
}
}
}
}
return $val;
}
##############################################################
# getIPTCObjectName - get the object name of a given file
##############################################################
sub getIPTCObjectName {
my $dpic = shift;
return getIPTCAttr($dpic, "ObjectName");
}
##############################################################
# getIPTCHeadline - get the headline of a given file
##############################################################
sub getIPTCHeadline {
my $dpic = shift;
return getIPTCAttr($dpic, "Headline");
}
##############################################################
# getIPTCCaption - get the caption of a given file
##############################################################
sub getIPTCCaption {
my $dpic = shift;
return getIPTCAttr($dpic, "Caption/Abstract");
}
##############################################################
# getIPTCByLineTitle - get the by-line title of a given file
##############################################################
sub getIPTCByLineTitle {
my $dpic = shift;
return getIPTCAttr($dpic, "ByLineTitle");
}
##############################################################
# getIPTCSublocation - get the sublocation of a given file
##############################################################
sub getIPTCSublocation {
my $dpic = shift;
return getIPTCAttr($dpic, "SubLocation");
}
##############################################################
# getIPTCCity - get the city of a given file
##############################################################
sub getIPTCCity {
my $dpic = shift;
return getIPTCAttr($dpic, "City");
}
##############################################################
# getIPTCProvince - get the province/state of a given file
##############################################################
sub getIPTCProvince {
my $dpic = shift;
return getIPTCAttr($dpic, "Province/State");
}
##############################################################
# getIPTCCountryCode - get the country code of a given file
##############################################################
sub getIPTCCountryCode {
my $dpic = shift;
return getIPTCAttr($dpic, "Country/PrimaryLocationCode");
}
##############################################################
# iptcDialog
##############################################################
sub iptcDialog {
my $iptc = shift;
my $picname = shift;
my $nr = shift; # number of pics
my $rc = 'Cancel';
my @tag_list; # used to store all IPTC tags which are already displayed, all others will go to the misc tab
# open window
my $t = $top->Toplevel();
$t->title("Edit IPTC/IIM information of $nr pictures ($picname)");
$t->iconimage($mapiviicon) if $mapiviicon;
$t->geometry($conf{iptc_geometry}{value});
# we use a pane to support small screen resolutions, the user is still able to scroll e.g. to the buttons at the bottom of the window
my $pane = $t->Scrolled('Pane', -scrollbars => 'osoe')->pack(-expand => 1, -fill => 'both');
my $notebook =
$pane->NoteBook(-background => $conf{color_bg}{value}, # background of active page (including its tab)
-inactivebackground => $conf{color_entry}{value}, # tabs of inactive pages
-backpagecolor => $conf{color_bg}{value}, # background behind notebook
)->pack(-expand => 1,
-fill => 'both',
-padx => 5, -pady => 5);
my $aN = $notebook->add('stan', -label => 'Standard');
my $bN = $notebook->add('misc', -label => 'Misc');
my $cN = $notebook->add('opt', -label => 'Options');
$notebook->raise($config{IPTCLastPad});
my $w = 11;
my $ent;
####### Standart IPTC tags #############
# left and right frame on standard tab
my $aF = $aN->Frame(-bd => 0)->pack(-side => 'left', -expand => 1, -fill => 'both', -padx => 3, -pady => 0);
my $bF = $aN->Frame(-bd => 0)->pack(-side => 'left', -expand => 1, -fill => 'both', -padx => 3, -pady => 0);
my @alist = ('Headline', 'ObjectName');
foreach (@alist) {
$ent = labeledEntry($aF,'top',$w,$_,\${$iptc->{$_}}[0], 5);
if (defined $iptcHelp{$_}) {
$balloon->attach($ent, -msg => formatString($_.":\n".$iptcHelp{$_}, 80, -1)) if (Exists $ent);
}
}
push @tag_list, @alist; # add already displayed elements to the list
####### Caption #############
my $capF = $aF->Frame(-bd => 0)->pack(-anchor=>'w', -expand => 1, -fill => 'both', -padx => 3, -pady => 3);
$capF->Label(-text => 'Caption/Abstract', -bg => $conf{color_bg}{value})->pack(-anchor => 'w', -padx => 2, -pady => 2);
my $caption = $capF->Scrolled("Text",
-scrollbars => 'osoe',
-wrap => 'word',
-width => 60,
-height => 6,
)->pack(-expand => 1, -fill => 'both', -padx => 2, -pady => 2);
$caption->insert('end', ${$iptc->{'Caption/Abstract'}}[0]);
$caption->see(0.1);
push @tag_list, 'Caption/Abstract'; # add already displayed elements to the list
####### Urgency #############
my $oF = $aF->Frame(-bd => 0)->pack(-anchor=>'w', -padx => 3, -pady => 6);
$balloon->attach($oF, -msg => "Rating/Urgency\n0 = no\n1 = High ********\n2 = *******\n3 = ******\n4 = *****\n5 = Normal ****\n6 = ***\n7 = **\n8 = Low *");
$oF->Label(-text => "Rating/Urgency", -bg => $conf{color_bg}{value}, -width => 15, -anchor => 'w')->pack(-side => 'left', -anchor => 'w', -padx => 2, -pady => 2);
$oF->Optionmenu(-variable => \${$iptc->{Urgency}}[0], -textvariable => \${$iptc->{Urgency}}[0], -options => [0,1,2,3,4,5,6,7,8])->pack(-side => 'left', -anchor => 'w', -padx => 0);
push @tag_list, 'Urgency'; # add already displayed elements to the list
if ($config{IPTCProfessional}) {
####### Writer/Editor and Credit #############
labeledDoubleEntry($aF, 'top', $w, 'Writer/Editor', 'Credit',
\${$iptc->{'Writer/Editor'}}[0],
formatString("Writer/Editor:\n".$iptcHelp{'Writer/Editor'}, 80, -1),
\${$iptc->{'Credit'}}[0],
formatString("Credit:\n".$iptcHelp{'Credit'}, 80, -1));
push @tag_list, ('Writer/Editor', 'Credit'); # add already displayed elements to the list
}
####### BylineTitle and Byline #############
# !!! todo byline and bylinetitle are repeatable use e.g. .= "$_, " for @{$iptc->{$_}};
labeledDoubleEntry($aF, 'top', $w, 'ByLineTitle', 'Name',
\${$iptc->{ByLineTitle}}[0],
formatString("ByLineTitle:\n".$iptcHelp{'ByLineTitle'}, 80, -1),
\${$iptc->{ByLine}}[0],
formatString("ByLine:\n".$iptcHelp{'ByLine'}, 80, -1));
push @tag_list, ('ByLineTitle', 'ByLine'); # add already displayed elements to the list
####### EditStatus etc. ##############
if ($config{IPTCProfessional}) {
@alist = ('EditStatus', 'SpecialInstructions', 'Contact', 'Source', 'CopyrightNotice');
foreach (@alist) {
$ent = labeledEntry($aF,'top',$w,$_,\${$iptc->{$_}}[0]);
if (defined $iptcHelp{$_}) {
# todo this cuts very long desc because of config{LineLimit}
$balloon->attach($ent, -msg => formatString($_.":\n".$iptcHelp{$_}, 80, -1)) if (Exists $ent);
}
}
push @tag_list, @alist; # add already displayed elements to the list
}
####### Location ##############
my $locF = $aF->Frame(-relief => 'raised')->pack(-anchor=>'w', -padx => 3, -pady => 3, -fill => 'x');
$locF->Label(-text => 'Location')->pack(-anchor => 'w', -padx => 2, -pady => 2);
labeledDoubleEntry($locF, 'top', $w, 'Country', 'Code',
\${$iptc->{'Country/PrimaryLocationName'}}[0],
formatString("Country/PrimaryLocationName:\n".$iptcHelp{'Country/PrimaryLocationName'}, 80, -1),
\${$iptc->{'Country/PrimaryLocationCode'}}[0],
formatString("Country/PrimaryLocationCode:\n".$iptcHelp{'Country/PrimaryLocationCode'}, 80, -1));
labeledDoubleEntry($locF, 'top', $w, 'Province/State', 'City',
\${$iptc->{'Province/State'}}[0],
formatString("Province/State:\n".$iptcHelp{'Province/State'}, 80, -1),
\${$iptc->{'City'}}[0],
formatString("City:\n".$iptcHelp{'City'}, 80, -1) );
$ent = labeledEntry($locF,'top',$w,'SubLocation',\${$iptc->{'SubLocation'}}[0]);
if (defined $iptcHelp{'SubLocation'}) {
# todo this cuts very long desc because of config{LineLimit}
$balloon->attach($ent, -msg => formatString("SubLocation:\n".$iptcHelp{'SubLocation'}, 80, -1)) if (Exists $ent);
}
push @tag_list, ('SubLocation', 'City', 'Province/State', 'Country/PrimaryLocationName', 'Country/PrimaryLocationCode');
####### Date and Time ############
if ($config{IPTCProfessional}) {
@alist = ('ReleaseDate', 'ReleaseTime', 'DateCreated', 'TimeCreated');
my $dateF = $aF->Frame(-bd => $config{Borderwidth}, -relief => 'raised')->pack(-anchor=>'w', -padx => 3, -pady => 3, -fill => 'x');
$dateF->Label(-text => 'Date and time')->pack(-anchor => 'w', -padx => 2, -pady => 2);
labeledDoubleEntry($dateF, 'top', $w, 'Date created', 'Time',
\${$iptc->{DateCreated}}[0],
formatString("DateCreated:\n".$iptcHelp{'DateCreated'}, 80, -1),
\${$iptc->{TimeCreated}}[0],
formatString("TimeCreated:\n".$iptcHelp{'TimeCreated'}, 80, -1));
labeledDoubleEntry($dateF, 'top', $w, 'Date released', 'Time',
\${$iptc->{ReleaseDate}}[0],
formatString("ReleaseDate:\n".$iptcHelp{'ReleaseDate'}, 80, -1),
\${$iptc->{ReleaseTime}}[0],
formatString("ReleaseTime:\n".$iptcHelp{'ReleaseTime'}, 80, -1));
push @tag_list, @alist; # add already displayed elements to the list
}
####### Keywords ############
my $keyword_frame = $bF->Frame(-bd => 0)->pack(-expand => 1, -fill => 'both', -padx => 0, -pady => 0);
# get the keywords (list ref)
doubleList($keyword_frame, \@prekeys, \@{$iptc->{Keywords}}, 'keywords');
push @tag_list, 'Keywords';
####### Categories ##########
my $category_frame;
if ($config{IPTCProfessional} == 1) {
$category_frame = $bF->Frame(-bd => 0)->pack(-expand => 1, -fill => 'both', -padx => 0, -pady => 0);
$ent = labeledEntry($category_frame,'top',$w,'Category',\${$iptc->{Category}}[0]);
if (defined $iptcHelp{Category}) {
$balloon->attach($ent, -msg => formatString("Category:\n".$iptcHelp{Category}, 80, -1)); # todo
}
# supp categories ###
doubleList($category_frame, \@precats, \@{$iptc->{SupplementalCategory}}, 'supplemental categories');
push @tag_list, ('Category', 'SupplementalCategory');
}
####### Misc #################
my $p = $bN->Scrolled("Pane", -scrollbars => "oe", -height => 300)->pack(-fill => 'both', -expand => 1);
# build a frame, a label and an entry for every tag which is not yet displayed
foreach (@IPTCAttributes) {
next if (isInList($_, \@tag_list));
$ent = labeledEntry($p,'top',40,$_,\${$iptc->{$_}}[0]);
if (defined $iptcHelp{$_}) {
$balloon->attach($ent, -msg => formatString($_.":\n".$iptcHelp{$_}, 80, -1)); # todo
}
}
###### bottom frame
my $exf = $pane->Frame()->pack(-anchor=>'w');
#my $exf2 = $t->Frame()->pack(-anchor=>'w');
my $edb =
$exf->Checkbutton(-variable => \$config{IPTCdateEXIF},
-text => "EXIF date -> creation date ")->pack(-anchor => 'w', -side => 'left');
$balloon->attach($edb, -msg => 'This option will copy EXIF date,
to the IPTC date created tag.');
my $etb =
$exf->Checkbutton(-variable => \$config{IPTCtimeEXIF},
-text => "EXIF time -> creation time ")->pack(-anchor => 'w', -side => 'left');
$balloon->attach($etb, -msg => 'This option will copy EXIF time,
to the IPTC time created tag.');
my $IbEo =
$exf->Checkbutton(-variable => \$config{IPTCbylineEXIF},
-text => "EXIF owner -> ByLine ")->pack(-anchor => 'w', -side => 'left');
$balloon->attach($IbEo, -msg => 'This option will copy the content of EXIF Owner,
or if not available the content of EXIF Artist,
or if not available the content of EXIF UserComment
to the IPTC ByLine tag.');
my $IMap =
$exf->Checkbutton(-variable => \$config{IPTCaddMapivi},
-text => "Add Mapivi infos")->pack(-anchor => 'w', -side => 'left');
$balloon->attach($IMap, -msg => 'This option will insert Mapivi
in the IPTC OriginatingProgram tag
and the actual Mapivi version
into the ProgramVersion tag.');
my $umlautB = $exf->Checkbutton(-variable => \$config{onlyASCII}, -text => 'Use only ASCII')->pack(-side => 'left', -anchor => 'w', -padx => 3, -pady => 1);
$balloon->attach($umlautB, -msg => "Remove non-ASCII chars and convert german umlaute (e.g. ä -> ae)\nNon-ASCII chars like umlaute often cause problems in other tools,\nso it's saver to remove or convert them to plain ASCII where possible.");
my $optF = $cN->Frame()->pack();
$optF->Label(-text => 'IPTC dialog layout')->pack(-anchor => 'w');
$optF->Radiobutton(-text => 'Simple', -variable => \$config{IPTCProfessional}, -value => 0)->pack(-anchor => 'w');
$optF->Radiobutton(-text => 'Professional without Category', -variable => \$config{IPTCProfessional}, -value => 2)->pack(-anchor => 'w');
$optF->Radiobutton(-text => 'Professional with Category', -variable => \$config{IPTCProfessional}, -value => 1)->pack(-anchor => 'w');
$cN->Label(-text => 'Note: According to the IPTC standard Categories are deprecated.')->pack();
$cN->Label(-text => 'Please choose IPTC dialog layout, close dialog and open it again to see changes.')->pack();
my $f = $pane->Frame()->pack(-anchor=>'w',-fill => 'x', -expand => 0);
# edit mode buttons only for more than one pictures
if ($nr > 1) {
my $rf = $f->Frame()->pack(-side => 'left', -anchor=>'w', -fill => 'x', -expand => 0);
my $radioB =
$rf->Label(-text => 'Edit mode')->pack(-side => 'left', -anchor => 'w');
$rf->Radiobutton(-text => lang('Add'), -variable => \$config{IPTC_action}, -value => 'ADD')->pack(-side => 'left', -anchor => 'w');
$rf->Radiobutton(-text => lang('Update'), -variable => \$config{IPTC_action}, -value => 'UPDATE')->pack(-side => 'left', -anchor => 'w');
$rf->Radiobutton(-text => lang('Replace'), -variable => \$config{IPTC_action}, -value => 'REPLACE')->pack(-side => 'left', -anchor => 'w');
$balloon->attach($rf, -msg =>
'Add: new records are added and nothing is deleted; however, if you
try to add a non-repeatable record which is already present,
the newly supplied value ejects (replaces) the pre-existing value.
Update: new records replace those characterised by the same tags,
but the others are preserved. This makes it possible to modify
some repeatable IPTC records without deleting the other tags.
Replace: all records present in the IPTC sub folder are deleted
before inserting the new ones.');
}
my $okb =
$f->Button(-text => lang('OK'), -command =>
sub {
# get the caption
${$iptc->{'Caption/Abstract'}}[0] = $caption->get(0.1, 'end');
${$iptc->{'Caption/Abstract'}}[0] =~ s/\s+$//; # remove trailing whitespace
$config{IPTCLastPad} = $notebook->raised();
if (Exists $keyword_frame) {
saveTreeMode($keyword_frame->{m_tree}); # todo
nstore($keyword_frame->{m_tree}->{m_mode}, "$user_data_path/keywordMode") or warn "could not store $user_data_path/keywordMode: $!";
}
if (Exists $category_frame) {
saveTreeMode($category_frame->{m_tree}); # todo
nstore($category_frame->{m_tree}->{m_mode}, "$user_data_path/categoryMode") or warn "could not store $user_data_path/categoryMode: $!";
}
$conf{iptc_geometry}{value} = $t->geometry; # save window size
$t->destroy; # close window
$rc = 'OK';
}
)->pack(-side => 'left', -fill => 'x', -expand => 1, -padx => 3, -pady => 3);
$balloon->attach($okb, -msg => "You can press Control-x to close the dialog (like OK button)");
$t->bind('', sub { $okb->Invoke; });
my $Xbut = $f->Button(-text => lang('Cancel'), -command =>
sub {
$config{IPTCLastPad} = $notebook->raised();
$conf{iptc_geometry}{value} = $t->geometry; # save window size
$t->destroy; # close window
$rc = 'Cancel';
}
)->pack(-side => 'left', -fill => 'x', -expand => 1, -padx => 3, -pady => 3);
$balloon->attach($Xbut, -msg => "You can press ESC to close the dialog (like Cancel button)");
bind_exit_keys_to_button($t, $Xbut);
$t->waitWindow;
return $rc;
}
##############################################################
# doubleList - mega widget containing two listboxes, an entry
# and some buttons
##############################################################
sub doubleList {
my $widget = shift; # mother widget
my $l1 = shift; # predefined list ref
my $l2 = shift; # real list ref
my $name = shift;
# build a frame for the keywords/categories
my $f = $widget->Frame(-bd => $config{Borderwidth}, -relief => 'raised')->pack(-expand => 1, -fill => 'both', -anchor=>'w', -padx => 3, -pady => 3);
$f->Label(-text => $name, -bg => $conf{color_bg}{value})->pack(-anchor=>'w', -padx => 2, -pady => 2);
my $fc1 = $f->Frame()->pack(-expand => 1, -fill => 'both', -side => 'left', -anchor=>'n');
my $fc2 = $f->Frame()->pack(-expand => 0, -fill => 'x', -side => 'left', -anchor=>'n');
my $fc3 = $f->Frame()->pack(-expand => 1, -fill => 'both', -side => 'left', -anchor=>'n');
$fc1->Label(-text => "common tags", -bg => $conf{color_bg}{value})->pack(-anchor=>'w', -padx => 2, -pady => 2);
my $catLB2;
my $category = '';
my $fcent = $fc1->Entry(-textvariable => \$category,
-width => 20)->pack(-fill => 'x', -padx => 2, -pady => 2);
$fcent->bind('',
sub {
return if ($category eq '');
# check if keyword/category is allready in list
return if isInList($category, $l2);
push @$l2, $category;
$category = '';
@$l2 = sort { uc($a) cmp uc($b) } @$l2;
$catLB2->delete(0, 'end');
$catLB2->insert('end', @$l2);
});
my $tree = $fc1->Scrolled('Tree',
-separator => '/',
-scrollbars => 'osoe',
-selectmode => 'extended',
-exportselection => 0,
-width => 26,
-height => 14,
)->pack(-expand => 1, -fill => 'both', -padx => 2, -pady => 2);
$widget->{m_tree} = $tree;
$balloon->attach($tree, -msg => "Double click on a item to insert it.\nIt's possible to edit the items, use the\nright mouse button to open the edit menu.");
# try to get the saved mode
my $modeRef;
if ($name eq 'keywords' and -f "$user_data_path/keywordMode") {
$modeRef = retrieve("$user_data_path/keywordMode");
}
if ($name eq 'supplemental categories' and -f "$user_data_path/categoryMode") {
$modeRef = retrieve("$user_data_path/categoryMode");
}
$tree->{m_mode} = $modeRef if (defined $modeRef);
addTreeMenu($tree, $l1);
insertTreeList($tree, @$l1);
# $tree->bind("", sub {
# my @keys = $keytree->info('selection');
# return unless checkSelection($myDiag, 1, 0, \@keys);
# $entry->insert("insert", getLastItem($keys[0])." ");
# });
$fc2->Label(-text => "command", -bg => $conf{color_bg}{value})->pack(-expand => 0, -anchor=>'w', -padx => 2, -pady => 2);
my $all = 0;
my $all_ref = \$all;
$all_ref = \$config{CategoriesAll} if ($name eq 'supplemental categories');
$all_ref = \$config{KeywordsAll} if ($name eq 'keywords');
my $addB =
$fc2->Button(-text => "add",
-command => sub {
my @keys = $tree->info('selection');
return unless checkSelection($widget, 1, 0, \@keys);
my @keylist;
my $warning = '';
my @items;
foreach my $key (@keys) {
if ($$all_ref == 1) { # all, separated
push @items, getAllItems($key);
}
elsif ($$all_ref == 2) { # all, joined
my $joined = join('.', getAllItems($key));
if (length($joined) > 64) {
$warning .= "Keyword $joined has ".length($joined)." characters";
next;
}
push @items, $joined;
}
elsif ($$all_ref == 0) { # last
push @items, getLastItem($key);
}else {
warn "doubleList: should never be reached!";
}
}
foreach my $item (@items) {
next if isInList($item, $l2); # make @$l2 unique
push @$l2, $item; # by adding just new items
@$l2 = sort { uc($a) cmp uc($b) } @$l2; # sort alphabetical
$catLB2->delete(0, 'end');
$catLB2->insert('end', @$l2);
}
} )->pack(-expand => 0, -fill => 'x', -padx => 1, -pady => 1);
$balloon->attach($addB, -msg => "Add the selected items to the picture");
my $fc2a = $fc2->Frame()->pack();
$fc2a->Radiobutton(-text => "all", -variable => $all_ref, -value => 1)->pack(-anchor => 'w');
$fc2a->Radiobutton(-text => "join", -variable => $all_ref, -value => 2)->pack(-anchor => 'w');
$fc2a->Radiobutton(-text => "last", -variable => $all_ref, -value => 0)->pack(-anchor => 'w');
$balloon->attach($fc2a, -msg => "$name add mode\nExample $name: Friend/Bundy/Kelly\nmode all: three $name: Friend, Bundy and Kelly\nmode join: one $name: Friend.Bundy.Kelly\nmode last: one $name: Kelly");
my $rmB =
$fc2->Button(-text => "remove",
-command => sub {
my @sellist = $catLB2->curselection();
if (@sellist < 1) {
print "nothing selected\n" if $verbose;
return;
}
# delete the selected elements in reverse order
foreach (reverse @sellist) {
splice @$l2, $_, 1;
}
$catLB2->delete(0, 'end');
$catLB2->insert('end', @$l2);
})->pack(-expand => 0, -fill => 'x', -padx => 1, -pady => 1);
$balloon->attach($rmB, -msg => "Remove the selected items from the picture");
$tree->bind('', sub { $addB->Invoke(); } );
$fc3->Label(-text => "tags of picture", -bg => $conf{color_bg}{value})->pack(-anchor=>'w');
$catLB2 =
$fc3->Scrolled('Listbox',
-scrollbars => 'osoe',
-selectmode => 'extended',
-exportselection => 0,
-width => 25,
-height => 14,
)->pack(-expand => 1, -fill =>'both', -padx => 2, -pady => 2);
$catLB2->insert('end', @$l2);
$catLB2->bind('', sub { $rmB->Invoke(); } );
}
##############################################################
# removeAllComments
##############################################################
sub removeAllComments {
my $ask = shift;
unless ($ask == ASK or $ask == NO_ASK) { warn "removeAllComments called with wrong argument: $ask"; return; }
my @sellist = $picLB->info('selection');
return unless checkSelection($top, 1, 0, \@sellist, lang("picture(s)"));
my $selected = @sellist;
if ($ask == ASK) {
my $rc = $top->messageBox(-icon => 'question', -message => "Ok to remove all comments of $selected selected pictures?\nThere is no undo!",
-title => "Remove all comments?", -type => 'OKCancel');
return if ($rc !~ m/Ok/i);
}
log_it("removing comments ...");
# check if some files are links
return if (!checkLinks($picLB, @sellist));
my $pw = progressWinInit($top, "Remove all comments");
my $i = 0;
foreach my $dpic (@sellist) {
last if progressWinCheck($pw);
$i++;
progressWinUpdate($pw, "removing all comments ($i/$selected) ...", $i, $selected);
my $pic = basename($dpic);
next if (!checkWriteable($dpic));
# check if file is a link and get the real target
next if (!getRealFile(\$dpic));
my $meta = getMetaData($dpic, 'COM');
next unless ($meta);
$meta->remove_all_comments();
unless ($meta->save()) { warn "removeAllComments: save $pic failed!"; }
# touch the thumbnail pic (set actual time stamp), to suppress rebuilding the next time
touch(getThumbFileName($dpic));
updateOneRow($dpic, $picLB);
showImageInfo($dpic) if ($dpic eq $actpic);
}
progressWinEnd($pw);
log_it("ready! (removed comments in $i of $selected pictures)");
}
##############################################################
# editComment
##############################################################
sub editComment {
my $lb = shift; # the reference to the listbox widget to update
my @sellist = $lb->info('selection');
return unless checkSelection($top, 1, 0, \@sellist, lang("picture(s)"));
my $selected = @sellist;
log_it("editing comments from $selected pictures");
# check if some files are links
return if (!checkLinks($lb, @sellist));
my $pw = progressWinInit($lb, "Edit comments");
my $i = 0;
foreach my $dpic (@sellist) {
last if progressWinCheck($pw);
$i++;
progressWinUpdate($pw, "editing comment ($i/$selected) ...", $i, $selected);
my $pic = basename($dpic);
my $dirthumb = getThumbFileName($dpic);
next if (!checkWriteable($dpic));
# check if file is a link and get the real target
next if (!getRealFile(\$dpic));
my @comsellist = ();
my $text = '';
my @comments = getComments($dpic);
if (@comments <= 0) {
next; # no comment -> no edit
} elsif (@comments == 1) {
$text = $comments[0]; # one comment -> select the first
$comsellist[0] = 0;
} else {
# more than one comment, let the user select one comment to edit
my $nr = @comments;
my @shortComments;
foreach (@comments) { push @shortComments, cutString($_, 80, "..."); }
next if (!mySelListBoxDialog("Edit comment of $pic",
"Please select one of the $nr comments to edit",
SINGLE,
"Edit", \@comsellist, @shortComments));
if (@comsellist != 1) {
$top->messageBox(-icon => 'warning', -message => "Please select just one comment.", -title => "Wrong selection", -type => 'OK');
next;
}
$text = $comments[$comsellist[0]];
}
my $rc = myTextDialog("Edit comment", "Please edit comment of $pic", \$text, $dirthumb);
next if ($rc ne 'OK');
# replace (german) umlaute by corresponding letters
$text =~ s/([$umlaute])/$umlaute{$1}/g if ($config{ConvertUmlaut});
$config{Comment} = $text; # save changed comment to global config hash
my $meta = getMetaData($dpic, "COM");
next unless ($meta);
$meta->set_comment($comsellist[0], $text);
unless ($meta->save()) { warn "editComment: save $pic failed!"; }
# touch the thumbnail pic (set actual time stamp), to suppress rebuilding the next time
touch($dirthumb);
updateOneRow($dpic, $lb);
showImageInfo($dpic) if ($dpic eq $actpic);
}
progressWinEnd($pw);
log_it("ready! ($i of $selected edited)");
}
##############################################################
# joinComments
##############################################################
sub joinComments {
my $ask = shift;
unless ($ask == ASK or $ask == NO_ASK) { warn "joinComments called with wrong argument: $ask"; return; }
my @sellist = $picLB->info('selection');
return unless checkSelection($top, 1, 0, \@sellist, lang("picture(s)"));
my $separator = "\n";
if ($ask == ASK) {
my $rc = myButtonDialog('Join comments?', "Ok to join all comments to one comment in each of the ".scalar @sellist." selected pictures?\n\n(Some programms are only able to display the fist comment of a JPEG picture.\nPictures with no or just one comment will be skipped.)\nPlease choose the desired separator when joining the comments.", undef, 'Space', 'Newline', 'Nothing', 'Cancel');
return if ($rc =~ m/Cancel/i);
$separator = ' ' if ($rc =~ m/Space/i);
$separator = '' if ($rc =~ m/Nothing/i);
}
log_it("joining comments from ".scalar @sellist." pictures");
# check if some files are links
return if (!checkLinks($picLB, @sellist));
my $pw = progressWinInit($top, "Join comments");
my $i = 0;
foreach my $dpic (@sellist) {
last if progressWinCheck($pw);
$i++;
progressWinUpdate($pw, "joining comments ($i/".scalar @sellist.") ...", $i, scalar @sellist);
my $pic = basename($dpic);
next if (!checkWriteable($dpic));
# check if file is a link and get the real target
next if (!getRealFile(\$dpic));
my $meta = getMetaData($dpic, "COM");
next unless ($meta);
my $nr = $meta->get_number_of_comments();
next if ($nr <= 1); # no or just one comment -> no join
my $com = getComments($dpic, 0);
if ((defined $com) and (length $com > $maxCommentLength)) { # a JPEG comment may have max 64kB
my $rc = $top->messageBox(-icon => 'warning', -message => "The joined comments of $dpic are too long (".length $com." characters).\nJPEG-Comments may only be up to 64K.\nOK will skip this picture, Cancel will abort the operation.",
-title => "Comment to big", -type => 'OKCancel');
return if ($rc !~ m/Ok/i);
next;
}
# join comments with configurable separator string
$meta->join_comments($separator);
unless ($meta->save()) { warn "editComment: save $pic failed!"; }
# touch the thumbnail pic (set actual time stamp), to suppress rebuilding the next time
touch(getThumbFileName($dpic));
updateOneRow($dpic, $picLB);
}
progressWinEnd($pw);
log_it("ready! ($i of ".scalar @sellist." joined)");
}
##############################################################
# checkTempFile - check if temp file exists
# returns 0 if it exists
# returns 1 if not
##############################################################
sub checkTempFile {
my $tmpfile = shift;
if (-f $tmpfile) {
$top->messageBox(-icon => 'warning', -message => "Temporary file $tmpfile already exists. Skipping!",
-title => 'Error', -type => 'OK');
return 0;
}
return 1;
}
##############################################################
# removeComment - remove a JPEG comment from a picture
# if there is more than one comment in the
# picture the user can
# choose which to delete
# if the same comment is selected in two pics
# we ask, if we should delete this one in all
##############################################################
sub removeComment {
my @sellist = $picLB->info('selection');
return unless checkSelection($top, 1, 0, \@sellist, lang("picture(s)"));
my $selected = @sellist;
my $doForAll = 0;
my @removedComments;
log_it("removing comments from $selected pictures");
# check if some files are links
return if (!checkLinks($picLB, @sellist));
my $pw = progressWinInit($top, "Remove comments");
my $i = 0;
my $j = 0; # the real number of changed pictures
foreach my $dpic (@sellist) {
last if progressWinCheck($pw);
$i++;
progressWinUpdate($pw, "removing comment ($i/$selected) ...", $i, $selected);
my $pic = basename($dpic);
next if (!checkWriteable($dpic));
# check if file is a link and get the real target
next if (!getRealFile(\$dpic));
my @comments = getComments($dpic);
next if (@comments <= 0);
# let the user select the comments to delete
my @comsellist = ();
# normal modus - let the user select what to remove
if (!$doForAll) {
my @shortComments;
foreach (@comments) { push @shortComments, cutString($_, 80, "..."); }
next if (!mySelListBoxDialog("Remove comments",
"Please select comment(s) to remove from $pic",
MULTIPLE,
"Remove", \@comsellist, @shortComments));
}
# comment remove wizard mode :) - we choose the right comment to delete
else {
for (0 .. $#comments) { # search in all comments
if ($comments[$_] eq $removedComments[-1]) { # for the magic comment
$comsellist[0] = $_; # remember the index
last;
}
}
}
if ( (@comsellist == 1) and ($doForAll == 0) ) { # if just one comment is removed
push @removedComments, $comments[$comsellist[0]]; # remember the removed comments
if (@removedComments >= 2) { # when we collected at least two ...
if ($removedComments[-1] eq $removedComments[-2]) { # and they are the same ...
if ($i < @sellist) { # and there is still some work to be done ...
my $com = $removedComments[-1];
$com = substr($com, 0, 100)."..." if (length($com) > 103);
my $rc = $top->messageBox(-icon => 'question', -message => "You've selected the same comment two times. Should I remove this comment:\n-------------\n$com\n-------------\nfrom the rest (".(@sellist - $i).") of the selected pictures?",
-title => "Comment remove wizard", -type => 'OKCancel');
$doForAll = 1 if ($rc =~ m/Ok/i);
}
}
}
}
# this can only happen in wizard mode (for pictures not containing the comment to remove)
next if (@comsellist == 0);
my $meta = getMetaData($dpic, 'COM');
next unless ($meta);
# delete the selected elements in reverse order, the unselected stay in the @comments
foreach (reverse @comsellist) {
$meta->remove_comment($_);
}
unless ($meta->save()) { warn "editComment: save $pic failed!"; }
$j++; # count the modified pics
# touch the thumbnail pic (set actual time stamp), to suppress rebuilding the next time
touch(getThumbFileName($dpic));
updateOneRow($dpic, $picLB);
showImageInfo($dpic) if ($dpic eq $actpic);
}
progressWinEnd($pw);
log_it("ready! (removed comments in $j of $selected pictures)");
}
##############################################################
# rotate - rotate all selected pictures by 90, 180 or 270
# degrees or do a flip transformation
##############################################################
sub rotate {
my @sellist = $picLB->info('selection');
return unless checkSelection($top, 1, 0, \@sellist, lang("picture(s)"));
my $selected = @sellist;
return if (!checkExternProgs("rotate", "jpegtran"));
my $deg = shift; # 90, 180, 270, auto, clear, horizontal or vertical
if ($deg eq "auto") {
return if (!checkExternProgs("auto rotate", "jhead"));
my $usage = `jhead -h 2>&1`;
if ($usage !~ m/.*-autorot.*/) {
$top->messageBox(-icon => 'warning', -message => "Sorry, but your version of jhead does not support automatic rotation!\nTry to get a newer version at: ".$exprogsres{jhead},
-title => "Wrong jhead version", -type => 'OK');
return;
}
}
elsif ($deg eq "clear") {
return if (!checkExternProgs("clear rotate", "jhead"));
my $usage = `jhead -h 2>&1`;
if ($usage !~ m/.*-norot.*/) {
$top->messageBox(-icon => 'warning', -message => "Sorry, but your version of jhead does not support the clearing of the rotation tag!\nTry to get a newer version at: ".$exprogsres{jhead},
-title => "Wrong jhead version", -type => 'OK');
return;
}
}
else { }
my $errors = '';
log_it("rotating $selected pictures");
# check if some files are links
return if (!checkLinks($picLB, @sellist));
my $pw = progressWinInit($top, "rotate pictures");
my $i = 0;
foreach my $dpic (@sellist) {
last if progressWinCheck($pw);
$i++;
my ($ok, $error) = rotate_pic($dpic, $deg);
$errors .= $error;
progressWinUpdate($pw, "rotating ($i/$selected) ...", $i, $selected);
updateOneRow($dpic, $picLB);
deleteCachedPics($dpic);
showPic($dpic) if ($ok and ($dpic eq $actpic)); # redisplay the picture if it is the actual one
}
progressWinEnd($pw);
reselect($picLB, @sellist);
log_it("ready! ($i of $selected rotated)");
showText("Errors while rotating pictures", $errors, NO_WAIT) if ($errors ne '');
generateThumbs(ASK, SHOW);
}
##############################################################
# rotate a single pic by 90, 180, 270, degree or
# auto, clear, flip horizontal or flip vertical
# !!!!!! WARNING !!!!!!!
# assumes that external progs are already checked!
# (checkExternProgs("rotate", "jpegtran")) , ... jhead
# see also rotate()
##############################################################
sub rotate_pic {
my $dpic = shift;
my $deg = shift;
my @allowed_args = qw(90 180 270 auto clear horizontal vertical);
my $valid = 0;
foreach (@allowed_args) {
if ($deg eq $_) {
$valid = 1; last;
}
}
if (not $valid) {
return (0, "rotate_pic called with invalid argument. Must be one of ".join(", ", @allowed_args)."\n");
}
my $pic = basename($dpic);
my $dirtpic = dirname($dpic)."/$pic"."-cjpg"; # temporary file
if (not checkWriteable($dpic)) {
return (0, "File $dpic is not writable! Exit rotate.\n");
}
# check if temp file exists
if (-f $dirtpic) {
return (0, "Temp file $dirtpic exists! Please delete first. Exit rotate.\n");
}
my $transform = "-rotate $deg";
if (($deg eq 'horizontal') or ($deg eq 'vertical')) {
$transform = "-flip $deg";
}
my $command = '';
if ($deg eq 'auto') { # auto
if (is_a_JPEG($dpic)) {
# call external command jhead and auto rotate the file directly
$command = "jhead -autorot \"$dpic\" ";
}
else {
return (0, "auto rotation is only supported for JPEGs ($dpic)\n");
}
}
elsif ($deg eq 'clear') { # clear
if (is_a_JPEG($dpic)) {
# call external command jhead and clear the rotation flag of the file directly
$command = "jhead -norot \"$dpic\" ";
}
else {
return (0, "clear rotation is only supported for JPEGs ($dpic)\n");
}
}
else {
if (is_a_JPEG($dpic)) {
my $trim = '';
$trim = "-trim " if $config{jpegtranTrim};
# call external command jpegtran and rotate to the temp file
$command = "jpegtran -copy all $transform $trim -outfile \"$dirtpic\" \"$dpic\" ";
}
else {
$transform = "-rotate $deg";
if ($deg eq "horizontal") {
$transform = "-flip";
}
if ($deg eq "vertical") {
$transform = "-flop";
}
$command = "mogrify $transform \"$dpic\" ";
}
}
if ($command ne '') {
execute($command);
# now overwrite the original pic with the temp file and delete the temp file
# (only needed for jpegtran; not needed for jhead and mogrify)
if ($command =~ m/jpegtran .*/) {
rotateThumb($dirtpic, $transform) if ($config{RotateThumb});
if (not overwrite($dpic, $dirtpic)) {
return (0, "Could not overwrite $dpic!\n");
}
}
}
else {
return (0, "rotate_pic: Found no command for $dpic\n");
}
return (1, '');
}
##############################################################
# rotateThumb
##############################################################
sub rotateThumb {
my $dpic = shift;
my $pic = basename($dpic);
my $tmppic = "$trashdir/$pic";
my $tmppic2 = "$trashdir/$pic.tcjpeg";
my $transform = shift;
print "rotateThumb: $pic $transform\n" if $verbose;
my $errors = '';
extractThumb($dpic, $tmppic, \$errors);
return unless (-f $tmppic); # there is no EXIF thumbnail
my $trim = '';
$trim = "-trim " if $config{jpegtranTrim};
my $command = "jpegtran -copy all $transform $trim -outfile \"$tmppic2\" \"$tmppic\" ";
execute($command);
removeFile($tmppic);
writeThumb($dpic, $tmppic2);
removeFile($tmppic2);
}
##############################################################
# extractThumb - extract embedded thumbnail picture and save
# it into a file
##############################################################
sub extractThumb {
my $dpic = shift; # picture file with path
my $dthumb = shift; # thumbnail file with path (will be overwritten!)
my $errors = shift; # reference to error text scalar
# extract information from an embedded thumbnail image using ExifTool
my $exifTool = new Image::ExifTool;
my $info = $exifTool->ImageInfo($dpic, 'thumbnailimage');
if ($info) {
my $thumbInfo = $exifTool->ImageInfo($$info{ThumbnailImage});
if (defined $thumbInfo and defined ${$$info{ThumbnailImage}}) {
my $thumbfile;
if (open($thumbfile,'>',$dthumb)) {
binmode $thumbfile;
print $thumbfile ${$$info{ThumbnailImage}};
close $thumbfile;
}
else {
$$errors .= "Couldn't open thumb $dthumb for write access\n";
}
}
else {
$$errors .= "No thumbnail in $dpic info block\n";
}
}
else {
$$errors .= "No thumbnail in $dpic\n";
}
}
##############################################################
# writeThumb - returns 1 if OK, else an error string
##############################################################
sub writeThumb {
my $dpic = shift; # the picture file with path to which the thumb will be written
my $dthumb = shift; # the thumbnail file name with path
my $error = 1;
my $image = new Image::MetaData::JPEG($dpic, 'APP1');
return "Could not read meta data of $dpic" unless ($image);
my $thimage = new Image::MetaData::JPEG($dthumb);
return "Could not read meta data of $dthumb" unless ($thimage);
my $data = "dummy";
unless ($thimage->save(\$data)) {
return "Could not build thumbnail for $dthumb";
}
my $hash = $image->set_Exif_data(\$data, 'THUMBNAIL');
return "JPEG thumbnail rejected for $dpic" if (keys %$hash);
my $result = $image->save();
return "save failed for $dpic" unless ($result);
return 1;
}
##############################################################
# buildEXIFThumb
##############################################################
sub buildEXIFThumb {
my $rc = $top->messageBox(-icon => "question",
-message => "This function will (re)build the embedded EXIF thumbnail of the selected pictures.\nThe original EXIF thumnail (if existent) will be overwritten!\nOk to continue?",
-title => "(Re)Build EXIF thumbnail", -type => 'OKCancel');
return if ($rc !~ m/Ok/i);
my @sellist = $picLB->info('selection');
my $selected = @sellist;
return unless checkSelection($top, 1, 0, \@sellist, lang("picture(s)"));
log_it("(re)building EXIF thumbnail in $selected pictures");
my $i = 0;
my $pw = progressWinInit($top, "(Re)build EXIF thumbnail");
foreach my $dpic (@sellist) {
last if progressWinCheck($pw);
progressWinUpdate($pw, "(Re)building EXIF thumbnail ($i/$selected) ...", $i, $selected);
$i++;
my $pic = basename($dpic);
my $thumb = "$trashdir/$pic-exifthumb";
if (-f $thumb) {
warn "the temp file $thumb exists - skipping!";
next;
}
# check if file is a link and get the real target
next if (!getRealFile(\$dpic));
next if (!checkWriteable($dpic));
my $command = "convert -size 160x160 -geometry 160x160 -quality 75 -sharpen 0.4 -filter Lanczos \"$dpic\" \"$thumb\"";
$top->Busy;
execute($command);
$top->Unbusy;
if (!-f $thumb) {
warn "file $thumb not generated - skipping!";
next;
}
my $errors;
removeEXIF($thumb, 'all', \$errors);
my $size = getFileSize($thumb, NO_FORMAT); # file size in bytes
if ($size > 65535) {
$top->messageBox(-icon => 'warning', -message => "Sorry, builded EXIF thumbnail picture is too big ($size bytes). The thumbnail picture must have less than 65535 bytes.\nSkipping picture ...",
-title => "Thumbnail too big", -type => 'OK');
next;
}
writeThumb($dpic, $thumb);
removeFile($thumb);
# touch the thumbnail pic (set actual time stamp), to suppress rebuilding the next time
touch(getThumbFileName($dpic));
updateOneRow($dpic, $picLB);
showImageInfo($dpic) if ($dpic eq $actpic);
}
progressWinEnd($pw);
log_it("ready! ($i/$selected EXIF thumbnails (re)builded)");
}
##############################################################
# reselect - selects the index in the given list, if they exist
# and shows the selection information in the status
# bar
##############################################################
sub reselect {
my $lb = shift;
# reselect does not work for the light table
return if (ref($lb) eq 'Tk::Canvas');
foreach (@_) { $lb->selectionSet($_) if ($lb->info("exists", $_)); }
showNrOf() if ($lb == $picLB);
}
##############################################################
# after moving or deleting pictures we try to select the picture
# after the last selected file
##############################################################
sub select_next {
my $lb = shift;
my $select = shift; # name of picture to select
if (not $select) {
# when the last picture has been deleted there is no next picture
# so we simply select the last picture which is available
my @childs = $lb->info('children');
$select = $childs[-1];
}
if ($lb->info("exists", $select)) {
if ($lb == $picLB) {
showPic($select);
}
else { # just select it
selectThumb($lb, $select);
}
}
}
##############################################################
# rotateAny - rotate all selected pictures in any angle
##############################################################
sub rotateAny {
return if (!checkExternProgs('rotateAny', 'mogrify'));
my @sellist = $picLB->info('selection');
return unless checkSelection($top, 1, 0, \@sellist, lang("picture(s)"));
my $selected = @sellist;
log_it("rotating $selected pictures");
# check if some files are links
return if (!checkLinks($picLB, @sellist));
my $doforall = 0;
my $degree = 0;
my $color = 'gray30';
my $pw = progressWinInit($top, "Rotate pictures");
my $i = 0;
foreach my $dpic (@sellist) {
last if progressWinCheck($pw);
$i++;
if (!$doforall) {
last if (!rotateDialog(\$degree, \$color, \$doforall, $dpic, $selected));
}
progressWinUpdate($pw, "rotating ($i/$selected) ...", $i, $selected);
# check if file is a link and get the real target
next if (!getRealFile(\$dpic));
next if (!checkWriteable($dpic));
next if (!makeBackup($dpic));
my $command = "mogrify -rotate $degree -bordercolor \"$color\" -background \"$color\" -quality $config{PicQuality} ";
$command .= "-unsharp ".$config{UnsharpRadius}.'x'.$config{UnsharpSigma}."+".$config{UnsharpAmount}."+".$config{UnsharpThreshold}." " if $config{Unsharp};
$command .= "\"$dpic\" ";
print "$command\n" if $verbose;
execute($command);
addProcessInfoToPicComment($command, $dpic);
updateOneRow($dpic, $picLB);
deleteCachedPics($dpic);
showPic($dpic) if ($dpic eq $actpic); # redisplay the picture if it is the actual one
}
progressWinEnd($pw);
reselect($picLB, @sellist);
log_it("ready! ($i of $selected rotated)");
generateThumbs(ASK, SHOW);
}
my $rotw;
##############################################################
# rotateDialog
##############################################################
sub rotateDialog {
my $deg = shift; # reference
my $col = shift; # reference
my $doforall = shift; # reference
my $pic = shift; # the preview pic
my $nr = shift; # the number of pics
my $preview_size = 400;
if (Exists($rotw)) {
$rotw->deiconify;
$rotw->raise;
return;
}
my $orig = "$trashdir/".basename($pic);
my $new = "$trashdir/x-".basename($orig);
unless (mycopy($pic, $orig, OVERWRITE)) {
warn "rotateDialog: copy error $pic -> $orig ($new)\ncopy";
return 0;
}
my ($w, $h) = getSize($orig);
if ($w > $preview_size or $h > $preview_size) {
log_it("rotate: resizing preview picture ...");
my $command = "mogrify -geometry ${preview_size}x${preview_size} -quality 80 \"$orig\"";
$top->Busy;
execute($command);
$top->Unbusy;
log_it(lang('Ready!'));
}
return 0 unless (-f $orig);
# open window
$rotw = $top->Toplevel();
$rotw->title("Rotate picture");
$rotw->iconimage($mapiviicon) if $mapiviicon;
my $rc = 0;
my $preview;
$preview = $rotw->Photo(-file => "$orig", -gamma => $config{Gamma}) if (-f $orig);
my $fc = $rotw->Frame()->pack();
my $prevC;
$prevC = $fc->Scrolled('Canvas',
-scrollbars => 'osoe',
-width => $preview_size,
-height => $preview_size,
-relief => 'sunken',
-bd => $config{Borderwidth})->pack(-side => 'left', -padx => 3, -pady => 3,-anchor => 'w') if $preview;
my $horizont = 0;
my $vertical = 0;
$fc->Scale(-variable => \$horizont,
-length => $preview_size,
-from => 0,
-to => $preview_size,
-resolution => 1,
-sliderlength => 10,
-orient => 'vertical',
-width => 10,
-bd => 1,
-showvalue => 0,
-relief => 'groove',
-command => sub {
drawHorizont($prevC, $horizont, $vertical);
} )->pack(-side => 'left', -padx => 3,-pady => 3);
$rotw->Scale(-variable => \$vertical,
-length => $preview_size,
-from => 0,
-to => $preview_size,
-resolution => 1,
-sliderlength => 10,
-orient => 'horizontal',
-width => 10,
-bd => 1,
-showvalue => 0,
-relief => 'groove',
-command => sub {
drawHorizont($prevC, $horizont, $vertical);
} )->pack(-anchor => 'w', -padx => 3,-pady => 3);
$prevC->createImage(0, 0, -image => $preview, -tag => "image", -anchor => "nw");
my $f1 = $rotw->Frame()->pack(-anchor => 'w');
my $auto = 0;
$f1->Checkbutton(-text => "auto update", -variable => \$auto)->pack(-side => 'left', -expand => 1, -fill => 'x');
$f1->Button(-text => "--", -command => sub {
$$deg--;
rotUpdate($prevC, $preview, $orig, $new, $deg, $col) if $auto;
})->pack(-side => 'left', -expand => 1, -fill => 'x');
$f1->Button(-text => "-", -command => sub {
$$deg -= 0.1;
rotUpdate($prevC, $preview, $orig, $new, $deg, $col) if $auto;
})->pack(-side => 'left', -expand => 1, -fill => 'x');
$f1->Label(-textvariable => $deg, -relief => 'sunken', -width => 5)->pack(-side => 'left', );
$f1->Button(-text => "+", -command => sub {
$$deg += 0.1;
rotUpdate($prevC, $preview, $orig, $new, $deg, $col) if $auto;
})->pack(-side => 'left', -expand => 1, -fill => 'x');
$f1->Button(-text => "++", -command => sub {
$$deg++;
rotUpdate($prevC, $preview, $orig, $new, $deg, $col) if $auto;
})->pack(-side => 'left', -expand => 1, -fill => 'x');
labeledScale($rotw, 'top', 26, "Angle (degrees, clockwise)", $deg, 0, 359.9, 0.1);
my $qS = labeledScale($rotw, 'top', 26, lang("Quality (%)"), \$config{PicQuality}, 10, 100, 1);
qualityBalloon($qS);
labeledEntryColor($rotw,'top',26,"Background color",'Set',$col);
# check, if a new version of ImageMagick's mogrify with the unsharp option is available
my $unsharp = 0;
$unsharp = 1 if (`mogrify` =~ m/.*-unsharp.*/);
# sharpen the image with an unsharp mask operator
if ($unsharp) {
my $umF = $rotw->Frame()->pack(-fill =>'x');
my $umcB = $umF->Checkbutton(-variable => \$config{Unsharp},
-anchor => 'w',
-text => "Unsharp mask")->pack(-side => 'left', -anchor => 'w', -fill => 'x', -expand => 1);
$balloon->attach($umcB, -msg => "The -unsharp option sharpens an image.
We convolve the image with a Gaussian operator of the given radius
and standard deviation (sigma).
For reasonable results, radius should be larger than sigma.
Use a radius of 0 to have the method select a suitable radius.");
$umF->Button(-text => "Options",
-anchor => 'w',
-command => sub { unsharpDialog(); })->pack(-side => 'left', -anchor => 'w', -padx => 3);
}
buttonBackup($rotw, 'top');
buttonComment($rotw, 'top');
if ($nr > 1) {
$rotw->Checkbutton(-variable => \$$doforall,
-anchor => 'w',
-text => "use this setting for all pics"
)->pack(-anchor => 'w');
}
my $ButF = $rotw->Frame()->pack(-fill =>'x', -padx => 3, -pady => 3);
my $OKB = $ButF->Button(-text => lang('OK'),
-command => sub {
$rc = 1;
$rotw->withdraw();
$rotw->destroy();
}
)->pack(-side => 'left', -expand => 1, -fill => 'x', -padx => 3, -pady => 3);
$ButF->Button(-text => "Preview",
-command => sub {
rotUpdate($prevC, $preview, $orig, $new, $deg, $col);
}
)->pack(-side => 'left', -expand => 1, -fill => 'x', -padx => 3, -pady => 3) if $preview;
my $XBut = $ButF->Button(-text => lang('Cancel'),
-command => sub {
$rc = 0;
$rotw->withdraw();
$rotw->destroy();
}
)->pack(-side => 'left', -expand => 1, -fill => 'x', -padx => 3, -pady => 3);
bind_exit_keys_to_button($rotw, $XBut);
$rotw->Popup;
$rotw->waitWindow;
# clean up
$preview->delete;
removeFile($orig);
removeFile($new);
return $rc;
}
##############################################################
# bind Ctrl-q and ESC key and window close button to invoke
# given window exit button (e.g. "Cancel" button)
##############################################################
sub bind_exit_keys_to_button {
my $w = shift; # widget / window
my $button = shift; # Exit button (e.g. Cancel) to invoke on quit
# check arguments
if (ref($w) ne 'Tk::Toplevel') {
warn "bind_exit_keys_to_button called with wrong argument w: ".ref($w);
return 0;
}
if (ref($button) ne 'Tk::Button') {
warn "bind_exit_keys_to_button called with wrong argument button: ".ref($button);
return 0;
}
$w->bind('', sub { $button->Invoke; });
$w->bind('', sub { $button->Invoke; });
$w->protocol("WM_DELETE_WINDOW" => sub { $button->Invoke; });
return 1;
}
##############################################################
# drawHorizont
##############################################################
sub drawHorizont {
my $canvas = shift;
my $y = shift; # in percent of the canvas height
my $x = shift; # in percent of the canvas width
$canvas->delete('withtag', 'line');
$canvas->createLine( 0, $y, $canvas->width, $y,
-tags => 'line',
-fill => 'black',
-dash => [6,4,2,4],
);
$canvas->createLine( 0, $y, $canvas->width, $y,
-tags => 'line',
-fill => 'white',
-dash => [2,6,2,4],
);
$canvas->createLine( $x, 0, $x, $canvas->height,
-tags => 'line',
-fill => 'black',
-dash => [6,4,2,4],
);
$canvas->createLine( $x, 0, $x, $canvas->height,
-tags => 'line',
-fill => 'white',
-dash => [2,6,2,4],
);
}
##############################################################
# rotUpdate - update the picture in the rotateDialog with the
# new degree setting
##############################################################
sub rotUpdate {
my ($prevC, $preview, $orig, $new, $deg, $col) = @_;
return if !mycopy($orig, $new, OVERWRITE);
$rotw->Busy;
# some versions of mogrify need bordercolor, some background so we supply both
my $command = "mogrify -rotate $$deg -bordercolor \"$$col\" -background \"$$col\" \"$new\" ";
execute($command);
$preview->configure(-file => $new, -gamma => $config{Gamma});
my ($id) = $prevC->find('withtag', 'image');
my ($x1, $y1, $x2, $y2) = $prevC->bbox($id);
$prevC->configure(-scrollregion => [0, 0, $x2-$x1, $y2-$y1]);
$rotw->Unbusy;
}
##############################################################
# getRealFile - alters the path and file name to the real file
# if it's a link, else do nothing
# returns 1 if everything worked, else 0
##############################################################
sub getRealFile {
my $dirfileR = shift; # reference to a file, which may be a link
if (!-f $$dirfileR) {
my $file = Encode::encode('iso-8859-1', $$dirfileR);
warn "getRealFile: $$dirfileR ($file) is no file!";
return 0;
}
if (-l $$dirfileR) {
my $linktargetfile = getLinkTarget($$dirfileR);
if ($linktargetfile eq '') {
warn "error in getLinkTarget! ($$dirfileR)";
return 0;
}
else {
$$dirfileR = $linktargetfile;
return 1;
}
}
else { # no link, change nothing, return true
return 1;
}
}
##############################################################
# getLinkTarget - returns the file a link is pointing to
# input (folder, link) or (dirlink) where
# dirlink consists of folder and link
# works with relative and absolute links
##############################################################
sub getLinkTarget {
my ($dir, $link);
if (@_ == 2) {
$dir = shift;
$link = shift;
}
elsif (@_ == 1) {
$dir = dirname($_[0]);
$link = basename($_[0]);
}
else {
warn "getLinkTarget: wrong # of parameters!";
return '';
}
# change first to the start dir (to handle relative links)
return '' if !changeDir($dir);
my $linktargetfile = readlink $link;
my $linktargetdir = dirname $linktargetfile;
# change to link target, this should now work for relative and absolute links
return '' if !changeDir($linktargetdir);
# get the current dir
my $cwd = cwd();
$linktargetfile = $cwd.'/'.basename($linktargetfile);
return $linktargetfile;
}
##############################################################
# overwrite - takes two files a and b, deletes a and moves b
# to a
# the file names must include the absolute path
##############################################################
sub overwrite {
my $dpic = shift;
my $dirtpic = shift;
if (!-f $dirtpic) {
warn "overwrite: $dirtpic not created. Giving up!";
return 0;
}
if (-l $dpic) {
my $linktargetfile = getLinkTarget($dpic);
$dpic = $linktargetfile;
}
return 0 if (! removeFile($dpic) );
if (!move($dirtpic, $dpic)) {
$top->Dialog(-title => "Move $dirtpic",
-text => "Couldn't move $dirtpic to $dpic: $!",
-buttons => ['Ok'])->Show();
return 0;
}
return 1;
}
##############################################################
# myEntryDialog - get a string from the user
# returns 'OK' or 'Cancel'
##############################################################
# ToDo: should return true or false instead of Ok/Cancel
sub myEntryDialog {
my $title = shift;
my $text = shift;
my $varRef = shift;
my $thumbnail = shift; # optional
my $icon;
my $rc = 'Cancel';
# open window
my $myDiag = $top->Toplevel();
$myDiag->title($title);
$myDiag->iconimage($mapiviicon) if $mapiviicon;
my $f = $myDiag->Frame()->pack(-fill => 'both', -expand => 1);
if ((defined $thumbnail) and (-f $thumbnail)) {
$icon = $top->Photo(-file => $thumbnail, -gamma => $config{Gamma});
if ($icon) {
$f->Label(-image => $icon, -bg => $conf{color_bg}{value}, -relief => 'sunken',
)->pack(-side => 'left', -fill => 'x', -padx => 3, -pady => 3);
}
}
# determine the heigt of the textbox by counting the number of lines
my $height = ($text =~ tr/\n//);
$height += 2;
$height = 30 if ($height > 30); # not to big, we have scrollbars
my $rotext = $f->Scrolled('ROText',
-scrollbars => 'osoe',
-wrap => 'word',
-tabs => '4',
-width => 80,
-height => $height,
-relief => 'flat',
-bg => $conf{color_bg}{value},
-bd => 0
)->pack(-side => 'right', -fill => 'both', -expand => 1, -padx => 3, -pady => 3);
$rotext->insert('end', $text);
my $OKB;
my $entry =
$myDiag->Entry(-textvariable => \$$varRef,
-width => 40,
)->pack(-fill => 'x', -padx => 3, -pady => 3);
if ($$varRef =~ /(.*)(\.jp(g|eg))/i) { # if it is a jpeg image name
$entry->selectionRange(0,length($1)); # select only the part before the suffix
$entry->icursor(length($1));
}
else {
$entry->selectionRange(0,'end'); # else select all
$entry->icursor('end');
}
$entry->xview('end');
$entry->bind('', sub { $OKB->Invoke; } );
$entry->focus;
my $ButF = $myDiag->Frame()->pack(-fill =>'x', -padx => 3, -pady => 3);
$OKB = $ButF->Button(-text => lang('OK'),
-command => sub {
$rc = 'OK';
$myDiag->destroy;
})->pack(-side => 'left', -expand => 1, -fill => 'x',
-padx => 3, -pady => 3);
my $XBut = $ButF->Button(-text => lang('Cancel'),
-command => sub {
$rc = 'Cancel';
$myDiag->destroy;
}
)->pack(-side => 'left', -expand => 1, -fill => 'x',
-padx => 3, -pady => 3);
bind_exit_keys_to_button($myDiag, $XBut);
$myDiag->Popup;
repositionWindow($myDiag);
$myDiag->waitWindow();
$icon->delete if $icon;
return $rc;
}
##############################################################
# myFontDialog - dialog to select a font family
##############################################################
sub myFontDialog {
my $widget = shift;
my $title = shift;
#my $text = shift;
my $varRef = shift;
my $size = shift;
my $rc = 0;
# open window
my $myDiag = $widget->Toplevel();
$myDiag->title($title);
$myDiag->iconimage($mapiviicon) if $mapiviicon;
my $listBox = $myDiag->Scrolled('Listbox',
-scrollbars => 'osoe',
-selectmode => 'single',
-exportselection => 0,
-width => 30,
#-height => 40,
)->pack(-side => 'left', -anchor => 'w', -expand => 1, -fill =>'y', -padx => 3, -pady => 3);
my $f = $myDiag->Frame()->pack(-side => 'left', -expand => 1, -anchor => 'w', -fill =>'both');
my @fontFamilies = sort $top->fontFamilies;
shift @fontFamilies unless ($fontFamilies[0]);
$listBox->insert('end', @fontFamilies);
foreach my $i (0 .. $#fontFamilies) {
if ($fontFamilies[$i] eq $$varRef) {
$listBox->selectionSet($i);
$listBox->see($i);
last;
}
}
my $normalText = "This is a preview Text, here you can see how the selected font will look like.\n\nThe brown fox jumps over the brigde.\n\n1 :\n12 :\n123 :\n1234 :\n12345 :\nWWWWWWW:\niiiiiii:\n\040\041\042\043\044\045\046\047\050\051\052\053\054\055\056\057\040\041\042\043\044\045\046\047\050\051\052\053\054\055\056\057\060\061\062\063\064\065\066\067\070\071\072\073\074\075\076\077\100\n\101\102\103\104\105\106\107\110\111\112\113\114\115\116\117\120\121\122\123\124\125\126\127\130\131\132\133\134\135\136\137\140\141\142\143\144\145\146\147\150\151\152\153\154\155\156\157\160\161\162\163\164\165\166\167\170\171\172\173\174\175\176\n\200\201\202\203\204\205\206\207\210\211\212\213\214\215\216\217\220\221\222\223\224\225\226\227\230\231\232\233\234\235\236\237\240\241\242\243\244\245\246\247\250\251\252\253\254\255\256\257\n\260\261\262\263\264\265\266\267\270\271\272\273\274\275\276\277\300\301\302\303\304\305\306\307\310\311\312\313\314\315\316\317\320\321\322\323\324\325\326\327\330\331\332\333\334\335\336\337\n\340\341\342\343\344\345\346\347\350\351\352\353\354\355\356\357\360\361\362\363\364\365\366\367\370\371\372\373\374\375\376\377";
my $ButF = $f->Frame()->pack(-fill =>'x', -padx => 3, -pady => 3);
my $pane = $f->Scrolled('Pane', -bd => $config{Borderwidth}, -relief => 'groove', -scrollbars => 'osoe', -width => 1000)->pack(-expand => 1, -anchor => 'w', -fill => 'both', -padx => 3, -pady => 3);
my $example = $pane->Label(-text => $normalText, -bg => $conf{color_bg}{value}, -justify => 'left')->pack(-fill => 'both', -expand => 1, -anchor => 'w');
$listBox->bind('', sub {
my @sell = $listBox->curselection();
return unless @sell;
my $actfont = $fontFamilies[$sell[0]];
return unless $actfont;
$myDiag->Busy;
my $font = $top->Font(-family => $actfont,
-size => $size);
$example->configure(-font => $font);
$example->update();
$myDiag->Unbusy;
} );
$ButF->Button(-text => lang('Next'),
-command => sub {
my @sell = $listBox->curselection();
return unless @sell;
my $index = $sell[0];
$listBox->selectionClear(0, 'end');
$index++;
$index = 0 if ($index >= @fontFamilies);
$listBox->selectionSet($index);
$listBox->see($index);
my $actfont = $fontFamilies[$index];
return unless $actfont;
$myDiag->Busy;
my $font = $top->Font(-family => $actfont,
-size => $size);
$example->configure(-font => $font);
$example->update();
$myDiag->Unbusy;
})->pack(-side => 'left', -expand => 1, -fill => 'x', -padx => 3, -pady => 3);
$ButF->Button(-text => lang('Previous'),
-command => sub {
my @sell = $listBox->curselection();
return unless @sell;
my $index = $sell[0];
$listBox->selectionClear(0, 'end');
$index--;
$index = $#fontFamilies if ($index < 0);
$listBox->selectionSet($index);
$listBox->see($index);
my $actfont = $fontFamilies[$index];
return unless $actfont;
$myDiag->Busy;
my $font = $top->Font(-family => $actfont,
-size => $size);
$example->configure(-font => $font);
$example->update();
$myDiag->Unbusy;
})->pack(-side => 'left', -expand => 1, -fill => 'x', -padx => 3, -pady => 3);
my $OKB = $ButF->Button(-text => lang('OK'),
-command => sub {
my @sell = $listBox->curselection();
$$varRef = $fontFamilies[$sell[0]] if @sell;
$rc = 1;
$myDiag->destroy;
})->pack(-side => 'left', -expand => 1, -fill => 'x',
-padx => 3, -pady => 3);
$myDiag->bind ('', sub { $OKB->Invoke; } );
$listBox->bind('', sub { $OKB->Invoke; } );
$OKB->focus;
my $XBut = $ButF->Button(-text => lang('Cancel'),
-command => sub {
$rc = 0;
$myDiag->destroy;
}
)->pack(-side => 'left', -expand => 1, -fill => 'x',
-padx => 3, -pady => 3);
bind_exit_keys_to_button($myDiag, $XBut);
my $ws = 0.5;
my $w = int($ws * $myDiag->screenwidth);
my $h = int($ws * $myDiag->screenheight);
my $x = int(((1 - $ws) * $myDiag->screenwidth)/3);
my $y = int(((1 - $ws) * $myDiag->screenheight)/3);
#print "geo==${w}x${h}+${x}+${y}\n";
$myDiag->geometry("${w}x${h}+${x}+${y}");
$myDiag->Popup;
repositionWindow($myDiag);
$myDiag->waitWindow();
return $rc;
}
##############################################################
# myPicDialog - show some thumbnails and a text to the user
# returns 'OK' or content of $button
##############################################################
sub myPicDialog {
my $title = shift;
my $text = shift;
my $button = shift; # optional button, if not needed set to ''
my @thumbnails = @_;
my @icons;
my $rc = $button;
# open window
my $myDiag = $top->Toplevel();
$myDiag->title($title);
$myDiag->iconimage($mapiviicon) if $mapiviicon;
# determine the heigt of the textbox by counting the number of lines
my $height = ($text =~ tr/\n//);
$height += 2;
$height = 50 if ($height > 50); # not to big, we have scrollbars
my $rotext = $myDiag->Scrolled('ROText',
-scrollbars => 'osoe',
-wrap => 'word',
-tabs => '4',
-width => 40,
-height => $height,
-relief => 'flat',
-bg => $conf{color_bg}{value},
-bd => 0
)->pack(-fill => 'both', -expand => 1, -padx => 3, -pady => 3);
$rotext->insert('end', $text);
my $f = $myDiag->Frame()->pack;
my $i = 0;
# insert the thumbnails
foreach (@thumbnails) {
if ((defined $_) and (-f $_)) {
$icons[$i] = $top->Photo(-file => "$_", -gamma => $config{Gamma});
if ($icons[$i]) {
$f->Label(-image => $icons[$i], -bg => $conf{color_bg}{value}, -relief => 'sunken',
)->pack(-side => 'left', -anchor => 'n', -fill => 'x', -padx => 3, -pady => 3);
$i++;
}
}
}
my $bf = $myDiag->Frame()->pack(-expand => 1, -fill => 'x');
my $OKB = $bf->Button(-text => 'OK', -command => sub { $rc = 'OK'; $myDiag->destroy; }
)->pack(-side => 'left', -expand => 1, -fill => 'x', -padx => 3, -pady => 3);
$OKB->focus;
if ($button ne '') {
$bf->Button(-text => $button, -command => sub { $rc = $button; $myDiag->destroy; }
)->pack(-side => 'left', -expand => 1, -fill => 'x', -padx => 3, -pady => 3);
}
$myDiag->bind('', sub { $OKB->Invoke; });
$myDiag->Popup;
repositionWindow($myDiag);
$myDiag->waitWindow();
foreach (@icons) { $_->delete if $_; } # free memory
return $rc;
}
##############################################################
# myButtonDialog - get a feedback from the user
# you may specify as many buttons as you like
# the return value will be the text of the button pressed
# The first one is the default button
# the last one is invoked when pressing Escape
##############################################################
sub myButtonDialog {
my $title = shift;
my $text = shift;
my $thumbnail = shift;
my @buttons = @_;
my $icon;
my $rc = '';
# open window
my $myDiag = $top->Toplevel();
$myDiag->title($title);
$myDiag->iconimage($mapiviicon) if $mapiviicon;
my $f = $myDiag->Frame()->pack(-fill => 'both', -expand => 1);
if ((defined $thumbnail) and (-f $thumbnail)) {
$icon = $top->Photo(-file => "$thumbnail", -gamma => $config{Gamma});
if ($icon) {
$f->Label(-image => $icon, -bg => $conf{color_bg}{value}, -relief => 'sunken',
)->pack(-side => 'left', -fill => 'x', -padx => 3, -pady => 3);
}
}
# determine the heigt of the textbox by counting the number of lines
my $height = ($text =~ tr/\n//);
$height += 2;
$height = 50 if ($height > 50); # not to big, we have scrollbars
my $rotext = $f->Scrolled('ROText',
-scrollbars => 'osoe',
-wrap => 'word',
-tabs => '4',
-width => 90,
-height => $height,
-relief => 'flat',
-bg => $conf{color_bg}{value},
-bd => 0
)->pack(-side => 'right', -fill => 'both', -expand => 1, -padx => 3, -pady => 3);
$rotext->insert('end', $text);
my %buts;
my $ButF = $myDiag->Frame()->pack(-fill =>'x', -padx => 3, -pady => 3);
# add the buttons
foreach (@buttons) {
my $name = $_;
$buts{$name} = $ButF->Button(-text => "$name",
-command => sub {
$rc = "$name";
})->pack(-side => 'left', -expand => 1, -fill => 'x',
-padx => 3, -pady => 3);
}
# the first button gets the focus and is invoked with return
$myDiag->bind('', sub { $buts{$buttons[0]}->Invoke; } );
$buts{$buttons[0]}->focus;
# the last button is invoked with the Escape key
$myDiag->bind('', sub { $buts{$buttons[-1]}->Invoke; });
$myDiag->Popup;
repositionWindow($myDiag);
$myDiag->waitVariable(\$rc);
$icon->delete if $icon;
$myDiag->destroy();
$top->focus;
return $rc;
}
##############################################################
# checkDialog - a dialog with a Checkbutton (e.g. do not show
# this again ...)
##############################################################
sub checkDialog {
my $title = shift;
my $text = shift;
my $check = shift; # var ref
my $checkT = shift; # the text for the checkbutton
my $thumbnail = shift; # !!! not optional, supply '' if there is no thumbnail to show
my @buts = @_; # the button text, this text will be returned
my $icon;
my $rc;
# open window
my $myDiag = $top->Toplevel();
$myDiag->title($title);
$myDiag->iconimage($mapiviicon) if $mapiviicon;
my $f = $myDiag->Frame()->pack;
if ((defined $thumbnail) and (-f $thumbnail)) {
$icon = $top->Photo(-file => "$thumbnail", -gamma => $config{Gamma});
if ($icon) {
$f->Label(-image => $icon, -bg => $conf{color_bg}{value},
)->pack(-side => 'left', -fill => 'x', -padx => 3, -pady => 3);
}
}
# determine the heigt of the textbox by counting the number of lines
my $height = ($text =~ tr/\n//);
$height += 2;
$height = 50 if ($height > 50); # not to big, we have scrollbars
my $rotext = $f->Scrolled('ROText',
-scrollbars => 'osoe',
-wrap => 'word',
-tabs => '4',
-width => 55,
-height => $height,
-relief => 'flat',
-bg => $conf{color_bg}{value},
-bd => 0
)->pack(-side => 'right', -fill => 'both', -expand => 1, -padx => 3, -pady => 3);
$rotext->insert('end', $text);
my $OKB;
$myDiag->Checkbutton(-variable => \$$check,
-text => $checkT,
)->pack(-fill => 'x',
-padx => 3,
-pady => 3);
my $ButF =
$myDiag->Frame()->pack(-fill =>'x',
-padx => 3,
-pady => 3);
foreach my $text (@buts) {
$ButF->Button(-text => "$text",
-command => sub {
$rc = "$text";
})->pack(-side => 'left',
-expand => 1,
-fill => 'x',
-padx => 3,
-pady => 3);
}
$myDiag->Popup;
repositionWindow($myDiag);
$myDiag->waitVariable(\$rc);
$icon->delete if $icon;
$myDiag->withdraw();
$myDiag->destroy();
return $rc;
}
##############################################################
# myTextDialog - get a text from the user
##############################################################
sub myTextDialog {
my $title = shift;
my $text = shift;
my $varRef = shift;
my $thumb = shift; # optional file name of thumbnail
my ($rc, $icon);
# open window
my $myDiag = $top->Toplevel();
#$myDiag->grab();
$myDiag->title($title);
$myDiag->iconimage($mapiviicon) if $mapiviicon;
$myDiag->Label(-text => $text, -bg => $conf{color_bg}{value}
)->pack(-fill => 'x', -padx => 3, -pady => 3);
my $fl = $myDiag->Frame()->pack(-anchor => 'n', -side => 'left');
my $fm = $myDiag->Frame()->pack(-expand => 1, -fill => 'both', -anchor => 'n', -side => 'left');
my $fr = $myDiag->Frame()->pack(-expand => 1, -fill => 'both', -anchor => 'n', -side => 'left');
if ((defined $thumb) and (-f $thumb)) {
$icon = $myDiag->Photo(-file => "$thumb", -gamma => $config{Gamma});
if ($icon) {
$fl->Label(-image => $icon, -bg => $conf{color_bg}{value}, -relief => 'sunken',
)->pack(-padx => 1, -pady => 2);
}
}
my $topButF = $fm->Frame(-bd => $config{Borderwidth}, -relief => 'groove')->pack(-fill =>'x', -padx => 3, -pady => 3);
my $midF = $fm->Frame()->pack(-expand => 1, -fill => 'both', -padx => 0, -pady => 3);
my $entry = $midF->Scrolled("Text",
-scrollbars => 'osoe',
-wrap => 'none',
-width => 65,
-height => 20,
)->pack(-side => 'left', -expand => 1, -fill => 'both', -padx => 3, -pady => 3);
$entry->insert('end', $$varRef);
#$entry->selectionRange(0,'end');
$entry->see('end');
$entry->markSet("insert",'end');
my $keytree = $fr->Scrolled('Tree',
-separator => '/',
-scrollbars => 'osoe',
-selectmode => 'single',
-exportselection => 0,
-width => 20,
)->pack(-expand => 1, -fill => 'both', -padx => 2, -pady => 2);
$balloon->attach($keytree, -msg => "Double click on a keyword to insert it.\nIt's possible to edit the keywords, use the\nright mouse button to open the edit menu.");
# try to get the saved mode
if (-f "$user_data_path/keywordMode") {
my $hashRef = retrieve("$user_data_path/keywordMode");
warn "could not retrieve mode" unless defined $hashRef;
$keytree->{m_mode} = $hashRef;
}
addTreeMenu($keytree, \@prekeys);
insertTreeList($keytree, @prekeys);
$keytree->bind("", sub {
my @keys = $keytree->info('selection');
return unless checkSelection($myDiag, 1, 0, \@keys);
$entry->insert("insert", getLastItem($keys[0])." ");
$entry->focus;
});
my $ButF = $fm->Frame()->pack(-fill =>'x', -padx => 3, -pady => 3);
my $umlautB = $ButF->Checkbutton(-variable => \$config{ConvertUmlaut}, -text => 'convert german umlaute')->pack(-side => 'left', -anchor => 'w', -padx => 3, -pady => 1);
$balloon->attach($umlautB, -msg => "Convert german umlaute (e.g. ä -> ae)\nUmlaute often cause problems in other tools,\nso it's saver to convert them to plain ASCII.");
my $OKB =
$ButF->Button(-text => lang('OK'),
-command => sub {
$$varRef = $entry->get(0.1, 'end');
trimComment($varRef);
my $len = length($$varRef);
if ($len >= $maxCommentLength) {
$top->messageBox(-icon => 'warning', -message => "Sorry your comment is too long ($len characters).\nJPEG-Comments may only be up to 64K.\nPlease shorten your comment.",
-title => "Comment to long", -type => 'OK');
return;
}
$rc = 'OK';
saveTreeMode($keytree);
nstore($keytree->{m_mode}, "$user_data_path/keywordMode") or warn "could not store $user_data_path/keywordMode: $!";
$myDiag->destroy();
})->pack(-side => 'left', -expand => 1, -fill => 'x', -padx => 3, -pady => 3);
$balloon->attach($OKB, -msg => "You can press Control-x to close the dialog (OK button)");
# key-desc,Ctrl-x,accept text and close (in text dialog)
$myDiag->bind('', sub { $OKB->Invoke; });
$topButF->Label(-text => lang("Insert ..."), -bg => $conf{color_bg}{value},
)->pack(-side => 'left', -expand => 0, -fill => 'x', -padx => 3, -pady => 3);
my $crb =
$topButF->Button(-text => lang('Copyright'),
-command => sub {
$entry->insert("insert", $config{Copyright});
})->pack(-side => 'left', -expand => 0, -fill => 'x', -padx => 3, -pady => 3);
$myDiag->bind('', sub { $crb->Invoke; });
$topButF->Button(-text => lang('File name'),
-command => sub {
$entry->insert("insert", basename($actpic));
})->pack(-side => 'left', -expand => 0, -fill => 'x', -padx => 3, -pady => 3);
$topButF->Button(-text => lang('Last comment'),
-command => sub {
$entry->insert("insert", $config{Comment});
})->pack(-side => 'left', -expand => 0, -fill => 'x', -padx => 3, -pady => 1);
$topButF->Button(-text => lang("File ..."),
-command => sub {
my $file = $myDiag->getOpenFile(-title => 'Add comment from file', -initialdir => $actdir);
return if ((!defined $file) or ($file eq '') or (!-f $file));
my $fileH;
if (!open($fileH, '<', $file)) {
warn "Sorry, I couldn't open the file $file: $!";
return;
}
my $buffer;
read $fileH, $buffer, 32768; # <- todo!!!
close($fileH);
$entry->insert("insert", $buffer);
})->pack(-side => 'left', -expand => 0, -fill => 'x', -padx => 3, -pady => 3);
$ButF->Button(-text => lang('Cancel'),
-command => sub {
$rc = 'Cancel';
saveTreeMode($keytree);
nstore($keytree->{m_mode}, "$user_data_path/keywordMode") or warn "could not store $user_data_path/keywordMode: $!";
$myDiag->destroy();
})->pack(-side => 'left', -expand => 1, -fill => 'x', -padx => 3, -pady => 3);
$entry->focus;
$myDiag->Popup(-popover => 'cursor');
repositionWindow($myDiag);
$myDiag->waitWindow;
$icon->delete if $icon;
return $rc;
}
##############################################################
# myReplaceDialog - get two strings from the user
##############################################################
sub myReplaceDialog {
my $title = shift;
my $text = shift;
my $varARef = shift;
my $varBRef = shift;
my $rc = 'Cancel';
# open window
my $win = $top->Toplevel();
#$win->grab();
$win->title($title);
$win->iconimage($mapiviicon) if $mapiviicon;
$win->Label(-text => $text, -bg => $conf{color_bg}{value}
)->pack(-anchor=>'w', -padx => 3, -pady => 3);
my $midF = $win->Frame()->pack(-expand => 1, -fill => 'both', -padx => 0, -pady => 0);
$midF->Label(-text => "Replace this:", -bg => $conf{color_bg}{value}
)->pack(-anchor=>'w', -padx => 3, -pady => 3);
my $entryA = $midF->Scrolled("Text",
-scrollbars => 'osoe',
-wrap => 'none',
-height => 4,
-width => 80,
)->pack(-side => 'top', -expand => 1, -fill => 'both', -padx => 3, -pady => 3);
$midF->Label(-text => "with that:", -bg => $conf{color_bg}{value}
)->pack(-anchor=>'w', -padx => 3, -pady => 3);
my $entryB = $midF->Scrolled("Text",
-scrollbars => 'osoe',
-wrap => 'none',
-height => 4,
-width => 80,
)->pack(-side => 'top', -expand => 1, -fill => 'both', -padx => 3, -pady => 3);
$entryA->insert('end', $$varARef);
$entryA->see('end');
$entryA->markSet("insert",'end');
$entryB->insert('end', $$varBRef);
$entryB->see('end');
$entryB->markSet("insert",'end');
my $umlautB = $win->Checkbutton(-variable => \$config{ConvertUmlaut}, -text => "convert german umlaute")->pack(-anchor => 'w', -padx => 3, -pady => 3);
$balloon->attach($umlautB, -msg => "Convert german umlaute (e.g. ä -> ae)\nUmlaute often cause problems in other tools,\nso it's saver to convert them to plain ASCII.");
my $ButF = $win->Frame()->pack(-fill =>'x', -padx => 0, -pady => 0);
my $OKB =
$ButF->Button(-text => lang('OK'),
-command => sub {
$$varARef = $entryA->get(0.1, 'end');
trimComment($varARef);
my $len = length($$varARef);
if ($len >= $maxCommentLength) {
$top->messageBox(-icon => 'warning', -message => "Sorry your comment is too long ($len characters).\nJPEG-Comments may only be up to 64K.\nPlease shorten your comment.",
-title => "Comment to long", -type => 'OK');
return;
}
$$varBRef = $entryB->get(0.1, 'end');
trimComment($varBRef);
$len = length($$varBRef);
if ($len >= $maxCommentLength) {
$top->messageBox(-icon => 'warning', -message => "Sorry your comment is too long ($len characters).\nJPEG-Comments may only be up to 64K.\nPlease shorten your comment.",
-title => "Comment to long", -type => 'OK');
return;
}
$rc = 'OK';
$win->withdraw();
$win->destroy();
})->pack(-side => 'left', -expand => 1, -fill => 'x', -padx => 3, -pady => 3);
$balloon->attach($OKB, -msg => "You can press Control-x to close the dialog (OK button)");
$ButF->Button(-text => lang("Test"),
-command => sub {
$$varARef = $entryA->get(0.1, 'end');
trimComment($varARef);
my $len = length($$varARef);
if ($len >= $maxCommentLength) {
$top->messageBox(-icon => 'warning', -message => "Sorry your comment is too long ($len characters).\nJPEG-Comments may only be up to 64K.\nPlease shorten your comment.",
-title => "Comment to long", -type => 'OK');
return;
}
$$varBRef = $entryB->get(0.1, 'end');
trimComment($varBRef);
$len = length($$varBRef);
if ($len >= $maxCommentLength) {
$top->messageBox(-icon => 'warning', -message => "Sorry your comment is too long ($len characters).\nJPEG-Comments may only be up to 64K.\nPlease shorten your comment.",
-title => "Comment to long", -type => 'OK');
return;
}
$rc = "Test";
$win->withdraw();
$win->destroy();
})->pack(-side => 'left', -expand => 1, -fill => 'x', -padx => 3, -pady => 3);
$win->bind('', sub { $OKB->Invoke; });
$ButF->Button(-text => lang('Cancel'),
-command => sub {
$rc = 'Cancel';
$win->withdraw();
$win->destroy();
})->pack(-side => 'left', -expand => 1, -fill => 'x', -padx => 3, -pady => 3);
$entryA->focus;
$win->Popup(-popover => 'cursor');
repositionWindow($win);
$win->waitWindow;
return $rc;
}
##############################################################
# trimComment
##############################################################
sub trimComment {
my $comRef = shift;
$$comRef =~ s/\n*$//; # remove trailing newlines
$$comRef =~ s/\r*//g; # remove \r (carriage return)
#$$comRef =~ s/"/\\"/g; # replace " with \"
$$comRef =~ s/\"/\'/g; # replace " with '
return;
}
##############################################################
# mySelListBoxDialog - let the user select some items of the
# given list
##############################################################
sub mySelListBoxDialog {
my $title = shift;
my $text = shift;
my $mode = shift; #SINGLE (one selection) or MULTIPLE (several selections)
my $OKBut = shift;
my $sellist = shift; # output list (list reference) - the list with the selected items
my @list = @_; # input list - the list to choose from
my $rc = 0;
# open window
my $myDiag = $top->Toplevel();
$myDiag->title($title);
$myDiag->iconimage($mapiviicon) if $mapiviicon;
$myDiag->Label(-anchor => 'w', -justify => 'left', -text => $text, -bg => $conf{color_bg}{value})->pack(-fill => 'x', -padx => 3, -pady => 3);
my $listBoxY = @list;
$listBoxY = 30 if ($listBoxY > 30); # maximum 30 entries
my $listBox =
$myDiag->Scrolled('Listbox',
-scrollbars => 'osoe',
-selectmode => 'extended',
-exportselection => 0,
-width => 80,
-height => $listBoxY,
)->pack(-expand => 1, -fill =>'both', -padx => 3, -pady => 3);
$listBox->configure(-selectmode => 'single') if ($mode == SINGLE);
$listBox->insert('end', @list);
$listBox->bind('', sub {
@$sellist = $listBox->curselection();
$rc = 1;
} );
# select all|none make only sense if multiple selection is possible
if ($mode == MULTIPLE) {
my $ubutF = $myDiag->Frame()->pack(-fill =>'x', -padx => 3, -pady => 3);
$ubutF->Button(-text => lang('Select all'),
-command => sub {
$listBox->selectionSet(0, 'end');
})->pack(-side => 'left', -padx => 3, -pady => 3);
$ubutF->Button(-text => lang('Select none'),
-command => sub {
$listBox->selectionClear(0, 'end');
})->pack(-side => 'left', -padx => 3, -pady => 3);
}
my $ButF = $myDiag->Frame()->pack(-fill =>'x', -padx => 3, -pady => 3);
my $OKB =
$ButF->Button(-text => $OKBut,
-command => sub {
@$sellist = $listBox->curselection();
$rc = 1;
})->pack(-side => 'left', -expand => 1, -fill => 'x', -padx => 3, -pady => 3);
$OKB->bind('', sub { $OKB->Invoke; } );
my $xBut = $ButF->Button(-text => lang('Cancel'),
-command => sub { $rc = 0; }
)->pack(-side => 'left', -expand => 1, -fill => 'x', -padx => 3, -pady => 3);
bind_exit_keys_to_button($myDiag, $xBut);
$myDiag->Popup;
if ($EvilOS) { # sometimes to dialog disappears when clicked on, so we need a short grab
$myDiag->grab;
$myDiag->after(50, sub{$myDiag->grabRelease});
}
$OKB->focus;
$myDiag->waitVariable(\$rc);
$myDiag->destroy() if Tk::Exists($myDiag);
return $rc;
}
##############################################################
# createDirMenu
##############################################################
sub createDirMenu {
$dirMenu =
$top->Menu(-title => lang("Folder Menu"));
return;
}
##############################################################
# updateDirMenu
##############################################################
sub updateDirMenu {
return if (!defined($dirMenu));
# get number of items
my $end = $dirMenu->index('end');
# first call to function - build up menu fixed part
# less than 12 menu items (separators count too!)
if ($end < 12) {
$dirMenu->command(-image => compound_menu($top, lang('Open folder ...'), 'folder.png'),
-command => sub {
my $dir = getRightDir();
openDirPost($dir);}, -accelerator => "double click");
$dirMenu->command(-image => compound_menu($top, lang('Preview folder'), ''),
-command => sub {
my $dir = getRightDir();
my @list = getPics($dir, WITH_PATH, NO_CHECK_JPEG);
sortPics($config{SortBy}, $config{SortReverse}, \@list);
showThumbList(\@list, $dir); }, -accelerator => "middle click");
$dirMenu->command(-image => compound_menu($top, lang('Copy pictures to folder'), ''),
-command => sub { copy_or_move_pics_to_folder(COPY); });
$dirMenu->command(-image => compound_menu($top, lang('Move pictures to folder'), ''),
-command => sub { copy_or_move_pics_to_folder(MOVE); });
$dirMenu->command(-image => compound_menu($top, lang('Search in folder ...'), 'system-search.png'),
-command => sub {
my $tmp = $config{SearchOnlyInDir}; # save search mode
$config{SearchOnlyInDir} = 1; # set to local search
searchMetaInfo();
$config{SearchOnlyInDir} = $tmp; # restore search mode
});
my $dir_size = $dirMenu->cascade(-image => compound_menu($top, lang('Folder size'), ''));
$dir_size->cget(-menu)->configure(-title => lang('Folder size'));
$dir_size->command(-label => lang("Calculate folder size"), -command => sub { calcDirSize(); } );
$dir_size->command(-label => lang("Display folder sizes (graphic)"),
-command => sub { showDirSizes(getRightDir()); } );
$dirMenu->separator;
$dirMenu->command(-image => compound_menu($top, lang('Rename folder ...'), ''),
-command => sub { renameDir(); });
$dirMenu->command(-image => compound_menu($top, lang('New folder ...'), 'folder-new.png'),
-command => sub {
my $dir = getRightDir();
if (!-d $dir) { warn "dir $dir is no dir"; return; }
makeNewDir($dir, $dirtree); });
$dirMenu->command(-image => compound_menu($top, lang('Delete folder ...'), ''),
-command => sub { deleteDir(); });
$dirMenu->separator;
my $dir_hot = $dirMenu->cascade(-image => compound_menu($top, lang('Folder list'), 'emblem-favorite.png'));
$dir_hot->cget(-menu)->configure(-title => lang('Folder list'));
$dir_hot->command(-label => lang("Add actual folder"),
-command => sub {
my $dir = getRightDir();
my $max = 0;
foreach (sort {$dirHotlist{$b} <=> $dirHotlist{$a}} keys %dirHotlist) {
$max = $dirHotlist{$_};
last;
}
$dirHotlist{$dir} = $max;
log_it("added $dir to list!");
updateDirMenu();
});
$dir_hot->command(-label => lang("Remove actual folder"), -command => sub {
my $dir = getRightDir();
delete $dirHotlist{$dir} if (defined($dirHotlist{$dir}));
log_it("removed $dir from list!");
updateDirMenu();
});
}
else {
# clear dir menu index 13 to end (dynamic part)
$dirMenu->delete(13, 'end');
}
# add the dynamic part
# add the 12 most wanted hotlist folders :)
my @dirlist;
foreach (sort {$dirHotlist{$b} <=> $dirHotlist{$a}} keys %dirHotlist) {
# remove deleted dirs
if (!-d $_) {
delete $dirHotlist{$_};
next; # skip
}
next if ($_ eq $trashdir);
push @dirlist, $_;
last if (@dirlist > 11);
}
foreach (sort @dirlist) {
my $dir = $_; # we need a local copy
# this will add the number of accesses of the folder
#$dirMenu->command(-label => "$_", -command => sub { openDirPost($dir); }, -accelerator => "($dirHotlist{$_})");
$dirMenu->command(-label => "$_", -command => sub { openDirPost($dir); });
}
$dirMenu->separator;
# add the last used folders
foreach (reverse @dirHist) {
next if (!-d $_);
my $dir = $_; # we need a local copy
$dirMenu->command(-label => "$dir", -command => sub { openDirPost($dir); });
}
}
##############################################################
# createThumbMenu
##############################################################
sub createThumbMenu {
$thumbMenu =
$top->Menu(-title => lang("Thumbnail Menu"));
addSelectMenu($thumbMenu);
$thumbMenu->separator;
addFileActionsMenu($thumbMenu, $picLB);
$thumbMenu->separator;
addPicProcessing($thumbMenu, $picLB);
$thumbMenu->separator;
addMetaInfoMenu($thumbMenu);
$thumbMenu->separator;
$thumbMenu->command(-image => compound_menu($top, lang('Open this folder'), 'folder.png'), -command => sub { open_pic_folder($picLB); }, -accelerator => '' );
$thumbMenu->command(-image => compound_menu($top, lang('Reload pictures'), 'view-refresh.png'), -command => \&updateThumbsPlus, -accelerator => '');
$thumbMenu->command(-image => compound_menu($top, lang('Reload picture meta information'), 'view-refresh.png'), -command => sub { reread_pics($picLB); });
$thumbMenu->command(-label => lang("Rebuild thumbnails ..."), -command => \&rebuildThumbs); #, -accelerator => "");
$thumbMenu->command(-label => lang("Add to collection"), -command => sub {light_table_add_from_lb($picLB);}, -accelerator => "");
$thumbMenu->command(-image => compound_menu($top, lang('Show GPS position in map'), 'internet-web-browser.png'), -command => sub { gps_map_open($picLB); } );
}
##############################################################
# createPicMenu
##############################################################
sub createPicMenu {
$picMenu = $top->Menu(-title => lang('Picture Menu'));
$picMenu->command(-label => lang('Reload picture'), -command => \&reloadPic, -accelerator => '' );
$picMenu->command(-label => lang('Show thumbnails in picture frame'), -command => sub { my @pics = $picLB->info('children'); show_canvas_thumbs($c, \@pics);}, -accelerator => '' );
$picMenu->command(-image => compound_menu($top, lang('Open pictures in new window'), 'image-x-generic.png'), -command => sub {showPicInOwnWin($actpic);}, -accelerator => '' );
$picMenu->separator;
addPicProcessing($picMenu, $picLB);
$picMenu->separator;
addZoomMenu($picMenu);
$picMenu->separator;
add_window_layout_menu($picMenu);
$picMenu->separator;
$picMenu->command(-image => compound_menu($top, lang('Options ...'), 'preferences-system.png'), -command => \&options_edit, -accelerator => "");
$picMenu->command(-image => compound_menu($top, lang('Other options ...'), 'preferences-system.png'), -command => \&options);
$picMenu->command(-image => compound_menu($top, lang('Fullscreen'), 'view-fullscreen.png'), -command => sub { fullscreen($top); } );
}
##############################################################
# compoud_menu
##############################################################
sub compound_menu {
my $w = shift;
my $text = shift;
my $icon_name = shift;
my $space = shift; # optional
$space = 19 unless defined $space;
my $compound_image = $w->Compound();
if (-f "$icon_path/$icon_name") {
$compound_image->Image(-image => $top->Photo(-file => "$icon_path/$icon_name", -gamma => $config{Gamma}));
$compound_image->Space(-width => 3);
}
else {
$compound_image->Space(-width => $space);
print "Mapivi info: icon $icon_path/$icon_name not found.\n" if ($icon_name ne '');
}
$compound_image->Text(-text => $text, -foreground => $conf{color_menu_fg}{value} );
return $compound_image;
}
##############################################################
# createMenubar
##############################################################
sub createMenubar {
$menubar = $top->Menu;
my $file_menu = $menubar->cascade(-label => lang("File")); # use "~File" for key shortcut
$file_menu->cget(-menu)->configure(-title => "File menu");
my $edit_menu = $menubar->cascade(-label => lang("Edit"));
$edit_menu->cget(-menu)->configure(-title => "Edit menu");
my $view_menu = $menubar->cascade(-label => lang("View"));
$view_menu->cget(-menu)->configure(-title => "View menu");
my $sort_menu = $menubar->cascade(-label => lang('Sort'));
$sort_menu->cget(-menu)->configure(-title => "Sort menu");
my $find_menu = $menubar->cascade(-label => lang("Search"));
$find_menu->cget(-menu)->configure(-title => "Search menu");
my $opti_menu = $menubar->cascade(-label => lang("Options"));
$opti_menu->cget(-menu)->configure(-title => "Options menu");
my $extr_menu = $menubar->cascade(-label => "Extra");
$extr_menu->cget(-menu)->configure(-title => "Extra menu");
my $plug_menu = $menubar->cascade(-label => "PlugIns");
$plug_menu->cget(-menu)->configure(-title => "PlugIn menu");
my $help_menu = $menubar->cascade(-label => lang("Help"));
$help_menu->cget(-menu)->configure(-title => "Help menu");
#my $icon = ;
$file_menu->command(-image => compound_menu($top, lang('Open folder ...'), 'folder.png'), -command => \&openDir, -accelerator => "");
#$file_menu->command(-image => compound_menu($top, 'open umlaut folder ...', ''), -command => sub { openDirPost("/home/herrmann/tmp/dirb/subdirä"); } );
$file_menu->command(-image => compound_menu($top, lang('Preview folder'), ''), -command => sub {
my $dir = getRightDir();
my @list = getPics($dir, WITH_PATH, NO_CHECK_JPEG);
sortPics($config{SortBy}, $config{SortReverse}, \@list);
showThumbList(\@list, $dir); }, -accelerator => "middle click");
$file_menu->command(-image => compound_menu($top, lang('Search in folder ...'), ''), -command => sub {
my $tmp = $config{SearchOnlyInDir}; # save search mode
$config{SearchOnlyInDir} = 1; # set to local search
searchMetaInfo();
$config{SearchOnlyInDir} = $tmp; # restore search mode
});
my $dir_size = $file_menu->cascade(-image => compound_menu($top, lang('Folder size'), ''));
$dir_size->command(-label => lang("Calculate folder size"), -command => sub { calcDirSize(); } );
$dir_size->command(-label => lang("Display folder sizes (graphic)"), -command => sub { showDirSizes(getRightDir()); } );
$file_menu->separator;
$file_menu->command(-image => compound_menu($top, lang('Rename folder ...'), ''), -command => \&renameDir);
$file_menu->command(-image => compound_menu($top, lang('New folder ...'), 'folder-new.png'), -command => sub {
my $dir = getRightDir();
if (!-d $dir) { warn "dir $dir is no dir"; return; }
makeNewDir($dir, $dirtree); } );
$file_menu->command(-image => compound_menu($top, lang('Delete folder ...'), ''), -command => \&deleteDir);
$file_menu->command(-image => compound_menu($top, lang('Hot folders ...'), ''), -command => sub {
$dirMenu->Popup(-popover => "cursor", -popanchor => "nw");
}, , -accelerator => "");
$file_menu->separator;
addFileActionsMenu($file_menu, $picLB);
$file_menu->separator;
#my $trash_menu = $file_menu->cascade(-image => compound_menu($top, lang('Trash'), 'user-trash.png'));
$file_menu->command(-image => compound_menu($top, lang('Empty trash ...'), 'user-trash.png'), -command => \&emptyTrash);
#$trash_menu->command(-label => lang("Open trash in main window"), -command => [\&openDirPost, $trashdir]);
$file_menu->command(-image => compound_menu($top, lang('Folder checklist ...'), ''), -command => sub { showDirProperties(); } );
$file_menu->command(-image => compound_menu($top, lang('Import wizard ...'), 'camera-photo.png'), -command => \&importWizard);
$file_menu->separator;
$file_menu->command(-image => compound_menu($top, lang('Picture collection').' ...', ''), -command => \&light_table_open_window);
$file_menu->command(-image => compound_menu($top, lang('Convert non-JPEG pictures ...'), ''), -command => \&convertNonJPEGS);
$file_menu->command(-image => compound_menu($top, lang('Reload pictures'), 'view-refresh.png'), -accelerator => "",
-command => \&updateThumbsPlus);
$file_menu->command(-image => compound_menu($top, lang('Smart update'), 'view-refresh.png'), -command => sub { smart_update(); }, -accelerator => "");
$file_menu->command(-image => compound_menu($top, lang("Rebuild thumbnails ..."), ''), -command => \&rebuildThumbs); #, -accelerator => "");
$file_menu->command(-image => compound_menu($top, lang('Build thumbnails ...'), ''), -command => \&buildThumbsRecursive);
$file_menu->separator;
$file_menu->command(-image => compound_menu($top, lang('Iconify'), 'user-desktop.png'), -accelerator => "", -command => sub { $top->iconify; });
$file_menu->command(-image => compound_menu($top, lang('Quit'), 'system-log-out.png'), -accelerator => "", -command => \&quitMain);
addSelectMenu($edit_menu);
$edit_menu->separator;
addPicProcessing($edit_menu, $picLB);
$edit_menu->separator;
# add the comments, EXIF and IPTC menu
addMetaInfoMenu($edit_menu);
$view_menu->command(-image => compound_menu($top, lang('Next'), 'go-next.png'), -command => sub {
return if (stillBusy()); # block, until last picture is loaded
if ($slideshow == 1) {
$slideshow = 0; slideshow();
} # switch slideshow off
showPic(nextPic($actpic));
}, -accelerator => "");
$view_menu->command(-image => compound_menu($top, lang('Previous'), 'go-previous.png'), -command => sub {
return if (stillBusy()); # block, until last picture is loaded
if ($slideshow == 1) {
$slideshow = 0; slideshow();
} # switch slideshow off
showPic(prevPic($actpic));},
-accelerator => "");
$view_menu->separator;
$view_menu->command(-image => compound_menu($top, lang('First'), 'go-first.png'), -command => sub {
return if (stillBusy()); # block, until last picture is loaded
if ($slideshow == 1) { $slideshow = 0; slideshow(); } # switch slideshow off
my @childs = $picLB->info('children');
return unless (@childs);
showPic($childs[0]); },
-accelerator => "");
$view_menu->command(-image => compound_menu($top, lang('Last'), 'go-last.png'), -command => sub {
return if (stillBusy()); # block, until last picture is loaded
if ($slideshow == 1) {
$slideshow = 0; slideshow();
} # switch slideshow off
my @childs = $picLB->info('children');
return unless (@childs);
showPic($childs[-1]);
},
-accelerator => "");
$view_menu->separator;
$view_menu->command(-image => compound_menu($top, lang('go to/select ...'), ''), -command => sub { gotoPic($picLB); });
$view_menu->separator;
addZoomMenu($view_menu);
$view_menu->separator;
$view_menu->command(-image => compound_menu($top, lang('Open pictures in new window'), 'image-x-generic.png'), -command => sub { my @sellist = getSelection($picLB);
return unless checkSelection($top, 1, 0, \@sellist, lang("picture(s)"));
show_multiple_pics(\@sellist, 0);
}, -accelerator => "");
$view_menu->command(-image => compound_menu($top, lang('Open pictures in external viewer'), 'image-x-generic.png'), -command => sub{openPicInViewer($picLB);}, -accelerator => "");
$view_menu->command(-label => lang("Picture information"), -command => \&identifyPic);
$view_menu->command(-label => lang("Histogram (ImageMagick)"), -command => sub { showHistogram($picLB); } );
$view_menu->command(-label => lang("Histogram (Mapivi)"), -command => sub { showHistogram2($picLB); } );
$view_menu->command(-label => lang("Show JPEG segments"), -command => \&showSegments);
$view_menu->command(-image => compound_menu($top, lang('Start/stop slideshow'), 'media-playback-start.png'), -command => sub {
if ($slideshow == 0) {
$slideshow = 1;
} else {
$slideshow = 0;
}
slideshow();
}, -accelerator => "");
$view_menu->command(-label => lang("Picture as desktop background"),
-command => \&setBackground);
$view_menu->separator;
add_window_layout_menu($view_menu);
$view_menu->command(-label => lang("Fullscreen"), -command => sub { fullscreen($top); }, -accelerator => "");
$view_menu->separator;
my $thumb_menu = $view_menu->cascade(-label => lang("Thumbnail table"));
$thumb_menu->cget(-menu)->configure(-title => lang("Thumbnail table"));
my $caption_menu = $thumb_menu->cascade(-label => lang("Thumbnail caption"));
$caption_menu->cget(-menu)->configure(-title => "Thumbnail caption ...");
$caption_menu->radiobutton(-label => lang("None"), -variable => \$config{ThumbCapt}, -value => "none", -command => sub { updateThumbsPlus(); });
$caption_menu->radiobutton(-label => lang("File name without suffix"), -variable => \$config{ThumbCapt}, -value => "filename", -command => sub { updateThumbsPlus(); });
$caption_menu->radiobutton(-label => lang("File name with suffix"), -variable => \$config{ThumbCapt}, -value => "filenameSuffix", -command => sub { updateThumbsPlus(); });
$caption_menu->radiobutton(-label => lang("IPTC object name"), -variable => \$config{ThumbCapt}, -value => "objectname", -command => sub { updateThumbsPlus(); });
$thumb_menu->separator;
$thumb_menu->checkbutton(-label => lang("Show file info"), -variable => \$config{ShowFile}, -command => \&toggleHeaders);
$thumb_menu->checkbutton(-label => lang("Show IPTC"), -variable => \$config{ShowIPTC}, -command => \&toggleHeaders);
$thumb_menu->checkbutton(-label => lang("Show comments"), -variable => \$config{ShowComment}, -command => \&toggleHeaders);
$thumb_menu->checkbutton(-label => lang("Show EXIF"), -variable => \$config{ShowEXIF}, -command => \&toggleHeaders);
$thumb_menu->checkbutton(-label => lang("Show folder"), -variable => \$config{ShowDirectory}, -command => \&toggleHeaders);
$sort_menu->radiobutton(-label => lang("File name"), -variable => \$config{SortBy}, -value => "name", -command => sub { updateThumbsPlus(); });
$sort_menu->radiobutton(-label => lang("File date"), -variable => \$config{SortBy}, -value => "date", -command => \&updateThumbsPlus);
$sort_menu->radiobutton(-label => lang("File size"), -variable => \$config{SortBy}, -value => "size", -command => \&updateThumbsPlus);
$sort_menu->separator;
$sort_menu->radiobutton(-label => lang("IPTC urgency/rating"), -variable => \$config{SortBy}, -value => "urgency", -command => \&updateThumbsPlus);
$sort_menu->radiobutton(-label => lang("IPTC by-line"), -variable => \$config{SortBy}, -value => "byline", -command => \&updateThumbsPlus);
$sort_menu->separator;
$sort_menu->radiobutton(-label => lang("Flags"), -variable => \$config{SortBy}, -value => "flag", -command => \&updateThumbsPlus);
$sort_menu->radiobutton(-label => lang("Number of views"), -variable => \$config{SortBy}, -value => "popularity", -command => \&updateThumbsPlus);
$sort_menu->radiobutton(-label => lang("Number of pixels"), -variable => \$config{SortBy}, -value => "pixel", -command => \&updateThumbsPlus);
$sort_menu->radiobutton(-label => lang("Number of bits per pixels (b/p)"), -variable => \$config{SortBy}, -value => "bitpix", -command => \&updateThumbsPlus) if ($config{BitsPixel});
$sort_menu->separator;
$sort_menu->radiobutton(-label => lang("EXIF date"), -variable => \$config{SortBy}, -value => "exifdate", -command => \&updateThumbsPlus);
$sort_menu->radiobutton(-label => lang("EXIF aperture"), -variable => \$config{SortBy}, -value => "aperture", -command => \&updateThumbsPlus);
$sort_menu->radiobutton(-label => lang("EXIF exposure time"), -variable => \$config{SortBy}, -value => "exposuretime", -command => \&updateThumbsPlus);
$sort_menu->radiobutton(-label => lang("EXIF camera maker/model"), -variable => \$config{SortBy}, -value => "model", -command => \&updateThumbsPlus);
$sort_menu->radiobutton(-label => lang("EXIF artist"), -variable => \$config{SortBy}, -value => "artist", -command => \&updateThumbsPlus);
$sort_menu->separator;
$sort_menu->radiobutton(-label => lang("Sort randomly"), -variable => \$config{SortBy}, -value => "random", -command => \&updateThumbsPlus);
$sort_menu->separator;
$sort_menu->checkbutton(-label => lang("Sort reverse"), -variable => \$config{SortReverse}, -command => \&updateThumbsPlus);
$find_menu->command(-image => compound_menu($top, lang('Search ...'), 'system-search.png'), -command => sub { $config{Layout} = 1 ; layout(1); $act_modus = SEARCH; $nav_F->{nav_tab}->raise('search');});
$find_menu->command(-image => compound_menu($top, lang('Advanced search ...'), 'system-search.png'), -command => \&searchMetaInfo, -accelerator => '');
$find_menu->command(-image => compound_menu($top, lang('Search by keywords (tag cloud) ...'), 'weather-overcast.png'), -command => \&keyword_browse, -accelerator => '');
$find_menu->command(-image => compound_menu($top, lang('Search by timeline ...'), 'x-office-calendar.png'), -command => \&database_info);
$find_menu->command(-image => compound_menu($top, lang('Search by location ...'), 'applications-internet.png'), -command => sub { search_by_location($picLB); } );
$find_menu->command(-image => compound_menu($top, lang('Search duplicates ...'), ''), -command => \&findDups);
#$find_menu->command(-label => "check for new keywords ...", -command => \&check_new_keywords);
$find_menu->separator;
my $find_special_menu = $find_menu->cascade(-image => compound_menu($top, lang('Special searches'), ''));
$find_menu->command(-image => compound_menu($top, lang('Slideshow all pictures with filter').' '.lang("Settings"), ''), -command => sub {slideshow_all_pics(SETTINGS);});
$find_menu->command(-image => compound_menu($top, lang('Slideshow all pictures with filter').' '.lang("Start"), ''), -command => sub {slideshow_all_pics(START);});
$find_special_menu->command(-label => lang("TOP 100 (best rated)"), -command => \&showMostPopularPics);
$find_special_menu->command(-label => lang("EXIF histogram"), -command => \&exif_histogram);
$find_special_menu->command(-image => compound_menu($top, lang('Search for file name ...'), 'edit-find.png'), -command => sub { searchFileName($picLB);});
$find_special_menu->command(-image => compound_menu($top, lang('Search for date/time'), 'edit-find.png'), -command => sub { search_by_date_time($picLB);});
$find_menu->separator;
$find_menu->command(-image => compound_menu($top, lang('Add to database ...'), 'list-add.png'), -command => \&buildDatabase);
$find_menu->command(-image => compound_menu($top, lang('Clean database ...'), 'edit-clear.png'), -command => \&cleanDatabase);
$find_menu->command(-image => compound_menu($top, lang('Check database ...'), ''), -command => \&checkDatabase);
$find_menu->command(-image => compound_menu($top, lang('Edit database ...'), 'accessories-text-editor.png'), -command => \&editDatabase);
$find_menu->command(-image => compound_menu($top, lang('Database information ...'), 'dialog-information.png'), -command => \&diff_database_statistic);
$opti_menu->command(-image => compound_menu($top, lang('Options ...'), 'preferences-system.png'), -command => \&options_edit, -accelerator => "");
$opti_menu->command(-image => compound_menu($top, lang('Other options ...'), 'preferences-system.png'), -command => \&options);
$opti_menu->command(-image => compound_menu($top, lang("Save options"), 'media-floppy.png'), -command => \&saveAllConfig);
$extr_menu->command(-label => lang("Export filelist ..."), -command => \&exportFilelist);
$extr_menu->command(-label => lang("Compare folders")." ...", -command => sub { dirDiffWindow(); } );
$extr_menu->command(-label => lang("Compare pictures"), -command => \&diffPics);
$extr_menu->separator;
$extr_menu->command(-label => lang("HDR ..."), -command => \&hdr_pic);
#$extr_menu->command(-label => lang("Fuzzy border ..."), -command => \&fuzzyBorder);
$extr_menu->command(-label => lang("Drop picture (lossless) ..."), -command => \&losslessWatermark);
$extr_menu->command(-label => lang("Generate logo ..."), -command => \&logo_generate_win);
$extr_menu->command(-label => lang("Make screenshot ..."), -command => \&screenshot);
$extr_menu->separator;
$extr_menu->command(-label => lang("Build thumbnails ..."), -command => \&buildThumbsRecursive);
$extr_menu->command(-label => lang("Clean thumbnails ..."), -command => sub { cleanThumbDB(); } );
$extr_menu->command(-label => lang("Clean folder ..."), -command => sub { cleanDir($actdir); } );
$extr_menu->command(-label => lang("Edit entry history ..."), -command => sub { editEntryHistory(); } );
$extr_menu->command(-label => lang("Session info"), -command => sub { session_info(); } );
$extr_menu->separator;
$extr_menu->command(-label => lang("Mapivi test suite"), -command => \&testSuite);
$extr_menu->command(-label => lang("Translation scan"), -command => \&language_scan);
# mh 2011-04-29 this takes too long (some minutes for 12 drive letters)
#if (Win32DriveInfoAvail) {
# $extr_menu->command(-label => "dirtree drive letter test", -command => sub{$dirtree->configure(-directory => "$_:") foreach (Win32::DriveInfo::DrivesInUse());});
#}
#$extr_menu->command(-label => "test menu", -command => sub {my @list; push @list, "Hund/Katze/Maus"; add_new_keywords(\@list); });
my $xmp_menu = $extr_menu->cascade(-label => "XMP ...");
$xmp_menu->command(-label => lang("Copy IPTC urgency to XMP rating"), -command => sub { rating_iptc_to_xmp(); } );
$xmp_menu->command(-label => lang("Copy XMP rating to IPTC urgency"), -command => sub { rating_xmp_to_iptc(); } );
$xmp_menu->command(-label => lang("Copy XMP keywords to IPTC"), -command => sub { keywords_xmp_to_iptc_folder(); } );
makePlugInsMenu($plug_menu, $plugin_sys_path); # add system wide plugins to the menu
$plug_menu->separator;
makePlugInsMenu($plug_menu, $plugin_user_path); # add user specific plugins to the menu
$help_menu->command(-image => compound_menu($top, lang('About'), 'dialog-information.png'), -command => \&about);
$help_menu->command(-image => compound_menu($top, lang('Keys'), 'input-keyboard.png'), -command => \&showkeys);
$help_menu->command(-image => compound_menu($top, lang('System information'), 'utilities-system-monitor.png'), -command => \&systemInfo);
foreach my $file (qw(License Changes Tips FAQ)) {
$help_menu->command(-image => compound_menu($top, $file, 'help-browser.png'), -command => [\&showFile, "$program_data_path/docs/${file}.txt"]) if (-f "$program_data_path/docs/${file}.txt");
}
$help_menu->command(-image => compound_menu($top, lang('Mapivi Home'), 'dialog-information.png'), -command => sub {web_browser_open($mapiviURL);} );
$top->configure(-menu => $menubar) if $config{ShowMenu};
}
##############################################################
##############################################################
sub add_window_layout_menu {
my $menu = shift;
my $layout_menu = $menu->cascade(-label => lang("Window layout"));
$layout_menu->cget(-menu)->configure(-title => lang("Window layout"));
$layout_menu->command(-label => lang('Toggle layout'), -command => sub { $config{Layout}++; layout(1); }, -accelerator => '');
$layout_menu->separator;
$layout_menu->command(-image => compound_menu($top, lang("3 columns: Navigation Thumbnails Picture"), 'layout-ntp.png'), -command => sub { $config{Layout} = 0 ; layout(1); }, -accelerator => "");
$layout_menu->command(-image => compound_menu($top, lang("2 columns: Navigation Thumbnails"), 'layout-nt.png'), -command => sub { $config{Layout} = 1 ; layout(1); }, -accelerator => "");
$layout_menu->command(-image => compound_menu($top, lang("1 column: Thumbnails"), 'layout-t.png'), -command => sub { $config{Layout} = 2 ; layout(1); }, -accelerator => "");
$layout_menu->command(-image => compound_menu($top, lang("2 columns: Thumbnails Picture"), 'layout-tp.png'), -command => sub { $config{Layout} = 3 ; layout(1); }, -accelerator => "");
$layout_menu->command(-image => compound_menu($top, lang("1 column: Picture"), 'layout-p.png'), -command => sub { $config{Layout} = 4 ; layout(1); }, -accelerator => "");
$layout_menu->command(-image => compound_menu($top, lang("2 columns: Navigation Picture"), 'layout-tp.png'), -command => sub { $config{Layout} = 5 ; layout(1); });
$layout_menu->separator;
$layout_menu->checkbutton(-label => lang("Menu bar"), -variable => \$config{ShowMenu}, -command => sub { showHideFrames(); }, -accelerator => "");
$layout_menu->checkbutton(-label => lang("Status bar"), -variable => \$config{ShowInfoFrame}, -command => sub { showHideFrames(); }, -accelerator => "");
$layout_menu->checkbutton(-label => lang("Picture metadata overlay"), -variable => \$config{ShowInfoInCanvas}, -command => sub { showImageInfoCanvas($actpic); }, -accelerator => "");
$layout_menu->checkbutton(-label => lang("IPTC box"), -variable => \$config{ShowIPTCFrame}, -command => sub { showHideFrames(); }, -accelerator => "");
$layout_menu->checkbutton(-label => lang("Comment box"), -variable => \$config{ShowCommentField}, -command => sub { showHideFrames(); });
$layout_menu->checkbutton(-label => lang("Display coordinates"), -variable => \$conf{show_coordinates}{value});
}
##############################################################
# addPicProcessing
##############################################################
sub addPicProcessing {
my $menu = shift;
my $widget = shift; # listbox or canvas
my $rot_menu = $menu->cascade(-image => compound_menu($top, lang('Rotate ...'), 'transform-rotate.png'));
$rot_menu->cget(-menu)->configure(-title => "rotation menu");
$rot_menu->command(-label => lang("Rotate 90 - right (lossless)"), -command => sub { rotate(90); }, -accelerator => "<9>");
$rot_menu->command(-label => lang("Rotate 180 (lossless)"), -command => sub { rotate(180); }, -accelerator => "<8>");
$rot_menu->command(-label => lang("Rotate 270 - left (lossless)"), -command => sub { rotate(270); }, -accelerator => "<7>");
$rot_menu->command(-label => lang("Flip horizontal (lossless)"), -command => sub { rotate("horizontal"); });
$rot_menu->command(-label => lang("Flip vertical (lossless)"), -command => sub { rotate("vertical"); });
$rot_menu->command(-label => lang("Auto rotate (lossless)"), -command => sub { rotate("auto"); }, -accelerator => "<0>");
$rot_menu->command(-label => lang("Clear rotate flag"), -command => sub { rotate("clear"); });
$rot_menu->command(-label => lang("Rotate ..."), -command => [\&rotateAny]);
$menu->command(-image => compound_menu($top, lang('Change size/quality ...'), 'transform-scale.png'), -command => \&changeSizeQuality, -accelerator => "" );
$menu->command(-image => compound_menu($top, lang('Crop (lossless) ...'), 'edit-cut.png'), -command => sub { crop($widget); }, -accelerator => "");
$menu->command(-image => compound_menu($top, lang('Image processing ...'), 'camera-photo.png'), -command => \&filterPic);
$menu->command(-image => compound_menu($top, lang('Image processing extern'), 'applications-graphics.png'), -command => sub { edit_pic($widget); }, -accelerator => "");
$menu->command(-image => compound_menu($top, lang('Collage/index print ...'), 'image-x-generic.png'), -command => sub { my @pics = getSelection($widget); indexPrint(\@pics); });
$menu->command(-image => compound_menu($top, lang('Passport print ...'), 'image-x-generic.png'), -command => sub { passport_print($widget); });
$menu->command(-image => compound_menu($top, lang("Convert to black and white"), 'image-x-generic-bw.png'), -command => sub { grayscalePic($widget); } );
$menu->command(-image => compound_menu($top, lang("Black and white preview"), 'image-x-generic-bw.png'),
-command => sub { my @list = getSelection($widget); return unless checkSelection($top, 1, 1, \@list, lang("picture(s)")); grayscale_preview($list[0]); });
my $border_menu = $menu->cascade(-image => compound_menu($top, lang('Add border ...'), 'image-x-generic.png'));
$border_menu->cget(-menu)->configure(-title => lang('Border menu'));
$border_menu->command(-image => compound_menu($top, lang('Add border (lossless) ...'), 'image-x-generic.png'), -command => sub { losslessBorder(PIXEL); }, -accelerator => "");
$border_menu->command(-image => compound_menu($top, lang('Add border aspect ratio (lossless) ...'), 'image-x-generic.png'), -command => sub { losslessBorder(ASPECT_RATIO); } );
$border_menu->command(-image => compound_menu($top, lang('Add relative border (lossless) ...'), 'image-x-generic.png'), -command => sub { losslessBorder(RELATIVE); } );
$border_menu->command(-image => compound_menu($top, lang('Add border or copyright (lossy) ...'), 'image-x-generic.png'), -command => \&addDecoration);
$border_menu->command(-image => compound_menu($top, lang("Fuzzy border (lossy) ..."), 'image-x-generic.png'), -command => \&fuzzyBorder);
$menu->command(-image => compound_menu($top, lang('Extract JPEG preview from raw'), 'image-x-generic.png'), -command => sub { extract_jpeg($widget); });
}
##############################################################
# addFileActionsMenu
##############################################################
sub addFileActionsMenu {
my $menu = shift;
my $lb = shift;
my $fop_menu = $menu->cascade(-image => compound_menu($top, lang('File operations ...'), ''));
$fop_menu->command(-image => compound_menu($top, lang('Copy to ...'), 'edit-copy.png'), -command => sub { copyPicsDialog(COPY, $lb); } );
$fop_menu->command(-image => compound_menu($top, langf("Copy to \"%s\" folder", $conf{origs_folder_name}{value}), ''), -command => sub { copy_move_to_origs($lb, COPY); });
$fop_menu->command(-image => compound_menu($top, lang('Copy to print ...'), 'printer.png'), -command => sub { copyToPrint($lb); }, -accelerator => "");
$fop_menu->command(-image => compound_menu($top, lang('Link to ...'), ''), -command => sub { linkPicsDialog($lb); }) if (!$EvilOS);
$fop_menu->command(-image => compound_menu($top, lang('Move to ...'), ''), -command => sub { movePicsDialog($lb); } );
$fop_menu->command(-image => compound_menu($top, langf("Move to \"%s\" folder", $conf{origs_folder_name}{value}), ''), -command => sub { copy_move_to_origs($lb, MOVE); }, -accelerator => "" );
$fop_menu->command(-image => compound_menu($top, lang('Rename ...'), ''), -command => sub { renamePic($lb); }, -accelerator => "");
$fop_menu->command(-image => compound_menu($top, lang('Smart rename ...'), ''), -command => sub { renameSmart($lb); }, -accelerator => "");
$fop_menu->separator;
$fop_menu->command(-image => compound_menu($top, lang('Email to ...'), 'mail-message-new.png'), -command => sub { sendTo($lb); } );
$fop_menu->command(-image => compound_menu($top, lang('Convert ...'), ''), -command => sub { convertPics($lb); } );
$fop_menu->command(-image => compound_menu($top, lang('Make backup'), ''), -command => sub { copyPicsDialog(BACKUP, $lb); } );
$fop_menu->command(-image => compound_menu($top, lang('Make HTML ...'), 'applications-internet.png'), -command => sub { makeHTML($lb); });
$fop_menu->separator;
$fop_menu->command(-image => compound_menu($top, lang('Delete to trash'), 'user-trash.png'), -accelerator => "",
-command => sub { deletePics($lb, TRASH); } );
$fop_menu->command(-image => compound_menu($top, lang('Delete ...'), ''), -accelerator => "", -command => sub { deletePics($lb, REMOVE); } );
}
##############################################################
# addSelectMenu
##############################################################
sub addSelectMenu {
my $menu = shift;
my $sel_menu = $menu->cascade(-image => compound_menu($top, lang('Select ...'), ''));
$sel_menu->command(-label => lang("Select all"), -accelerator => "", -command => sub {selectAll($picLB);} );
$sel_menu->command(-label => lang("Select all backups"), -command => \&selectBak );
$sel_menu->command(-label => lang("Invert selection"), -command => \&selectInv );
$sel_menu->command(-label => lang("Redo selection"), -command => sub { $picLB->selectionClear(); reselect($picLB, @savedselection2); } );
}
##############################################################
# addZoomMenu
##############################################################
sub addZoomMenu {
my $menu = shift;
$menu->checkbutton(-label => lang("Auto zoom (fit picture)"), -variable => \$config{AutoZoom});
my $zoom_menu = $menu->cascade(-label => lang("Zoom ..."));
$zoom_menu->cget(-menu)->configure(-title => lang("Zoom menu"));
$zoom_menu->command(-label => lang("fit"),
-command => sub { $conf{zoom_fit_fill}{value} = FIT; fitPicture(); },
-accelerator => " or ");
$zoom_menu->command(-label => lang("fill"),
-command => sub { $conf{zoom_fit_fill}{value} = FILL; fitPicture(); },
-accelerator => "");
my $i;
for ($i = 0; $i < (@frac); $i += 2) {
my $z = $frac[$i];
my $s = $frac[$i+1];
my $l = sprintf "%4d%%",($z/$s*100);
unless ($l =~ m/\w*100%/) {
$zoom_menu->command(-label => $l,
-command => sub { zoom($z, $s); } );
}
else {
$zoom_menu->command(-label => $l,
-command => sub { zoom($z, $s); },
-accelerator => " or ");
}
}
}
##############################################################
# the flags (red, green, blue) are used to mark pictures e.g.
# for further processing. They are not stored in the picture,
# but in the search database as bits
##############################################################
sub flag_toggle {
my $lb = shift;
my $flag = shift;
return unless (defined($flag));
return if (($flag < 0) or ($flag > 8));
my @sellist = getSelection($lb);
return unless checkSelection($lb, 1, 0, \@sellist, lang("picture(s)"));
my $pw = progressWinInit($top, lang("Set / reset flags"));
my $picnr = 0;
foreach my $dpic (@sellist) {
last if (progressWinCheck($pw));
$picnr++;
progressWinUpdate($pw, "Processing picture $picnr/".scalar(@sellist), $picnr, scalar(@sellist));
# init flag if it does not exists
if (not exists $searchDB{$dpic}{FLAG}) {
$searchDB{$dpic}{FLAG} = FLAG_RESET;
}
if ($flag == FLAG_RESET) {
$searchDB{$dpic}{FLAG} = FLAG_RESET;
}
else {
$searchDB{$dpic}{FLAG} ^= $flag; # binary XOR = toggle flag
}
updateOneRow($dpic, $lb);
# currently (2011-08) not needed, because the flags are
# only shown in the thumbnail table
#if ($dpic eq $actpic) {
# showImageInfoCanvas($dpic);
# showImageInfo($dpic);
#}
}
progressWinEnd($pw);
log_it(langf("Ready! Flag %d toggled in %d pictures.",$flag, scalar(@sellist)));
}
##############################################################
# mark all selected pictures which are used in a picture collection
# with the given flag color
##############################################################
sub flag_set_collection {
my $lb = shift;
my $flag = shift;
return unless (defined($flag));
return if (($flag < 1) or ($flag > 8));
my @sellist = getSelection($lb);
return unless checkSelection($lb, 1, 0, \@sellist, lang("picture(s)"));
my $slideshow_pics = build_slideshow_pic_hash();
my $marked_pics = 0;
my $pw = progressWinInit($top, lang("Set / reset flags"));
my $picnr = 0;
foreach my $dpic (@sellist) {
last if (progressWinCheck($pw));
$picnr++;
progressWinUpdate($pw, "Processing picture $picnr/".scalar(@sellist), $picnr, scalar(@sellist));
if (defined $$slideshow_pics{$dpic}) {
print "$dpic is used in a slideshow!\n";
$searchDB{$dpic}{FLAG} |= $flag; # binary OR = set flag
updateOneRow($dpic, $lb);
$marked_pics++;
}
}
progressWinEnd($pw);
log_it(langf("Ready! %d of the %d selected pictures are used in a collection and are now marked with a flag.",$marked_pics, scalar(@sellist)));
}
##############################################################
# addMetaInfoMenu
##############################################################
sub addMetaInfoMenu {
my $menu = shift;
my $flag_menu = $menu->cascade(-image => compound_menu($top, lang("Flags"), 'media-record16-red.png'));
$flag_menu->cget(-menu)->configure(-title => lang("Flags"));
$flag_menu->command(-image => compound_menu($top, lang('Red flag'), 'media-record16-red.png'), -command => sub { flag_toggle($picLB, FLAG_RED); }, -accelerator => "");
$flag_menu->command(-image => compound_menu($top, lang('Green flag'), 'media-record16-green.png'), -command => sub { flag_toggle($picLB, FLAG_GREEN); }, -accelerator => "");
$flag_menu->command(-image => compound_menu($top, lang('Blue flag'), 'media-record16-blue.png'), -command => sub { flag_toggle($picLB, FLAG_BLUE); }, -accelerator => "");
$flag_menu->separator;
$flag_menu->command(-image => compound_menu($top, lang('Flag pictures used in collections'), 'media-record16-green.png'), -command => sub { flag_set_collection($picLB, FLAG_GREEN); });
$flag_menu->separator;
$flag_menu->command(-image => compound_menu($top, lang('Reset all flags'), ''), -command => sub { flag_toggle($picLB, FLAG_RESET); });
my $iptc_menu = $menu->cascade(-image => compound_menu($top, 'IPTC', ''));
$iptc_menu->cget(-menu)->configure(-title => "IPTC/IIM information");
$iptc_menu->command(-image => compound_menu($top, lang('Show'), ''), -command => sub { displayIPTCData($picLB); }, -accelerator => "");
$iptc_menu->command(-image => compound_menu($top, lang('Edit ...'), 'accessories-text-editor.png'), -command => sub { editIPTC($picLB); }, -accelerator => "