view release on metacpan or  search on metacpan

lib/App/PhotoDB/handlers.pm  view on Meta::CPAN

sub camera_addbodytype {
	my $href = shift;
	my $db = $href->{db};
	my %data;
	$data{body_type} = $href->{body_type} // &prompt({prompt=>'Enter new camera body type'});
	return &newrecord({db=>$db, data=>\%data, table=>'BODY_TYPE'});
}

# Add a new series of camera/lens models
sub series_add {
	my $href = shift;
	my $db = $href->{db};
	my %data;
	$data{name} = $href->{name} // &prompt({prompt=>'What is the name of this series?'});
	return &newrecord({db=>$db, data=>\%data, table=>'SERIES'});
}

# Print info about a series
sub series_info {
	my $href = shift;
	my $db = $href->{db};
	my $series_id = $href->{series_id} // &listchoices({db=>$db, cols=>['series_id as id', 'name as opt'], table=>'SERIES', required=>1});
	my $seriesname = &lookupval({db=>$db, col=>'name', table=>'SERIES', where=>{series_id=>$series_id}});
	my $total = &printlist({db=>$db, msg=>"camera and lens models in series '$seriesname'", table=>'info_series', cols=>["Got as id", 'Model as opt'], where=>{'`Series ID`'=>$series_id}});
	my $got = &lookupval({db=>$db, col=>'count(*)', table=>'info_series', where=>{'`Series ID`'=>$series_id, Got=>'✓'}});

	if ($total > 0) {
		my $need = $total - $got;
		my $percentcomplete = round(100 * $got/$total);
		print "Series '$seriesname' is $percentcomplete% complete (got $got, need $need)\n";
	}
	return;
}

# Summarise all series
sub series_list {
	my $href = shift;
	my $db = $href->{db};
	my $rows = &tabulate({db=>$db, view=>'summary_series'});
	return $rows;
}

# List all models we need
sub series_need {
	my $href = shift;
	my $db = $href->{db};
	my $rows = &printlist({db=>$db, msg=>'models needed to complete series', cols=>["'' as id", 'Model as opt'], table=>'info_series', where=>{'Got'=>'✗'}});
	return $rows;
}

# Add a new physical archive for prints or films
sub archive_add {
	my $href = shift;
	my $db = $href->{db};
	my %data;
	$data{archive_type_id} = $href->{archive_type_id} // &listchoices({db=>$db, cols=>['archive_type_id as id', 'archive_type as opt'], table=>'ARCHIVE_TYPE'});
	$data{name} = $href->{name} // &prompt({prompt=>'What is the name of this archive?'});
	$data{max_width} = $href->{max_width} // &prompt({prompt=>'What is the maximum width of media that this archive can accept (if applicable)?'});
	$data{max_height} = $href->{max_height} // &prompt({prompt=>'What is the maximum height of media that this archive can accept (if applicable)?'});
	$data{location} = $href->{location} // &prompt({prompt=>'What is the location of this archive?'});
	$data{storage} = $href->{storage} // &prompt({prompt=>'What is the storage type of this archive? (e.g. box, folder, ringbinder, etc)'});
	$data{sealed} = $href->{sealed} // &prompt({default=>'no', prompt=>'Is this archive sealed (closed to new additions)?', type=>'boolean'});
	return &newrecord({db=>$db, data=>\%data, table=>'ARCHIVE'});
}

# Bulk-add multiple films to an archive
sub archive_films {
	my $href = shift;
	my $db = $href->{db};
	my %data;
	my $minfilm = $href->{minfilm} // &prompt({prompt=>'What is the lowest film ID in the range?', type=>'integer'});
	my $maxfilm = $href->{maxfilm} // &prompt({prompt=>'What is the highest film ID in the range?', type=>'integer'});
	if (($minfilm =~ m/^\d+$/) && ($maxfilm =~ m/^\d+$/)) {
		if ($maxfilm le $minfilm) {
			print "Highest film ID must be higher than lowest film ID\n";
			return;
		}
	} else {
		print "Must provide highest and lowest film IDs\n";
		return;
	}
	$data{archive_id} = $href->{archive_id} // &listchoices({db=>$db, cols=>['archive_id as id', 'name as opt'], table=>'ARCHIVE', where=>'archive_type_id in (1,2) and sealed = 0', inserthandler=>\&archive_add});
	return &updaterecord({db=>$db, data=>\%data, table=>'FILM', where=>"film_id >= $minfilm and film_id <= $maxfilm and archive_id is null"});
}

# Display info about an archive
sub archive_info {
	my $href = shift;
	my $db = $href->{db};
	my $archive_id = $href->{archive_id} // &listchoices({db=>$db, cols=>['archive_id as id', 'name as opt'], table=>'ARCHIVE', required=>1});
	print Dump(&lookupcol({db=>$db, table=>'info_archive', where=>{'`Archive ID`'=>$archive_id}}));
	return;
}

# List the contents of an archive
sub archive_list {
	my $href = shift;
	my $db = $href->{db};
	my $archive_id = $href->{archive_id} // &listchoices({db=>$db, cols=>['archive_id as id', 'name as opt'], table=>'ARCHIVE', required=>1});
	my $archive_name = &lookupval({db=>$db, col=>'name', table=>'ARCHIVE', where=>{archive_id=>$archive_id}});
	&printlist({db=>$db, msg=>"items in archive $archive_name", table=>'archive_contents', where=>{archive_id=>$archive_id}});
	return;
}

# Seal an archive and prevent new items from being added to it
sub archive_seal {
	my $href = shift;
	my $db = $href->{db};
	my %data;
	my $archive_id = $href->{archive_id} // &listchoices({db=>$db, cols=>['archive_id as id', 'name as opt'], table=>'ARCHIVE', where=>{sealed=>0}, required=>1});
	$data{sealed} = 1;
	return &updaterecord({db=>$db, data=>\%data, table=>'ARCHIVE', where=>{archive_id=>$archive_id}});
}

# Unseal an archive and allow new items to be added to it
sub archive_unseal {
	my $href = shift;
	my $db = $href->{db};
	my %data;
	my $archive_id = $href->{archive_id} // &listchoices({db=>$db, cols=>['archive_id as id', 'name as opt'], table=>'ARCHIVE', where=>{sealed=>1}, required=>1});
	$data{sealed} = 0;

lib/App/PhotoDB/handlers.pm  view on Meta::CPAN

				# Test to see if this is from a print, e.g. P232-image012.jpg
				} elsif ($filename =~ m/^p(rint)?(\d+).*\.jpg$/i) {
					my $print_id = $2;
					if ($auto || &prompt({prompt=>"This looks like a scan of print #$print_id. Add it?", type=>'boolean', default=>'yes', required=>1})) {
						&newrecord({db=>$db, data=>{print_id=>$print_id, filename=>$filename}, table=>'SCAN', silent=>$auto});
						print "Added $filename as scan of print #$print_id\n" if $auto;
						$x++;
					}
				} else {
					next if $auto;
					if (&prompt({prompt=>"Can't automatically determine the source of this scan. Add it manually?", type=>'boolean', default=>'yes', required=>1})) {
						&scan_add({db=>$db, filename=>$filename});
					}
				}
			}
		}
		my $stillfsonly = $numfsonly - $x;
		print "Added $x scans to the database. There are $stillfsonly scans on the filesystem but not in the database.\n";
	} else {
		print "All scans on the filesystem are already in the database\n";
	}

	# Re-search filesystem basepath & DB in case it was updated above
	@fsfiles = &fsfiles;
	@dbfiles = &dbfiles({db=>$db});

	# Find scans only in the database
	my @dbonly = array_minus(@dbfiles, @fsfiles);
	my $numdbonly = scalar @dbonly;

	# Scans only in the db
	if ($numdbonly>0 && &prompt({prompt=>"Audit $numdbonly scans that exist only in the database and not on the filesystem?", type=>'boolean', default=>'no', required=>1})) {
		my $x = 0;
		for my $dbonlyfile (@dbonly) {
			if (&prompt({prompt=>"Delete $dbonlyfile from the database?", type=>'boolean', default=>'no', required=>1})) {
				my $filename = fileparse($dbonlyfile);
				&deleterecord({db=>$db, table=>'SCAN', where=>{filename=>$filename}, silent=>1});
				$x++;
			}
		}
		my $stilldbonly = $numdbonly - $x;
		print "Deleted $x scans from the database. There are $stilldbonly scans in the database but not on the filesystem.\n";
	} else {
		print "All scans in the database exist on the filesystem\n";
	}
	return;
}

# Rename scans to include their caption in the filename
sub scan_rename {
	# Read in cmdline args
	my $href = shift;
	my $db = $href->{db};
	my $film_id = $href->{film_id} // &film_choose({db=>$db});

	# Make sure basepath is valid
	my $basepath = &basepath;

	# Find matching scans
	my $sql = SQL::Abstract->new;
	my($stmt, @bind) = $sql->select('scans_negs', '*', {film_id=>$film_id});
	my $sth = $db->prepare($stmt) or die "Couldn't prepare statement: " . $db->errstr;
	my $rows = $sth->execute(@bind);
	$rows = &unsci($rows);
	return if ($rows == 0);

	# Loop through our result set
	while (my $ref = $sth->fetchrow_hashref()) {
		# First check the path is defined in MySQL
		if (defined($ref->{'filename'})) {
			# Now make sure the path actually exists on the system
			if (-e "$basepath/$ref->{'directory'}/$ref->{'filename'}") {

				# Sanitise description with fs-safe chars
				my $safedesc = $ref->{'description'};
				$safedesc =~ s/[^a-zA-Z0-9-_ ]//g;

				# Generate theoretical new filename
				my $newname;
				if ($ref->{'print_id'}) {
					# For prints
					$newname = "P$ref->{print_id}-$safedesc.jpg";
				} else {
					# For negatives
					$newname = "$ref->{film_id}-$ref->{frame}-$safedesc.jpg";
				}

				# Check if a change is needed
				if ($ref->{'filename'} ne $newname) {
					print "\t$ref->{'filename'} => $newname\n";

					# Move file on fs
					rename(&untaint("$basepath/$ref->{'directory'}/$ref->{'filename'}"), &untaint("$basepath/$ref->{'directory'}/$newname"));

					# Update scan in db
					&updaterecord({db=>$db, data=>{filename=>$newname}, table=>'SCAN', where=>{scan_id=>$ref->{scan_id}}, silent=>1});
				}
			}
		}
	}
	return $rows;
}

# This ensures the lib loads smoothly
1;