App-PhotoDB
view release on metacpan or search on metacpan
lib/App/PhotoDB/funcs.pm view on Meta::CPAN
package App::PhotoDB::funcs;
=head1 Functions
This package provides reusable functions to be consumed by the rest of the PhotoDB application.
Note that some of these functions take traditional argument lists which must
be in order, while the more complex functions take a hashref of arguments
which can be passed in any order. Examples of each function are given.
=cut
use strict;
use warnings;
use experimental 'smartmatch';
use DBI;
use DBD::mysql;
use SQL::Abstract;
use Exporter qw(import);
use Config::IniHash;
use YAML;
use Image::ExifTool;
use Term::ReadLine;
use Term::ReadLine::Perl;
use File::Basename;
use Time::Piece;
use Text::TabularDisplay;
our @EXPORT_OK = qw(prompt db updaterecord deleterecord newrecord notimplemented nocommand nosubcommand listchoices lookupval lookuplist today validate ini printlist round pad lookupcol thin resolvenegid chooseneg annotatefilm keyword parselensmodel ...
=head2 prompt
Prompt the user for an arbitrary value. Has various options for data validation and customisation of the prompt.
If the provided input fails validation, or if a blank string is given when required=1 then the prompt is repeated.
=head4 Usage
my $camera = &prompt({prompt=>'What model is the camera?', required=>1, default=>$$defaults{model}, type=>'text'});
would give a prompt like
What model is the camera? (text) []:
=head4 Arguments
=item * C<$default> Default value that will be used if no input from user. Default empty string.
=item * C<$prompt> Prompt message for the user
=item * C<$type> Data type that this input expects, out of C<text>, C<integer>, C<boolean>, C<date>, C<decimal>, C<time>
=item * C<$required> Whether this input is required, or whether it can return an empty value. Default C<0>
=item * C<$showtype> Whether to show the user what data type is expected, in parentheses. Default C<1>
=item * C<$showdefault> Whether to show the user what the default value is set to, in square brackets. Default C<1>
=item * C<$char> Character to print at the end of the prompt. Defaults to C<:>
=head4 Returns
The value the user provided
=cut
sub prompt {
# Pass in a hashref of arguments
my $href = shift;
# Unpack the hashref and set default values
my $default = $href->{default} // ''; # Default value that will be used if no input from user
my $prompt = $href->{prompt}; # Prompt message for the user
my $type = $href->{type} || 'text'; # Data type that this input expects, out of text, integer, boolean, date, decimal, time
my $required = $href->{required} // 0; # Whether this input is required, or whether it can return an empty value
my $showtype = $href->{showtype} // 1; # Whether to show the user what data type is expected
my $showdefault = $href->{showdefault} // 1; # Whether to show the user what the default value is
my $char = $href->{char} // ':'; # Character to print at the end of the prompt
die "Must provide value for \$prompt\n" if !($prompt);
# Rewrite binary bools as strings
if ($type eq 'boolean' && $default ne '') {
$default = &printbool($default);
}
# Assemble prompt text
my $msg = $prompt;
$msg .= " ($type)" if $showtype;
$msg .= " [$default]" if $showdefault;
$msg .= "$char ";
lib/App/PhotoDB/funcs.pm view on Meta::CPAN
if ($val =~ m/^y(es)?$/i || $val =~ m/^true$/i || $val eq 1) {
return 1;
} elsif ($val =~ m/^n(o)?$/i || $val =~ m/^false$/i || $val eq 0) {
return 0;
} else {
return '';
}
}
=head2 printbool
Translate numeric bools to strings for friendly printing of user messages.
See also &friendlybool.
=head4 Usage
my $string = &printbool($bool);
=head4 Arguments
=item * C<$bool> boolean value to rewrite
=head4 Returns
Returns C<yes> if C<$bool> is true and C<no> if C<$bool> is false.
=cut
sub printbool {
my $val = shift;
if ($val =~ m/^y(es)?$/i || $val =~ m/^true$/i || $val eq 1) {
return 'yes';
} elsif ($val =~ m/^n(o)?$/i || $val =~ m/^false$/i || $val eq 0) {
return 'no';
} else {
return '';
}
}
=head2 writeconfig
Write out an initial config file by prompting the user interactively.
=head4 Usage
&writeconfig($path);
=head4 Arguments
=item * C<$path> path to the config file that should be written
=head4 Returns
Nothing
=cut
sub writeconfig {
my $inifile = shift;
# Untaint
unless ($inifile =~ m#^([\w.-\/]+)$#) {
die "filename '$inifile' has invalid characters.\n";
}
$inifile = $1;
# Check for existence of config dir
my $dir = dirname($inifile);
if (!-d $dir) {
# Create it if necessary
mkdir $dir or die "Can't create config directory $dir";
}
my %inidata;
$inidata{'database'}{'host'} = &prompt({default=>'localhost', prompt=>'Database hostname or IP address', type=>'text'});
$inidata{'database'}{'schema'} = &prompt({default=>'photodb', prompt=>'Schema name of photography database', type=>'text'});
$inidata{'database'}{'user'} = &prompt({default=>'photodb', prompt=>'Username with access to the schema', type=>'text'});
$inidata{'database'}{'pass'} = &prompt({default=>'', prompt=>'Password for this user', type=>'text'});
$inidata{'filesystem'}{'basepath'} = &prompt({default=>'', prompt=>'Path to your scanned images', type=>'text'});
WriteINI($inifile, \%inidata)
or die "Could not write to ini file at $inifile\n";
return;
}
=head2 round
Round a number to any precision
=head4 Usage
my $rounded = &round($num, 3);
=head4 Arguments
=item * C<$num> Number to round
=item * C<$pow10> Number of decimal places to round to. Defaults to C<0> i.e. round to an integer
=head4 Returns
Rounded number
=cut
sub round {
my $x = shift; # Number to round
my $pow10 = shift || 0; # Number of decimal places to round to
my $a = 10 ** $pow10;
return int(($x * $a) + 0.5) / $a
}
=head2 pad
Pad a string with spaces up to a fixed length, to make it easier to print fixed-width tables
=head4 Usage
my $paddedstring = &pad('Hello', 8);
=head4 Arguments
lib/App/PhotoDB/funcs.pm view on Meta::CPAN
=head2 choosescan
Select a scan by specifying a filename. Allows user to pick if there are multiple matching filenames.
=head4 Usage
my $id = &choosescan({db=>$db});
=head4 Arguments
=item * C<$db> variable containing database handle as returned by C<&db>
=head4 Returns
Integer representing the scan ID
=cut
sub choosescan {
my $href = shift;
my $db = $href->{db};
# prompt user for filename of scan
my $filename = &prompt({prompt=>'Please enter the filename of the scan', type=>'text'});
# should be unique if filename is X-Y-img1234.jpg, otherwise they can choose
return &listchoices({db=>$db, table=>'choose_scan', where=>{'filename'=>$filename}, type=>'text'});
}
=head2 basepath
Returns filesystem basepath which contains scans
=head4 Usage
my $basepath = &basepath;
=head4 Arguments
None
=head4 Returns
Path to directory which contains scans
=cut
sub basepath {
# Work out file path
my $connect = ReadINI(&ini);
if (!defined($$connect{'filesystem'}{'basepath'})) {
die "Config file did not contain basepath";
}
my $basepath = $$connect{'filesystem'}{'basepath'};
# Strip off trailing slash
$basepath =~ s/\/$//;
return $basepath;
}
# Untaint input
=head2 untaint
Untaint a tainted value
=head4 Usage
my $untainted = &untaint($tainted);
=head4 Arguments
=item * C<$tainted> Tainted value to untaint
=head4 Returns
Returns the untained string
=cut
sub untaint {
my $input = shift;
$input =~ m/^(.*)$/;
my $output = $1;
return $output;
}
=head2 fsfiles
List all scan files on the filesystem
=head4 Usage
my @scansondisk = &fsfiles;
=head4 Arguments
None
=head4 Returns
Array of file paths of scans found on the filesystem
=cut
sub fsfiles {
# Search filesystem basepath to enumerate all *.jpg
my $basepath = &basepath;
my $rule = Path::Iterator::Rule->new;
$rule->iname( '*.jpg' );
my @fsfiles = $rule->all($basepath);
# Filter out empty elements
@fsfiles = grep {$_} @fsfiles;
return @fsfiles;
}
=head2 dbfiles
List all scan files in the database
=head4 Usage
my @scansindb = &dbfiles;
=head4 Arguments
=item * C<$db> database handle
=head4 Returns
Array of file paths of scans recorded in the database
=cut
sub dbfiles {
my $href = shift;
my $db = $href->{db};
my $basepath = &basepath;
# Query DB to find all known scans
( run in 2.202 seconds using v1.01-cache-2.11-cpan-22024b96cdf )