code/SystemTag/image.tag

   1 # Copyright 2002-2011 Interchange Development Group and others
   2 #
   3 # This program is free software; you can redistribute it and/or modify
   4 # it under the terms of the GNU General Public License as published by
   5 # the Free Software Foundation; either version 2 of the License, or
   6 # (at your option) any later version.  See the LICENSE file for details.
   7
   8 UserTag image Order     src
   9 UserTag image AttrAlias geometry makesize
  10 UserTag image AttrAlias resize makesize
  11 UserTag image AddAttr
  12 UserTag image Version   1.25
  13 UserTag image Routine   <<EOR
  14 sub {
  15         my ($src, $opt) = @_;
  16         my ($image, $path, $secure, $sku);
  17         my ($imagedircurrent, $imagedir, $imagedirsecure);
  18
  19         my @descriptionfields = grep /\S/, split /\s+/,
  20                 $opt->{descriptionfields} || $::Variable->{DESCRIPTIONFIELDS} || $Vend::Cfg->{DescriptionField};
  21         @descriptionfields = qw( description ) if ! @descriptionfields;
  22
  23         my @imagefields = grep /\S/, split /\s+/,
  24                 $opt->{imagefields} || $::Variable->{IMAGEFIELDS};
  25         @imagefields = qw( image ) if ! @imagefields;
  26
  27         my @imagesuffixes = qw( jpg gif png jpeg );
  28         my $filere = qr/\.\w{2,4}$/;
  29         my $absurlre = qr!^(?i:https?)://!;
  30
  31         if ($opt->{ui}) {
  32                 # unless no image dir specified, add locale string
  33                 my $locale = $Scratch->{mv_locale} ? $Scratch->{mv_locale} : 'en_US';
  34                 $imagedir               = $::Variable->{UI_IMAGE_DIR}
  35                                                 || $Global::Variable->{UI_IMAGE_DIR};
  36                 $imagedirsecure = $::Variable->{UI_IMAGE_DIR}
  37                                                 || $Global::Variable->{UI_IMAGE_DIR};
  38                 for ($imagedir, $imagedirsecure) {
  39                         if ($_) {
  40                                 $_ .= '/' if substr($_, -1, 1) ne '/';
  41                                 $_ .= $locale . '/';
  42                         }
  43                 }
  44         } else {
  45                 $imagedir               = $Vend::Cfg->{ImageDir};
  46                 $imagedirsecure = $Vend::Cfg->{ImageDirSecure} || $imagedir ;
  47         }
  48
  49         # make sure there's a trailing slash on directories
  50         for ($imagedir, $imagedirsecure) {
  51                 $_ .= '/' if $_ and substr($_, -1, 1) ne '/';
  52         }
  53
  54         if (defined $opt->{secure}) {
  55                 $secure = $opt->{secure} ? 1 : 0;
  56         } else {
  57                 $secure = $CGI::secure;
  58         }
  59
  60         $imagedircurrent = $secure ? $imagedirsecure : $imagedir;
  61
  62         return $imagedircurrent if $opt->{dir_only};
  63
  64         $opt->{getsize} = 1 unless defined $opt->{getsize}
  65                 or (defined($opt->{height}) and defined($opt->{width}));
  66         $opt->{imagesubdir} ||= $::Scratch->{mv_imagesubdir}
  67                 if defined $::Scratch->{mv_imagesubdir};
  68         $opt->{default} ||= $::Scratch->{mv_imagedefault}
  69                 if defined $::Scratch->{mv_imagedefault};
  70
  71         if ($opt->{sku}) {
  72                 $sku = $opt->{sku};
  73         } else {
  74                 # assume src option is a sku if it doesn't look like a filename
  75                 if ($src !~ /$filere/) {
  76                         $sku = $src;
  77                         undef $src;
  78                 }
  79         }
  80
  81         if($opt->{name_only} and $src) {
  82                 my $ret = $src =~ /$absurlre/ ? $src : "$imagedircurrent$src";
  83                 $ret =~ s/%(?!25)/%25/g;
  84                 return $ret;
  85         }
  86
  87         if ($src =~ /$absurlre/) {
  88                 # we have no way to check validity or create/read sizes of full URLs,
  89                 # so we just assume they're good
  90                 $image = $src;
  91         } else {
  92
  93                 my @srclist;
  94                 push @srclist, $src if $src;
  95                 if ($sku) {
  96                         # check all products tables for image fields
  97                         for ( @{$Vend::Cfg->{ProductFiles}} ) {
  98                                 my $db = Vend::Data::database_exists_ref($_)
  99                                         or die "Bad database $_?";
 100                                 $db = $db->ref();
 101                                 my $view = $db->row_hash($sku)
 102                                         if $db->record_exists($sku);
 103                                 if (ref $view eq 'HASH') {
 104                                         for (@imagefields) {
 105                                                 push @srclist, $view->{$_} if $view->{$_};
 106                                         }
 107                                         # grab product description for alt attribute
 108                                         unless (defined $opt->{alt}) {
 109                                                 for (@descriptionfields) {
 110                                                         ($opt->{alt} = $view->{$_}, last)
 111                                                                 if $view->{$_};
 112                                                 }
 113                                         }
 114                                 }
 115                         }
 116                 }
 117                 push @srclist, $sku if $sku;
 118                 push @srclist, $opt->{default} if $opt->{default};
 119
 120                 if ($opt->{imagesubdir}) {
 121                         $opt->{imagesubdir} .= '/' unless $opt->{imagesubdir} =~ m:/$:;
 122                 }
 123                 my $dr = $::Variable->{DOCROOT};
 124                 my $id = $imagedircurrent;
 125                 $id =~ s:/+$::;
 126                 $id =~ s:/~[^/]+::;
 127
 128                 IMAGE_EXISTS:
 129                 for my $try (@srclist) {
 130                         ($image = $try, last) if $try =~ /$absurlre/;
 131                         $try = $opt->{imagesubdir} . $try;
 132                         my @trylist;
 133                         if ($try and $try !~ /$filere/) {
 134                                 @trylist = map { "$try.$_" } @imagesuffixes;
 135                         } else {
 136                                 @trylist = ($try);
 137                         }
 138                         for (@trylist) {
 139                                 if ($id and m{^[^/]}) {
 140                                         if ($opt->{force} or ($dr and -f "$dr$id/$_")) {
 141                                                 $image = $_;
 142                                                 $path = "$dr$id/$_";
 143                                         }
 144                                 } elsif (m{^/}) {
 145                                         if ($opt->{force} or ($dr and -f "$dr/$_")) {
 146                                                 $image = $_;
 147                                                 $path = "$dr/$_";
 148                                         }
 149                                 }
 150                                 last IMAGE_EXISTS if $image;
 151                         }
 152                 }
 153
 154                 return unless $image;
 155                 return 1 if $opt->{exists_only};
 156
 157                 my $mask;
 158
 159                 if($opt->{makesize} and $path) {
 160                         my $dir = $path;
 161                         $dir =~ s:/([^/]+$)::;
 162                         my $fn = $1;
 163                         my $siz = $opt->{makesize};
 164                         MOGIT: {
 165                                 # Support complete mogrify -geometry syntax
 166                                 # This matches: AxB, A or xB, followed by 0, 1, or 2 [+-]number
 167                                 # specs, followed by none or one of @!%><.
 168                                 $siz =~ m{^(()|\d+())(x\d+\3|x\d+\2|\3)([+-]\d+){0,2}([@!%><])?$}
 169                                         or do {
 170                                                 logError("%s: Unable to make image with bad size '%s'", 'image tag', $siz);
 171                                                 last MOGIT;
 172                                         };
 173
 174                                 (my $siz_path = $siz) =~ s:[^\dx]::g;
 175                                 $dir .= "/$siz_path";
 176
 177                                 my $newpath = "$dir/$fn";
 178                                 if(-f $newpath) {
 179                                         if($opt->{check_date}) {
 180                                                 my $mod1 = -M $newpath;
 181                                                 my $mod2 = -M $path;
 182                                                 unless ($mod2 < $mod1) {
 183                                                         $image =~ s:(/?)([^/]+$):$1$siz_path/$2:;
 184                                                         $path = $newpath;
 185                                                         last MOGIT;
 186                                                 }
 187                                         }
 188                                         else {
 189                                                 $image =~ s:(/?)([^/]+$):$1$siz_path/$2:;
 190                                                 $path = $newpath;
 191                                                 last MOGIT;
 192                                         }
 193                                 }
 194
 195                                 $mask = umask(02);
 196
 197                                 unless(-d $dir) {
 198                                         File::Path::mkpath($dir);
 199                                 }
 200
 201                                 my $mgkpath = $newpath;
 202                                 my $ext;
 203                                 $mgkpath =~ s/\.(\w+)$/.mgk/
 204                                         and $ext = $1;
 205
 206                                 File::Copy::copy($path, $newpath)
 207                                         or do {
 208                                                 logError("%s: Unable to create image '%s'", 'image tag', $newpath);
 209                                                 last MOGIT;
 210                                         };
 211                                 my $exec = $Global::Variable->{IMAGE_MOGRIFY};
 212                                 if(! $exec) {
 213                                         my @dirs = split /:/, "/usr/X11R6/bin:$ENV{PATH}";
 214                                         for(@dirs) {
 215                                                 next unless -x "$_/mogrify";
 216                                                  $exec = "$_/mogrify";
 217                                                  $Global::Variable->{IMAGE_MOGRIFY} = $exec;
 218                                                 last;
 219                                         }
 220                                 }
 221                                 last MOGIT unless $exec;
 222                                 system qq{$exec -geometry "$siz" '$newpath'};
 223                                 if($?) {
 224                                         logError("%s: Unable to mogrify image '%s'", 'image tag', $newpath);
 225                                         last MOGIT;
 226                                 }
 227
 228                                 if(-f $mgkpath) {
 229                                         rename $mgkpath, $newpath
 230                                                 or die "Could not overwrite image with new one!";
 231                                 }
 232                                 $image =~ s:(/?)([^/]+$):$1$siz_path/$2:;
 233                                 $path = $newpath;
 234                         }
 235                 }
 236
 237                 umask($mask) if defined $mask;
 238
 239                 if ($opt->{getsize} and $path) {
 240                         eval {
 241                                 require Image::Size;
 242                                 my ($width, $height) = Image::Size::imgsize($path);
 243                                 $opt->{height} = $height
 244                                         if defined($height) and not exists($opt->{height});
 245                                 $opt->{width} = $width
 246                                         if defined($width) and not exists($opt->{width});
 247                                 if ($opt->{size_scratch_prefix}) {
 248                                         Vend::Interpolate::set_tmp($opt->{size_scratch_prefix} . '_' . $_, $opt->{$_})
 249                                                 for qw/width height/;
 250                                 }
 251                         };
 252                 }
 253         }
 254
 255         $image = $imagedircurrent . $image unless
 256                 $image =~ /$absurlre/ or substr($image, 0, 1) eq '/';
 257
 258         $image =~ s/%(?!25)/%25/g;
 259         return $image if $opt->{src_only};
 260
 261         $opt->{title} = $opt->{alt} if ! defined $opt->{title} and $opt->{alt};
 262
 263         my $opts = '';
 264         for (qw: width height alt title border hspace vspace align valign style class name id :) {
 265                 if (defined $opt->{$_}) {
 266                         my $val = $opt->{$_};
 267                         $val = HTML::Entities::encode($val) if $val =~ /\W/;
 268                         $opts .= qq{ $_="$val"};
 269                 }
 270         }
 271         if($opt->{extra}) {
 272                 $opts .= " $opt->{extra}";
 273         }
 274         $image =~ s/"/&quot;/g;
 275         return qq{<img src="$image"$opts$Vend::Xtrailer>};
 276 }
 277 EOR
 278