tools/mkimgthumb

   1 #!/usr/bin/env perl
   2 use 5.014;
   3 use warnings;
   4 use lib $0 =~ s{[^/]+$}{..}r; # project root
   5 use Shiar_Sheet::ImagePrep '1.03';
   6
   7 our $VERSION = '1.00';
   8
   9 my %opt;
  10
  11 if (@ARGV and $ARGV[0] =~ /^-/) {
  12         require Getopt::Long;
  13         Getopt::Long->import(qw( 2.33 :config gnu_getopt ));
  14         GetOptions(\%opt,
  15                 'jpg=s',
  16                 'webp=s',
  17         ) or exit 64;
  18 }
  19
  20 %opt or %opt = (
  21         jpg  => '300x200',
  22         webp => '630x420@30',
  23 );
  24
  25 my @ffs;
  26 for (keys %opt) {
  27         push @ffs, my $ff = [$_];
  28         my $r = $opt{$_};
  29         push @{$ff}, -quality => $1 if $r =~ s/@(\d+)//;
  30         push @{$ff}, -resize => "$r^", -extent => $r;
  31 }
  32
  33 my $failcount = 0;
  34
  35 for my $src (@ARGV) {
  36         my ($name, @cmds) = split /:(?<!\\:)/, $src =~ s/\.(\w+)\z//r;
  37         my $ext = $1 // '*';
  38         next if $name =~ m/\./;
  39         unless (-e $src) {
  40                 ($src) = grep {-e} glob qq<"$name"{,:*}.$ext> or next;
  41         }
  42         s/\\(.)/$1/g for @cmds;
  43         say $name;
  44
  45         if (@cmds and $cmds[0] =~ /^\d/) {
  46                 # crop shorthand from initial dimension argument
  47                 my @crop = split /\D/, shift @cmds;
  48                 unshift @cmds, -gravity => 'southeast', -chop => "$crop[2]%x$crop[3]%"
  49                         if @crop > 2;
  50                 unshift @cmds, -chop => "$crop[0]%x$crop[1]%";
  51         }
  52         push @cmds, -gravity => 'north';
  53         eval {
  54                 my $image = Shiar_Sheet::ImagePrep->new($src);
  55                 for (@ffs) {
  56                         my ($ff, @ffcmds) = @{$_};
  57                         $image->convert("../$name.$ff", [@cmds, @ffcmds]);
  58                 }
  59                 1;
  60         } or do {
  61                 warn "error creating image:\n";
  62                 warn ref $@ eq 'ARRAY' ? $@->[1] : $@ if $@;
  63                 $failcount++;
  64         };
  65 }
  66
  67 exit $failcount;