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

    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

=item * C<$string> Text to pad

=item * C<$totallength> Total number of characters to pad to, defaults to C<18>

=head4 Returns

Padded string

=cut

sub pad {
	my $string = shift;		# Text to pad
	my $totallength = shift || 18;	# Total number of characters to pad to

	# Work out required pad
	my $pad = $totallength - length($string);

	if ($pad > 0) {
		# Return the padded string
		return $string . ' ' x $pad;
	} elsif ($pad = 0) {
		# No pad required, just return the original
		return $string;
	} else {
		# If the input is longer than the target, truncate it
		return substr($string, 0, $totallength);
	}
}

=head2 resolvenegid

Get a negative ID either from the neg ID or the film/frame ID

=head4 Usage

    my $negID = &resolvenegid({db=>$db, string=>'10/4'});

=head4 Arguments

=item * C<$db> DB handle

=item * C<$string> String to represent a negative ID, either as an integer or in film/frame format, e.g. C<834> or C<10/4>

=head4 Returns

Integer negative ID

=cut

sub resolvenegid {
	my $href = shift;
	my $db = $href->{db};
	my $string = $href->{string};
	if ($string =~ m/^\d+$/) {
		# All digits - already a NegID
		return $string;
	} elsif ($string =~ m/^(\d+)\/([a-z0-9]+)$/i) {
		# 999/99A - a film/frame ID
		my $film_id = $1;
		my $frame = $2;
		my $neg_id = &lookupval({db=>$db, col=>"lookupneg($film_id, $frame)", table=>'NEGATIVE'});
		return $neg_id;
	} else {
		# Could not resolve
		die "Could not resolve $string to a negative ID\n";
	}
}

=head2 chooseneg

Select a negative by drilling down

=head4 Usage

    my $id = &chooseneg({db=>$db, oktoreturnundef=>$oktoreturnundef});

=head4 Arguments

=item * C<$db> variable containing database handle as returned by C<&db>

=item * C<$oktoreturnundef> optional boolean to specify whether it is OK to fail to find a negative

=head4 Returns

Integer representing the negative ID

=cut

sub chooseneg {
	my $href = shift;
	my $db = $href->{db};
	my $oktoreturnundef = $href->{oktoreturnundef} || 0;

	# Choose a film
	my $film_id = &prompt({default=>'', prompt=>'Enter Film ID', type=>'integer'});

	#  Choose a negative from this film
	my $frame = &listchoices({db=>$db, table=>'NEGATIVE', cols=>'frame as id, description as opt', where=>{film_id=>$film_id}, type=>'text'});
	my $neg_id = &lookupval({db=>$db, col=>"lookupneg($film_id, $frame)", table=>'NEGATIVE'});
	if (defined($neg_id) && $neg_id =~ m/^\d+$/) {
		return $neg_id;
	} elsif ($oktoreturnundef == 1) {
		return;
	} else {
		die "Could not find a negative ID for film $film_id and frame $frame\n";
	}
}

=head2 annotatefilm