lib/UCW/Gallery.pm

   1 # Simple Photo Gallery
   2 # (c) 2003--2015 Martin Mares <mj@ucw.cz>
   3
   4 package UCW::Gallery;
   5
   6 use strict;
   7 use warnings;
   8
   9 use File::Spec;
  10 use Storable;
  11
  12 ### Class methods ###
  13
  14 sub new($) {
  15         my ($class) = @_;
  16         my $self = { };
  17         $self->{cfg} = {
  18                 # Directories
  19                 OrigDir => '.',                 # Original images
  20                 PhotoDir => 'photo',            # Scaled-down photos for web
  21                 CacheDir => 'cache',            # Cache with meta-data and thumbnails
  22
  23                 # URL prefixes
  24                 PhotoUrlPrefix => 'photo/',
  25                 ThumbUrlPrefix => 'thumb/',
  26                 ThemeUrlPrefix => 'gal/',
  27
  28                 # Processing machinery settings
  29                 ScanDefaultTransform => 's',
  30                 PhotoMaxWidth => 1024,
  31                 PhotoMaxHeight => 1024,
  32                 ThumbFormats => [ "114x94" ],   # Built-in themes use the first size,
  33                                                 # but more can be generated
  34                 CacheExif => 0,                 # Cache selected EXIF meta-data
  35                 CacheHashes => 1,               # Let gal-scan cache file hashes
  36
  37                 # Titles and navigation
  38                 Title => 'An Unnamed Gallery',
  39                 SubTitle => "",
  40                 ParentURL => '../',
  41                 BackURL => "",
  42                 FwdURL => "",
  43
  44                 # Hacks
  45                 GeoHack => 0,
  46         };
  47         return bless $self, $class;
  48 }
  49
  50 sub load_config($) {
  51         my $cfg = "./gallery.cf";
  52         my $self = do $cfg;
  53         unless (defined $self) {
  54                 if ($@) {
  55                         die "Error parsing $cfg: $@";
  56                 } elsif ($!) {
  57                         die "Cannot load $cfg: $!\n";
  58                 } else {
  59                         die "Cannot load $cfg, check that it returns true\n";
  60                 }
  61         }
  62         return $self;
  63 }
  64
  65 ### Object methods ###
  66
  67 sub get($$) {
  68         my ($self, $key) = @_;
  69         if (exists $self->{cfg}->{$key}) {
  70                 my $val = $self->{cfg}->{$key};
  71                 defined $val or warn "Gallery: Config item $key is not set\n";
  72                 return $val;
  73         } else {
  74                 warn "Gallery: Config item $key does not exist\n";
  75                 return;
  76         }
  77 }
  78
  79 sub try_get($$) {
  80         my ($self, $key) = @_;
  81         return $self->{cfg}->{$key};
  82 }
  83
  84 sub def($@) {
  85         my $self = shift;
  86         while (my $key = shift @_) {
  87                 my $val = shift @_;
  88                 $self->{cfg}->{$key} //= $val;
  89         }
  90 }
  91
  92 sub set($@) {
  93         my $self = shift;
  94         while (my $key = shift @_) {
  95                 $self->{cfg}->{$key} = shift @_;
  96         }
  97 }
  98
  99 sub get_config_keys($) {
 100         my ($self) = @_;
 101         return keys %{$self->{cfg}};
 102 }
 103
 104 our %list_attrs = (
 105         'file' => 0,            # 0 = not permitted as extended attribute
 106         'id' => 0,
 107         'orientation' => 1,     # 1 = aliases for normal attributes
 108         'title' => 1,
 109         'xf' => 2,              # 2 = ... and propagated to gal-gen
 110         'lat' => 3,             # 3 = normal extended attributes, propagated to gal-gen
 111         'lon' => 3,
 112         'alt' => 3,
 113         't' => 3,
 114 );
 115
 116 sub write_list($$$) {
 117         my ($self, $file, $images) = @_;
 118         open my $fh, '>:utf8', "$file.new" or die "Cannot create $file.new: $!\n";
 119         for my $i (@$images) {
 120                 print $fh join("\t",
 121                         $i->{file},
 122                         $i->{id},
 123                         $i->{orientation},
 124                         $i->{xf},
 125                         ($i->{title} eq '' ? '-' : $i->{title}),
 126                 ), "\n";
 127                 for my $k (keys %$i) {
 128                         print $fh "\t$k=", $i->{$k}, "\n" if $list_attrs{$k} >= 3;
 129                 }
 130         }
 131         close $fh;
 132         rename "$file.new", $file or die "Cannot rename $file.new to $file: $!\n";
 133 }
 134
 135 sub read_list_fh($$) {
 136         my ($self, $fh) = @_;
 137         my @images = ();
 138         while (<$fh>) {
 139                 chomp;
 140                 /^$/ and next;
 141                 /^#/ and next;
 142                 if (/^\t/) {
 143                         @images or die "Misplaced continuation line before first image\n";
 144                         if (my ($k, $v) = /^\t+(.*?)=(.*)/) {
 145                                 # Continutation of previous line
 146                                 my $i = $images[-1];
 147                                 if ($list_attrs{$k}) {
 148                                         $i->{$k} = $v;
 149                                 } else {
 150                                         print STDERR "Ignoring unknown attribute $k for ", $i->{file}, "\n";
 151                                 }
 152                         } else {
 153                                 die "Invalid continuation line. Expecting 'key=value'.\n";
 154                         }
 155                 } else {
 156                         my $i = {};
 157                         ($i->{file}, $i->{id}, $i->{orientation}, $i->{xf}, $i->{title}) = split /\t/;
 158                         if (!defined $i->{title} || $i->{title} eq '-') { $i->{title} = ""; }
 159                         push @images, $i;
 160                 }
 161         }
 162         return \@images;
 163 }
 164
 165 sub read_list($$) {
 166         my ($self, $file) = @_;
 167         open my $fh, '<:utf8', $file or return;
 168         my $list = $self->read_list_fh($fh);
 169         close $fh;
 170         return $list;
 171 }
 172
 173 sub write_meta($$) {
 174         my ($self, $file, $meta) = @_;
 175         open my $fh, '>', "$file.new" or die "Cannot create $file.new: $!\n";
 176         Storable::nstore_fd($meta, $fh);
 177         close $fh;
 178         rename "$file.new", $file or die "Cannot rename $file.new to $file: $!\n";
 179 }
 180
 181 sub read_meta($) {
 182         my ($self, $file) = @_;
 183         open my $fh, '<', $file or die "Cannot read $file: $!\n";
 184         my $meta = Storable::fd_retrieve($fh) or die "Cannot parse $file\n";
 185         close $fh;
 186         return $meta;
 187 }
 188
 189 sub photo_meta_name($) {
 190         my ($self) = @_;
 191         return File::Spec->catfile($self->get('PhotoDir'), 'gallery.meta');
 192 }
 193
 194 sub cache_meta_name($) {
 195         my ($self) = @_;
 196         return File::Spec->catfile($self->get('CacheDir'), 'cache.meta');
 197 }
 198
 199 sub thumb_fmt_to_size($$) {
 200         my ($self, $fmt) = @_;
 201         my ($tw, $th) = ($fmt =~ m{^(\d+)x(\d+)$}) or die "Cannot parse thumbnail format $fmt\n";
 202         return ($tw, $th);
 203 }
 204
 205 sub photo_file_name($$$) {
 206         my ($self, $photo_meta, $id) = @_;
 207         return $id . '.' . ($photo_meta->{fmt} // 'jpg');
 208 }
 209
 210 sub photo_name($$$) {
 211         my ($self, $photo_meta, $id) = @_;
 212         return File::Spec->catfile($self->get('PhotoDir'), $self->photo_file_name($photo_meta, $id));
 213 }
 214
 215
 216 1;