App-PhotoDB
view release on metacpan or search on metacpan
lib/App/PhotoDB/funcs.pm view on Meta::CPAN
my $rows = &updaterecord({db=>$db, data=>\%data, table=>'FILM', where=>{film_id=>$film_id}});
=head4 Arguments
=item * C<$db> DB handle
=item * C<$data> Hash of new values to update
=item * C<$table> Name of table to update
=item * C<$where> Where clause, formatted for SQL::Abstract
=item * C<$silent> Suppress output
=item * C<$log> Write an event to the database log. Defaults to C<1>.
=head4 Returns
The number of rows updated
=cut
sub updaterecord {
# Pass in a hashref of arguments
my $href = shift;
# Unpack the hashref and set default values
my $db = $href->{db}; # DB handle
my $data = $href->{data}; # Hash of new values to update
my $table = $href->{table}; # Name of table to update
my $where = $href->{where}; # Where clause, formatted for SQL::Abstract
my $silent = $href->{silent} // 0; # Suppress output
my $log = $href->{log} // 1; # Write event to log
# Quit if we didn't get params
die 'Must pass in $db' if !($db);
die 'Must pass in $data' if !($data);
die 'Must pass in $table' if !($table);
die 'Must pass in $where' if !($where);
# Delete empty strings from data hash
$data = &thin($data);
if (scalar(keys %$data) == 0) {
print "Nothing to update\n";
return 0;
}
# Work out affected rows
my $rowcount = &lookupval({db=>$db, col=>'count(*)', table=>$table, where=>$where});
# Dump data for debugging
print "\n\nThis is what I will update into $table where:\n" unless $silent;
print Dump($where) unless $silent;
print Dump($data) unless $silent;
print "\n$rowcount records will be updated\n" unless $silent;
print "\n" unless $silent;
# Build query
my $sql = SQL::Abstract->new;
my($stmt, @bind) = $sql->update($table, $data, $where);
# Final confirmation
unless ($silent) {
if (!&prompt({default=>'yes', prompt=>'Proceed?', type=>'boolean'})) {
print "Aborted!\n";
return;
}
}
# Execute query
my $sth = $db->prepare($stmt);
my $rows = $sth->execute(@bind);
$rows = &unsci($rows);
print "Updated $rows rows\n" unless $silent;
&logger({db=>$db, type=>'EDIT', message=>"$table $rows rows"}) if $log;
return $rows;
}
# Delete an existing record in any table
=head2 deleterecord
Delete an existing record from any table
=head4 Usage
my $rows = &deleterecord({db=>$db, table=>'FILM', where=>{film_id=>$film_id}});
=head4 Arguments
=item * C<$db> DB handle
=item * C<$table> Name of table to delete from
=item * C<$where> Where clause, formatted for SQL::Abstract
=item * C<$silent> Suppress output
=item * C<$log> Write an event to the database log. Defaults to C<1>.
=head4 Returns
The number of rows deleted
=cut
sub deleterecord {
# Pass in a hashref of arguments
my $href = shift;
# Unpack the hashref and set default values
my $db = $href->{db}; # DB handle
my $table = $href->{table}; # Name of table to delete from
my $where = $href->{where}; # Where clause, formatted for SQL::Abstract
my $silent = $href->{silent} // 0; # Suppress output
my $log = $href->{log} // 1; # Write event to log
# Quit if we didn't get params
die 'Must pass in $db' if !($db);
die 'Must pass in $table' if !($table);
die 'Must pass in $where' if !($where);
# Work out affected rows
my $rowcount = &lookupval({db=>$db, col=>'count(*)', table=>$table, where=>$where});
# Dump data for debugging
print "\n\nI will delete from $table where:\n" unless $silent;
print Dump($where) unless $silent;
print "$rowcount records will be deleted\n" unless $silent;
# Build query
my $sql = SQL::Abstract->new;
my($stmt, @bind) = $sql->delete($table, $where);
# Final confirmation
unless ($silent) {
if (!&prompt({default=>'yes', prompt=>'Proceed?', type=>'boolean'})) {
print "Aborted!\n";
return;
}
}
# Execute query
my $sth = $db->prepare($stmt);
my $rows = $sth->execute(@bind);
$rows = &unsci($rows);
print "Deleted $rows rows\n" unless $silent;
&logger({db=>$db, type=>'DELETE', message=>"$table $rows rows"}) if $log;
return $rows;
}
=head2 newrecord
Insert a record into any table
=head4 Usage
my $id = &newrecord({db=>$db, data=>\%data, table=>'FILM'});
=head4 Arguments
=item * C<$db> DB handle
=item * C<$data> reference to hash of new values to insert
=item * C<$table> Name of table to insert into
=item * C<$silent> Suppress user output and don't ask for confirmation. Defaults to C<0>.
=item * C<$log> Write an event to the database log. Defaults to C<1>.
=head4 Returns
Primary key of inserted row
=cut
sub newrecord {
# Pass in a hashref of arguments
my $href = shift;
# Unpack the hashref and set default values
my $db = $href->{db}; # DB handle
my $data = $href->{data}; # Hash of new values to insert
my $table = $href->{table}; # Table to insert into
my $silent = $href->{silent} // 0; # Suppress output
my $log = $href->{log} // 1; # Log this event
# Quit if we didn't get params
die 'Must pass in $db' if !($db);
die 'Must pass in $data' if !($data);
die 'Must pass in $table' if !($table);
# Delete empty strings from data hash
$data = &thin($data);
# Dump data for debugging
print "\n\nThis is what I will insert into $table:\n" unless $silent;
print Dump($data) unless $silent;
print "\n" unless $silent;
# Build query
my $sql = SQL::Abstract->new;
my($stmt, @bind) = $sql->insert($table, $data);
# Final confirmation
unless ($silent) {
if (!&prompt({default=>'yes', prompt=>'Proceed?', type=>'boolean'})) {
print "Aborted!\n";
return;
}
}
# Execute query
my $sth = $db->prepare($stmt);
$sth->execute(@bind);
# Display inserted row
my $insertedrow = $sth->{mysql_insertid};
print "Inserted $table $insertedrow\n" unless $silent;
&logger({db=>$db, type=>'ADD', message=>"$table #$insertedrow"}) if $log;
return $insertedrow;
}
=head2 notimplemented
Print a warning that this command/subcommand is not yet implemented
=head4 Usage
¬implemented
=head4 Arguments
None
=head4 Returns
Nothing
=cut
sub notimplemented {
print "This command or subcommand is not yet implemented.\n";
return;
}
=head2 nocommand
Print list of available top-level commands
=head4 Usage
&nocommand(\%handlers);
=head4 Arguments
=item * C<$handlers> reference to hash of handlers from C<handlers.pm>
=head4 Returns
Nothing
=cut
sub nocommand {
my $handlers = shift;
print "<command> <subcommand>\n\n";
print "Please enter a valid command. Valid commands are:\n";
print "\t$_\n" for sort keys %$handlers;
return;
}
# Print list of subcommands for a given command
lib/App/PhotoDB/funcs.pm view on Meta::CPAN
=head4 Arguments
=item * C<$db> DB handle
=item * C<$query> (legacy) the SQL to generate the list of choices
=item * C<$type> Data type of choice to be made. Defaults to C<text>
=item * C<$inserthandler> function ref to handler that can be used to insert a new row if necessary
=item * C<$default> ID of default choice
=item * C<$autodefault> if default not set, count number of allowed options and if there's just 1, make it the default
=item * C<$skipok> whether it is ok to return C<undef> if there are no options to choose from
=item * C<$table> table to run query against. Part of the SQL::Abstract tuple
=item * C<$cols> columns to select for the ID and the description. Defaults to C<('id', 'opt)>. Part of the SQL::Abstract tuple
=item * C<$where> where clause passed in as a hash, e.g. C<{'field'=>'value'}>. Part of the SQL::Abstract tuple
=item * C<$keyword> keyword to describe the thing being chosen, e.g. C<camera>. Defaults to attempting to figure it out with C<&keyword>
=item * C<$required> whether this is a required choice, or whether we allow the user to enter an empty input. Defaults to C<0>
=item * C<$char> character to use to signal that you want to enter a new row, if C<inserthandler> is set. Defaults to C<+>
=head4 Returns
ID of the selected option
=cut
sub listchoices {
# Pass in a hashref of arguments
my $href = shift;
my $db = $href->{db}; # DB handle
my $query = $href->{query}; # (legacy) the SQL to generate the list of choices
my $type = $href->{type} || 'text'; # Data type of choice to be made. Often but not always integer
my $inserthandler = $href->{inserthandler}; # ref to handler that can be used to insert a new row
my $default = $href->{default} // ''; # id of default choice
my $autodefault = $href->{autodefault} // 1; # if default not set, count number of allowed options and if there's just 1, make it the default
my $skipok = $href->{skipok} || 0; # whether it is ok to return null if there are no options to choose from
my $table = $href->{table}; # Part of the SQL::Abstract tuple
my $cols = $href->{cols} // ('id, opt'); # Part of the SQL::Abstract tuple
my $where = $href->{where} // {}; # Part of the SQL::Abstract tuple
my $keyword = $href->{keyword} || &keyword($table) || &keyword($query); # keyword to describe the thing being chosen
my $required = $href->{required} // 0; # whether we allow the user to enter an empty input
my $char = $href->{char} // '+'; # character to use to signal that you want to enter a new row
my ($sth, $rows);
if ($query) {
# Use the manual query
$sth = $db->prepare($query) or die "Couldn't prepare statement: " . $db->errstr;
$rows = $sth->execute();
} elsif ($table && $cols && $where) {
# Use SQL::Abstract
my $sql = SQL::Abstract->new;
my($stmt, @bind) = $sql->select($table, $cols, $where);
$sth = $db->prepare($stmt);
$rows = $sth->execute(@bind);
} else {
die "Must pass in either query OR table, cols, where\n";
}
# No point in proceeding if there are no valid options to choose from
if ($rows == 0) {
print "No valid $keyword options to choose from\n";
if ($inserthandler && &prompt({prompt=>"Add a new $keyword?", type=>'boolean', default=>'no'})) {
# add a new entry
my $id = $inserthandler->({db=>$db});
return $id;
} elsif ($skipok) {
return;
} else {
die;
}
}
my @allowedvals;
while (my $ref = $sth->fetchrow_hashref) {
print "\t$ref->{id}\t$ref->{opt}\n";
# Make a note of what allowed options are
push(@allowedvals, $ref->{id});
}
# Add option to insert a new row, if applicable
if ($inserthandler) {
print "\t$char\tAdd a new $keyword\n";
push(@allowedvals, $char);
}
if ($default eq '' && $autodefault) {
# If no default is given, count number of allowed options
# and if there's just one, make it the default
if ($rows == 1) {
$default = $allowedvals[0];
}
} else {
# Check that the provided default is an allowed value
# Otherwise silently unset it
if ($default && !($default ~~ @allowedvals)) {
$default = '';
}
}
# Loop until we get valid input
my $input;
my $msg = "Please select a $keyword from the list";
$msg .= ', or leave blank to skip' if ($required == 0);
do {
$input = &prompt({default=>$default, prompt=>$msg, type=>$type, required=>$required});
} while ($input && !($input ~~ [ map {"$_"} @allowedvals ] || $input eq ''));
# Spawn a new handler if that's what the user chose
# Otherwise return what we got
if ($input eq $char && $inserthandler) {
my $id = $inserthandler->({db=>$db});
return $id;
lib/App/PhotoDB/funcs.pm view on Meta::CPAN
print "\t$index\t$$choice{desc}\n";
push(@allowedvals, $index);
}
# Loop until we get valid input
my $input;
my $msg = "Please select an action from the list";
do {
$input = &prompt({prompt=>$msg, type=>'integer'});
} while ($input && !($input ~~ [ map {"$_"} @allowedvals ] || $input eq ''));
return $input;
}
=head2 printlist
Print arbitrary rows from the database as an easy way of displaying data
=head4 Usage
&printlist({db=>$db, msg=>"prints from negative $neg_id", table=>'info_print', where=>{`Negative ID`=>$neg_id}});
=head4 Arguments
=item * C<$db> DB handle
=item * C<$msg> Message to display to user to describe what is being displayed. Shows up as C<Now showing $msg\n>
=item * C<$table> Table to select from. Part of the SQL::Abstract tuple
=item * C<$cols> Columns to display. Defaults to C<(id, opt)>. Part of the SQL::Abstract tuple
=item * C<$where> Where clause for the query. Part of the SQL::Abstract tuple
=item * C<$order> Order by clause for the query. Part of the SQL::Abstract tuple
=head4 Returns
Integer representing the number of rows printed
=cut
sub printlist {
# Pass in a hashref of arguments
my $href = shift;
my $db = $href->{db}; # DB handle
my $msg = $href->{msg}; # Message to display to user
my $table = $href->{table}; # Part of the SQL::Abstract tuple
my $cols = $href->{cols} // ('id, opt'); # Part of the SQL::Abstract tuple
my $where = $href->{where} // {}; # Part of the SQL::Abstract tuple
my $order = $href->{order}; # Part of the SQL::Abstract tuple
print "Now showing $msg\n";
my ($sth, $rows);
if ($table && $cols && $where) {
# Use SQL::Abstract
my $sql = SQL::Abstract->new;
my($stmt, @bind) = $sql->select($table, $cols, $where, $order);
$sth = $db->prepare($stmt);
$rows = $sth->execute(@bind);
$rows = &unsci($rows);
} else {
print "Must pass in table, cols, where\n";
return;
}
while (my $ref = $sth->fetchrow_hashref) {
print "\t$ref->{id}\t$ref->{opt}\n";
}
return $rows;
}
# Return values from an arbitrary column from database as an arrayref
=head2 lookupcol
Return values from an arbitrary column from database as an arrayref
=head4 Usage
my $existing = &lookupcol({db=>$db, table=>'CAMERA', where=>{camera_id=>$camera_id}});
=head4 Arguments
=item * C<$db> DB handle
=item * C<$query> (legacy) bare SQL query to run
=item * C<$table> table to run query against. Part of the SQL::Abstract tuple
=item * C<$cols> columns to select for the ID and the description. Defaults to C<*>. Part of the SQL::Abstract tuple
=item * C<$where> where clause passed in as a hash, e.g. C<{'field'=>'value'}>. Part of the SQL::Abstract tuple
=head4 Returns
An arrayref containing a hashref of columns and values
=cut
sub lookupcol {
# Pass in a hashref of arguments
my $href = shift;
my $db = $href->{db}; # DB handle
my $query = $href->{query}; # (legacy) SQL query to run
my $table = $href->{table}; # Part of the SQL::Abstract tuple
my $cols = $href->{cols} // '*'; # Part of the SQL::Abstract tuple
my $where = $href->{where} // {}; # Part of the SQL::Abstract tuple
my ($sth, $rows);
if ($query) {
$sth = $db->prepare($query) or die "Couldn't prepare statement: " . $db->errstr;
$rows = $sth->execute();
} elsif ($table && $cols && $where) {
# Use SQL::Abstract
my $sql = SQL::Abstract->new;
my($stmt, @bind) = $sql->select($table, $cols, $where);
$sth = $db->prepare($stmt);
$rows = $sth->execute(@bind);
} else {
print "Must pass in either query OR table, cols, where\n";
return;
}
my @array;
while (my $ref = $sth->fetchrow_hashref) {
$ref = &thin($ref);
push(@array, $ref);
}
return \@array;
}
# Thin out keys will null values from a sparse hash
=head2 thin
Thin out keys with empty values from a sparse hash
=head4 Usage
$data = &thin($data);
=head4 Arguments
=item * C<$data> Hashref containing data to be thinned
=head4 Returns
Hashref containing thinned data
=cut
sub thin {
my $data = shift;
foreach (keys %$data) {
delete $$data{$_} unless (defined $$data{$_} and $$data{$_} ne '');
}
return \%$data;
}
=head2 lookupval
Return arbitrary single value from database
=head4 Usage
my $info = &lookupval({db=>$db, col=>'notes', table=>'FILM', where=>{film_id=>$film_id}});
=head4 Arguments
=item * C<$db> DB handle
=item * C<$query> (legacy) bare SQL query to run
=item * C<$table> table to run query against. Part of the SQL::Abstract tuple
=item * C<$col> column to select. Part of the SQL::Abstract tuple
=item * C<$where> where clause passed in as a hash, e.g. C<{'field'=>'value'}>. Part of the SQL::Abstract tuple
=head4 Returns
Single value from the database
=cut
sub lookupval {
# Pass in a hashref of arguments
my $href = shift;
my $db = $href->{db}; # DB handle
my $query = $href->{query}; # (legacy) SQL query to run
my $table = $href->{table}; # Part of the SQL::Abstract tuple
my $col = $href->{col}; # Part of the SQL::Abstract tuple
my $where = $href->{where} // {}; # Part of the SQL::Abstract tuple
my ($sth, $rows);
if ($query) {
# Use the manual query
$sth = $db->prepare($query) or die "Couldn't prepare statement: " . $db->errstr;
$rows = $sth->execute();
} elsif ($table && $col && $where) {
# Use SQL::Abstract
my $sql = SQL::Abstract->new;
my($stmt, @bind) = $sql->select($table, $col, $where);
$sth = $db->prepare($stmt);
$rows = $sth->execute(@bind);
} else {
print "Must pass in either query OR table, col, where\n";
return;
}
my $row = $sth->fetchrow_array();
return $row;
}
=head2 call
Call a stored procedure from the database
=head4 Usage
&call({db=>$db, procedure=>'print_unarchive', args=>['123']});
=head4 Arguments
=item * C<$db> DB handle
=item * C<$procedure> name of the database stored procedure to call
=item * C<$args> arrayref of arguments to pass to the stored procedure
=head4 Returns
Number of affected rows
=cut
sub call {
my $href = shift;
my $db = $href->{db};
my $procedure = $href->{procedure};
my $args = $href->{args};
my $arglist;
if (defined $args) {
$arglist = join(',', @$args);
} else {
$arglist = '';
}
my $query = "call $procedure($arglist)";
my $sth = $db->prepare($query);
my $rows = $sth->execute();
return $rows;
}
=head2 lookuplist
Return multiple values from a single database column as an arrayref
=head4 Usage
my $values = &lookuplist({db=>$db, col=>$column, table=>$table, where{key=>value}});
=head4 Arguments
=item * C<$db> DB handle
=item * C<$table> table to run query against. Part of the SQL::Abstract tuple
=item * C<$col> column to select. Part of the SQL::Abstract tuple
=item * C<$where> where clause passed in as a hash, e.g. C<{'field'=>'value'}>. Part of the SQL::Abstract tuple
=head4 Returns
An arreyref containing a list of values
=cut
sub lookuplist {
# Pass in a hashref of arguments
my $href = shift;
my $db = $href->{db}; # DB handle
my $table = $href->{table}; # Part of the SQL::Abstract tuple
my $col = $href->{col}; # Part of the SQL::Abstract tuple
my $where = $href->{where} // {}; # Part of the SQL::Abstract tuple
my ($sth, $rows);
if ($table && $col && $where) {
# Use SQL::Abstract
my $sql = SQL::Abstract->new;
my($stmt, @bind) = $sql->select($table, $col, $where);
$sth = $db->prepare($stmt);
$rows = $sth->execute(@bind);
} else {
print "Must pass in table, col, where\n";
return;
}
my @list;
while (my @row = $sth->fetchrow_array()) {
push(@list, $row[0]);
}
return \@list;
}
# Return today's date according to the DB
=head2 today
Return today's date according to the DB
=head4 Usage
my $todaysdate = &today;
=head4 Arguments
=item * C<$db> DB handle
=head4 Returns
Today's date, formatted C<YYYY-MM-DD>
=cut
sub today {
return localtime->strftime('%Y-%m-%d');
}
=head2 now
Return an SQL-formatted timestamp for the current time
=head4 Usage
my $time = &now;
=head4 Arguments
=item * C<$db> Database handle
=head4 Returns
String containing the current time, formatted C<YYYY-MM-DD HH:MM:SS>
=cut
sub now {
return localtime->strftime('%Y-%m-%d %H:%M:%S');
}
# Translate "friendly" bools to integers
lib/App/PhotoDB/funcs.pm view on Meta::CPAN
# Define hash to hold results
my %results;
if ($model =~ m/(\d+)-?(\d+)?mm/) {
$results{minfocal} = $1;
$results{maxfocal} = $2;
}
if ($results{minfocal} && $results{maxfocal}) {
$results{zoom} = 'yes';
} else {
$results{zoom} = 'no';
}
if ($model =~ m/(f\/|1:)([\d\.]+)/) {
$results{aperture} = $2;
}
if ($param) {
# If a specific param was requested, return it
return $results{$param};
} else {
# Else return a hashref of all params
return \%results;
}
}
=head2 unsetdisplaylens
Unassociate a display lens from a camera by passing in either the camera ID or
the lens ID. It is not harmful to pass in both, but it is pointless.
=head4 Usage
&unsetdisplaylens({db=>$db, camera_id=>$camera_id});
&unsetdisplaylens({db=>$db, lens_id=>$lens_id});
=head4 Arguments
=item * C<$db> DB handle
=item * C<$camera_id> ID of camera whose display lens you want to unassociate
=item * C<$lens_id> ID of lens you want to unassociate
=head4 Returns
Result of SQL update
=cut
sub unsetdisplaylens {
my $href = shift;
my $db = $href->{db};
my %where;
$where{camera_id} = $href->{camera_id};
$where{display_lens} = $href->{lens_id};
my $thinwhere = &thin(\%where);
# Build query
my $sql = SQL::Abstract->new;
my($stmt, @bind) = $sql->update('CAMERA', {display_lens => undef}, $thinwhere);
# Execute query
my $sth = $db->prepare($stmt);
return $sth->execute(@bind);
}
=head2 welcome
Print a friendly welcome message
=head4 Usage
&welcome;
=head4 Arguments
None
=head4 Returns
Nothing
=cut
sub welcome {
my $version = $App::PhotoDB::VERSION;
my $ascii = <<'END_ASCII';
____ _ _ ____ ____
| _ \| |__ ___ | |_ ___ | _ \| __ )
| |_) | '_ \ / _ \| __/ _ \| | | | _ \
| __/| | | | (_) | || (_) | |_| | |_) |
|_| |_| |_|\___/ \__\___/|____/|____/
END_ASCII
print $ascii . ' ' x 29 . 'v' . $version . "\n\n";
return;
}
=head2 duration
Calculate duration of a shutter speed from its string representation
=head4 Usage
my $duration = &duration($shutter_speed);
=head4 Arguments
=item * C<$shutter_speed> string containing a representation of a shutter speed, e.g. C<1/125>, C<0.7>, C<3>, or C<3">
=head4 Returns
Numeric representation of the duration of the shutter speed, e.g. C<0.05>
=cut
sub duration {
my $shutter_speed = shift;
my $duration = 0;
# Expressed like 1/125
if ($shutter_speed =~ m/1\/(\d+)/) {
$duration = 1 / $1;
# Expressed like 0.3 or 1
} elsif ($shutter_speed =~ m/((0\.)?\d+)/) {
$duration = $1;
lib/App/PhotoDB/funcs.pm view on Meta::CPAN
&tag({db=>$db, where=>{film_id=1}});
&tag({db=>$db, where=>{negative_id=100}});
=head4 Arguments
=item * C<$db> DB handle
=item * C<$where> hash to specify which scans should be tagged. Tags all scans if not set!
=head4 Returns
Nothing
=cut
sub tag {
# Read in cmdline args
my $href = shift;
my $db = $href->{db};
my $where = $href->{where};
# Make sure basepath is valid
my $basepath = &basepath;
# Crank up an instance of ExifTool
my $exifTool = Image::ExifTool->new;
$exifTool->Options(CoordFormat => q{%+.6f});
# Specify which attributes we want to write
# If any are specified here but not available, they will be ignored
my @attributes = (
'Make',
'Model',
'Lens',
'LensModel',
'ExposureTime',
'MaxApertureValue',
'FNumber',
'ApertureValue',
'FocalLength',
'ISO',
'Author',
'ImageDescription',
'DateTimeOriginal',
'ExposureProgram',
'MeteringMode',
'Flash',
'GPSLatitude',
'GPSLongitude',
'FocalLengthIn35mmFormat',
'LensSerialNumber',
'SerialNumber',
'LensMake',
'Copyright',
'UserComment',
);
# This is the query that fetches (and calculates) values from the DB that we want to write as EXIF tags
my $sql = SQL::Abstract->new;
my($stmt, @bind) = $sql->select('exifdata', '*', $where);
# Prepare and execute the SQL
my $sth = $db->prepare($stmt) or die "Couldn't prepare statement: " . $db->errstr;
my $rows = $sth->execute(@bind);
$rows = &unsci($rows);
# Get confirmation
if ($rows == 0) {
print "No scans be will tagged\n";
return;
}
return unless &prompt({prompt=>"This will review and potentially update the tags of $rows scans. Proceed?", type=>'boolean'});
# Set some globals
my $foundcount=0;
my $changedcount=0;
my @missingfiles;
# Loop through our result set
while (my $ref = $sth->fetchrow_hashref()) {
# First check the path is defined in MySQL
if (defined($ref->{'path'})) {
# Now make sure the path actually exists on the system
if (-e "$basepath/$ref->{'path'}") {
# File exists, so we go on and do stuff to it.
# Grab the existing EXIF tags for comparison
my $exif = $exifTool->ImageInfo("$basepath/$ref->{'path'}");
my $changeflag = 0;
$foundcount++;
# For each of the attributes on our list...
foreach my $var (@attributes) {
# Test if it exists in the DB
if (defined($ref->{$var})) {
# Test if it already exists in the file AND has the correct value, either string OR numeric format
if (defined($exif->{$var}) && ($exif->{$var} ~~ $ref->{$var})) {
# Tag already has correct value, skip
next;
} else {
# Set the value of the tag and flag that a change was made
if (defined($exif->{$var})) {
# Already defined, update it
print "\tChanging $var: $exif->{$var} => $ref->{$var}\n";
} else {
# Not defined, set it
print "\tSetting $var: $ref->{$var}\n";
}
$exifTool->SetNewValue($var => $ref->{$var});
$changeflag = 1;
}
}
}
# If a change has been made to the EXIF data, write out the data
if ($changeflag == 1) {
$exifTool->WriteInfo("$basepath/$ref->{'path'}");
print "Wrote tags to $basepath/$ref->{'path'}\n\n";
$changedcount++;
}
} else {
print "$basepath/$ref->{'path'} not found - skipping\n";
push (@missingfiles, "$basepath/$ref->{'path'}");
}
}
lib/App/PhotoDB/funcs.pm view on Meta::CPAN
db => $db,
cols => $cols,
table => $table,
where => $where,
skipok => 1,
});
# Bail out if no results found
if (!$id) {
print "No $keyword objects matching '$searchterm' were found\n";
return 0;
}
if ($choices && @$choices >0) {
# Ask user to choose a followup action
my $action = &multiplechoice({choices => $choices});
# Execute chosen handler with ID passed into named arg
if ($action && $choices->[$action]{handler}) {
$choices->[$action]{handler}->({db=>$db, $choices->[$action]{id}=>$id});
}
} else {
print "Selected $id\n";
}
return;
}
=head2 tabulate
Display multi-column SQL views as tabulated data.
=head4 Usage
&tabulate({db=>$db, view=>$view});
=head4 Arguments
=item * C<$db> database handle
=item * C<$view> name of SQL view to print
=item * C<$cols> columns of view to return. Defaults to C<*>
=item * C<$where> optional WHERE clause
=head4 Returns
Number of rows displayed
=cut
sub tabulate {
my $href = shift;
my $db = $href->{db};
my $view = $href->{view};
my $cols = $href->{cols} // '*';
my $where = $href->{where} // {};
# Use SQL::Abstract
my $sql = SQL::Abstract->new;
my($stmt, @bind) = $sql->select($view, $cols, $where);
my $sth = $db->prepare($stmt);
my $rows = $sth->execute(@bind);
my $returnedcols = $sth->{'NAME'};
my @array;
my $table = Text::TabularDisplay->new(@$returnedcols);
while (my @row = $sth->fetchrow) {
$table->add(@row);
}
# print "$choices[$action]{'desc'}\n";
print $table->render;
print "\n";
return $rows;
}
=head2 canondatecode
Decode Canon datecodes to discover the year of manufacture. Datecodes are sometimes ambiguous so by passing in the dates that the model was
introduced and discontinued, the year of manufacture can be pinned down.
=head4 Usage
my $manufactured = &canondatecode({datecode=>$datecode, introduced=>$introduced, discontinued=>$discontinued});
=head4 Arguments
=item * C<$datecode> the datecode to decode
=item * C<$introduced> year that the model was introduced. Assumes 1800 if not defined.
=item * C<$discontinued> year that the model was discontinued. Assumes 2100 if not defined.
=head4 Returns
Year of manufacture if the decoding was successful, otherwise undef
=cut
sub canondatecode {
my $href = shift;
my $datecode = $href->{datecode};
my $introduced = $href->{introduced} // 1800;
my $discontinued = $href->{discontinued} // 2100;
# Reformat datecode for reliable matching
$datecode = uc($datecode);
$datecode =~ s/[^A-Z0-9]//g;
# Map alphabet to numbers
my %h;
@h{'A' .. 'Z'} = (0 .. 25);
my @guesses;
# AB1234, B1234A, B123A
# From 1960-2012, the date code is in the form of "AB1234". "A" indicates the factory. Prior to 1986, "A" is moved to the end.
# "B" is a year code that indicates the year of manufacture. Canon increments this letter each year starting with A in 1960
# Of the 4 digits, the first two are the month of manufacture. Sometimes the leading 0 is omitted.
if ($datecode =~ /^[A-Z]?([A-Z])[0-9]{3,4}[A-Z]?$/ ) {
my $dateletter = $1;
my $epochstart = 1960;
( run in 0.708 second using v1.01-cache-2.11-cpan-2398b32b56e )