view release on metacpan or  search on metacpan

script/sitelen-mute  view on Meta::CPAN

sub is_a_gallery {
    my ($d) = @_;
    return unless -e catfile($d, 'data.json');
    return 1;
}

sub read_json {
  my($f) = @_;
  my $j = read_binary($f);
  fatal "Failed to read $f" unless $j;
  my $h = decode_json($j);
  fatal "Failed to parse $f"
    unless $h && ref $h eq 'HASH';
  fatal "Failed to parse $f: missing data"
    unless exists $h->{data};
  fatal "Failed to parse $f: data not an array"
    unless ref $h->{data} eq 'ARRAY';
  return $h;
}

sub write_json {
  my ($f, $jh, $ja) = @_;
  die "USAGE: write_json FILENAME HREF AREF"
    unless (@_ == 3) && (ref $jh eq 'HASH') && (ref $ja eq 'ARRAY');
  my $j = {};
  for (qw(thumb blur)) {
    $j->{$_} = $jh->{$_} if exists $jh->{$_};
  }
  $j->{data} = [ sort { $a->{stamp} <=> $b->{stamp} } @{$jh->{data}}, @$ja ];
  $j->{version} = $VERSION;
  $j->{timestamp} = time();
  $j->{timecreated} = sprintf "%s", scalar localtime $j->{timestamp};
  $j->{name} = $name if $name;
  $j->{download} = $fdownload if $zipfile && -f $zipfile;
  $j->{index} = $indexUrl if $indexUrl;
  write_binary($f, encode_json($j));
  say "Wrote new $f";
  return $f;
}

sub pmin {
  my ($m, $v) = @_;
  return 0 if $v < 0;
  return min($m, $v);
}

# normalise and trim whitespace in captions
sub cap_clean {
  my ($x) = @_;
  return '' unless $x;
  $x =~ s{\s+}{ }g;
  $x =~ s{^\s+|\s+$}{}g;
  return $x;
}

# extracting title and description from a string containing newlines
sub cap_from_str {
  my ($title, $desc) = @_;
  return unless $title;
  ($title, $desc) = split m{\n+}, $title unless $desc;
  return [cap_clean($title), cap_clean($desc)];
}

# extracting title and description from a properties hash reference
sub cap_from_props {
  my ($props) = @_;
  my $ret = ['', ''];
  if ($props->{Title}) {
    my $title = decode_utf8($props->{Title});
    $ret->[0] = cap_clean($title);
  }
  if ($props->{Description}) {
    my $desc = decode_utf8($props->{Description});
    $ret->[1] = cap_clean($desc);
  }
  return $ret;
}

# option parsing: width and height
sub parse_wh {
  my ($opt, $spec) = @_;
  my ($w, $h) = ($spec =~ m{^(\d+)x(\d+)$}o);
  unless(defined($w) && $w > 0 && defined($h) && $h > 0) {
    fatal "bad WxH specification in option $opt";
  }
  return (int($w), int($h));
}

# option parsing: integers
sub parse_int {
  my ($opt, $value, $min, $max) = @_;
  if ((defined($min) && $value < $min) || (defined($max) && $value > $max)) {
    fatal "bad value for option $opt";
  }
  return int($value);
}

sub parse_captions {
  my ($o, $v) = @_;
  return [] if $v eq 'none';
  my @cm = split(m{\s*,\s*}, $v);
  for my $m (@cm) {
    fatal "'$m' not a caption method; use one of "
          . join ', ', sort keys %captions
      unless exists $captions{$m};
  }
  return \@cm;
}

sub parse_copy_method {
  my ($o, $v) = @_;
  $v = $copy_method unless $v;
  fatal "'$v' not a copy method; use one of "
        . join ', ', sort keys %copy_method
    unless exists $copy_method{$v};
  return $v;
}

# given a directory return an aref of files with .$ext in that directory
sub current_imgs {

script/sitelen-mute  view on Meta::CPAN

  my ($i, @result);
  for (@_) {
    print $p->report("\rImage file processing %20b ETA: %E", $i++);
    push(@result, process_image($_));
  }
  say $p->report("\rImage file processing %20b done       ", $i);
  return \@result;
}

sub process_image {
  my %props = %{$_[0]};
  my $root = $props{root};
  my $suffix = $props{suffix};
  my $file = $props{file};

  # derived file names
  my $ofile = (splitpath($file))[2];
  my $ffile = catfile('files', "$root.$suffix");
  my $fbase = "$root.$ext";
  my $fimg = catfile('imgs', $fbase);
  my $fthumb = catfile('thumbs', $fbase);
  my $fblur = catfile('blurs', $fbase);

  my $absFout = catfile($absOut, $ffile);
  my $absFtmp = catfile($absOut, "$ffile.tmp");

  # copy source image, apply tranforms, set mode and file timestamp
  copy_source_file($file, $absFout);
  unless ($use_orig) {
    if ($orient && $props{FileType} eq "JPEG" && ($props{Orientation} // 0)) {
      sys("$exiftrancmd '$absFout' 2>/dev/null");
      if (($props{Orientation} // 0) > 4) {
        ($props{ImageWidth}, $props{ImageHeight})
          = ($props{ImageHeight}, $props{ImageWidth});
      }
    }
    if ($jpegoptim && $props{FileType} eq "JPEG") {
      sys('jpegoptim', '-q', $absFout);
    } elsif ($pngoptim && $props{FileType} eq "PNG") {
      sys('pngcrush', '-s', $absFout, $absFtmp);
      rename($absFtmp, $absFout);
    }
  }
  chmod($filemode, $absFout);
  sys('touch', '-r', $file, $absFout);

  # intermediate sRGB colorspace conversion
  if ( !$sRGB || !defined($props{ProfileID})
              || ($props{ColorSpace} // 65535) == 1
              || ($props{DeviceModel} // '') eq 'sRGB') {
    $absFtmp = $absFout;
  } else {
    sys('convert', '-quiet', $absFout, '-compress', 'LZW',
                   '-type', 'truecolor', "tiff:$absFtmp");
    sys($tificccmd, '-t0', $absFtmp, "$absFtmp.tmp");
    rename("$absFtmp.tmp", $absFtmp);
  }

  # generate main image
  my @sfile = ($props{ImageWidth}, $props{ImageHeight});
  my @simg = split m{\n+}, sys('convert', '-quiet', $absFtmp,
                 '-gamma', '0.454545',
                 '-geometry', "$maxfull[0]x$maxfull[1]>",
                 '-print', '%w\n%h',
                 '-gamma', '2.2',
                 '+profile', '!icc,*',
                 '-quality', $imgq, catfile($absOut, $fimg)
             );

  # face/center detection
  my @center = (0.5, 0.5);
  if ($facedet) {
    my @f = split m{\n+}, sys("facedetect", "--best", "--center", catfile($absOut, $fimg));
    for (@f) {
      if (my @tmp = /(\d+) (\d+) (\d+) (\d+)/) {
	@center = ($tmp[0] / $simg[0], $tmp[1] / $simg[1]);
	last;
      }
    }
  }

  # thumbnail size
  my $thumbrt;
  if ($sfile[0] / $sfile[1] < $minthumb[0] / $minthumb[1]) {
    $thumbrt = $minthumb[0] / $sfile[0];
  } else {
    $thumbrt = $minthumb[1] / $sfile[1];
  }
  my @sthumb = (max(int($sfile[0] * $thumbrt + 0.5), $minthumb[0]),
                max(int($sfile[1] * $thumbrt + 0.5), $minthumb[1]));
  my @mthumb = (min($maxthumb[0], $sthumb[0]),
                min($maxthumb[1], $sthumb[1]));

  # cropping window
  my $dx = $sthumb[0] - $mthumb[0];
  my $cx = pmin($dx, int($center[0] * $sthumb[0] - $sthumb[0] / 2 + $dx / 2));
  my $dy = $sthumb[1] - $mthumb[1];
  my $cy = pmin($dy, int($center[1] * $sthumb[1] - $sthumb[1] / 2 + $dy / 2));

  sys('convert', '-quiet', $absFtmp,
      '-gamma', '0.454545',
      '-resize', "$sthumb[0]x$sthumb[1]!",
      '-gravity', 'NorthWest',
      '-crop', "$mthumb[0]x$mthumb[1]+$cx+$cy",
      '-gamma', '2.2',
      '+profile', '!icc,*',
      '-quality', $imgq, catfile($absOut, $fthumb)
  );

  # blur
  sys('convert', '-quiet', catfile($absOut, $fthumb),
      '-virtual-pixel', 'Mirror',
      '-gaussian-blur', "0x$backblur",
      '-scale', "$backsize[0]x$backsize[1]",
      '-quality', '90', catfile($absOut, $fblur)
   ) if $do_blur;

  # checksum
  $sha->addfile($file);
  my $digest = $sha->hexdigest();
  $sha->reset();

  my %fdata;
  $fdata{props} = \%props;
  $fdata{img} = [$fimg, [map { int } @simg]];
  $fdata{file} = [$ffile, [map { int } @sfile]];
  $fdata{blur} = $fblur if $do_blur;
  $fdata{original} = $ofile;
  $fdata{$alg} = $digest;

  # avoid storing duplicate information
  my @tdata = ($fthumb, [map { int } @mthumb]);
  if ($sthumb[0] != $mthumb[0] || $sthumb[1] != $mthumb[1]) {