#!/usr/bin/perl
### pdfstampid.perl  -*- Perl -*-
## Make PDF files with random UUID/QR Code-based labels.

### Ivan Shmakov, 2013, 2019

## To the extent possible under law, the author(s) have dedicated
## all copyright and related and neighboring rights to this software
## to the public domain worldwide.  This software is distributed
## without any warranty.

## You should have received a copy of the CC0 Public Domain Dedication
## along with this software.  If not, see
## <http://creativecommons.org/publicdomain/zero/1.0/>.

### Code:

use common::sense;
use English qw (-no_match_vars);

require Data::Dump;
require Getopt::Long;
require IO::String;
# require List::Util;
require PDF::API2;

# our ($font_fn)
#     = ("/usr/share/fonts/truetype/dejavu/DejaVuSansMono.ttf");

our $mm_pt
    = (72 / 25.4);
our $pt_mm
    = (1 / $mm_pt);

## FIXME: hardcoded
our @label_size
    = (37.5, 18.75);

### Package: UUID::QRCode

package UUID::QRCode;

require Imager::QRCode;
require MIME::Base64;
require PDF::API2;
require UUID;

our $qr_coder
    = Imager::QRCode->new (qw (version 0  level M),
                           qw (mode 8-bit casesensitive 1));

## FIXME: hardcoded
our ($url_cut)
    = (8);

sub new {
    my ($class, $uuid, @may_be_opts) = @_;
    die ()
        unless (length ($uuid) == 16);
    my $self = {
        (@may_be_opts != 1 ? @may_be_opts
         : "HASH"  eq ref ($may_be_opts[0]) ? %{$may_be_opts[0]}
         : "ARRAY" eq ref ($may_be_opts[0]) ? @{$may_be_opts[0]}
         : ("urn_p" => $may_be_opts[0] // 0)),
        "uuid"  => $uuid
    };
    ## .
    bless ($self, $class);
}

sub raw {
    ## .
    $_[0]->{"uuid"};
}

sub uuid_string {
    my $s;
    UUID::unparse ($_[0]->raw (), $s);
    ## .
    $s;
}

sub urn {
    ## .
    ("urn:uuid:" . $_[0]->uuid_string ());
}

sub url {
    my ($self) = @_;
    our ($url_cut);
    ## .
    (($self->{"url-prefix"} // "")
     . substr (MIME::Base64::encode_base64url ($self->raw ()), 0, $url_cut)
     . ($self->{"url-suffix"} // ""));
}

sub uri {
    my ($self, $urn_p) = @_;
    $urn_p
        //= $self->{"urn_p"}
        //= !  (exists ($self->{"url-prefix"})
                || exists ($self->{"url-suffix"}));
    ## .
    ($urn_p ? $self->urn () : $self->url ());
}

sub qr_imager {
    my ($self, $urn_p) = @_;
    our $qr_coder;
    $urn_p
        //= $self->{"urn_p"}
        //= !  (exists ($self->{"url-prefix"})
                || exists ($self->{"url-suffix"}));
    my $mine
        = ($self->{"imager_" . ($urn_p ? "urn" : "url")}
           //= $qr_coder->plot ($self->uri ($urn_p))->to_paletted (qw (make_colors mono)))
        or die ();
    my $image
        = $mine->copy ()
        or die ();
    ## .
    $image;
}

sub qr_image_size {
    my ($self) = @_;
    my $img
        = $self->qr_imager ();
    ## .
    return ($img->getwidth (), $img->getheight ());
}

sub qr_png {
    my ($self) = @_;
    my $data;
    $self->qr_imager ()->write ("data" => \$data, qw (type png))
        or die ();
    ## .
    $data;
}

sub qr_jpeg {
    my ($self) = @_;
    my $data;
    $self->qr_imager ()->write ("data" => \$data, qw (type jpeg))
        or die ();
    ## .
    $data;
}


### Package: UUID::Stream

package UUID::Stream;

require Barcode::ZBar;
require Data::Dump;
require UUID;

our $reader
    = Barcode::ZBar::Processor->new ();

sub uuid_generate_fitting {
    my ($uq_opts) = @_;
    my $uuid;
    UUID::generate ($uuid);
    my $uo
        = UUID::QRCode->new ($uuid, $uq_opts)
        or die ();
    my $valid_p = eval {
        my ($jpeg, @size)
            = ($uo->qr_jpeg (), $uo->qr_image_size ());
        my $bi
            = Barcode::ZBar::Image->new ();
        $bi->set_format ("JPEG");
        $bi->set_data ($jpeg);
        $bi->set_size (@size);
        $reader->process_image ($bi);
        my @sym
            = $bi->get_symbols ();
        die ()
            unless (@sym == 1);
        my $data
            = $sym[0]->get_data ();
        die ()
            unless ($uo->urn () eq $data
                    || $uo->url () eq $data);
    };
    warn (($valid_p ? "D" : "W"), ": Generated: ", uuid_string ($uo),
          ($valid_p ? () : (" (invalid?)")), "\n")
        unless ($valid_p && ! $main::verbose_p);
    warn ("W: ", $@)
        unless ($valid_p);

    ## .
    return $uo
        if ($valid_p);

    die ("FIXME: out of luck");
}

sub uuid_parse {
    my ($u) = @_;

    ## .
    return $u
        if (ref ($u));

    ## .
    return UUID::QRCode->new ($u)
        if (length ($u) == 16);

    my $u1
        = $u;
    $u1
        =~ tr/-//d;
    my $uuid
        = (($u1 =~ m {^ [[:xdigit:]]{32} $}x)
           ? pack ("H*", $u1)
           : MIME::Base64::decode_base64url ($u1))
        or die ("Cannot parse UUID: ",
                Data::Dump::dump ($u));
    die (Data::Dump::dump ($uuid))
        unless (length ($uuid) == 16);
    my $uo
        = UUID::QRCode->new ($uuid)
        or die ();
    warn ("D: UUID: ", uuid_string ($uo),
          " (", Data::Dump::dump ($u), ")\n")
        if ($main::verbose_p);
    ## .
    $uo;
}

sub uuid_string {
    my ($uo) = @_;
    ## .
    return ($uo->urn () . " [" . $uo->url () . "]");
}

sub new {
    my ($class, @may_be_opts) = @_;
    my $self = {
        (@may_be_opts != 1 ? @may_be_opts
         : "HASH"  eq ref ($may_be_opts[0]) ? %{$may_be_opts[0]}
         : @{$may_be_opts[0]})
    };
    $self->{"preload"}
        //= [ ];

    ## .
    bless ($self, $class);
}

sub next {
    my ($self) = @_;
    my $preload
        = $self->{"preload"};
    my $u
        = (@$preload > 0
           ? uuid_parse (shift (@$preload))
           : uuid_generate_fitting ($self->{"uuid-qrcode-options"}))
        or die ();
    ## .
    $u;
}

sub load {
    my ($self, @load) = @_;
    push (@{$self->{"preload"}}, @load);
    ## .
    scalar (@{$self->{"preload"}});
}


### Back to the main package

package main;

sub parse_position {
    my ($s) = @_;
    my @r
        = ($s =~ /^ ([+-](?: \d+ (?:[.]\d*)?) | \d* (?:[.]\d+))
                    ([+-](?: \d+ (?:[.]\d*)?) | \d* (?:[.]\d+)) $/x);
    ## .
    @r;
}

sub add_page_uuid {
    my ($pdf, $stream, %options) = @_;

    my ($font, $may_be_page)
        = @options{qw (font page)};
    my ($may_be_position, $may_be_shift, $may_be_count)
        = @options{qw (position shift per-page)};
    our @label_size;
    my ($l_w, $l_h)
        = @label_size;
    my @pos0
        = (! defined ($may_be_position)         ? (105, 10 + .5 * $l_h)
           : ref ($may_be_position) eq "ARRAY"  ? @$may_be_position
           : parse_position ($may_be_position));
    my @shift
        = ($may_be_count < 1                    ? ()
           : ! defined ($may_be_shift)          ? @label_size
           : ref ($may_be_shift) eq "ARRAY"     ? @$may_be_shift
           : parse_position ($may_be_shift));
    my $page
        = ($may_be_page // $pdf->page ());
    $page->mediabox ("A4")
        unless (defined ($may_be_page));
    my $g
        = $page->gfx ();

    ## FIXME: too much data hardcoded (assumes A4)
    my @p_dim
        = (210, 297);
    our $mm_pt;
    $g->scale (($mm_pt) x 2);
    my @pos
        = @pos0;
    $g->translate (($pos[0] >= 0 ? $pos[0] : $pos[0] + $p_dim[0]),
                   ($pos[1] >= 0 ? $pos[1] : $pos[1] + $p_dim[1]));
    $g->linewidth (.175);

    warn ("D: Origin: ",    Data::Dump::dump (@pos0),
          " Paper size: ",  Data::Dump::dump (@p_dim),
          "\n")
        if ($main::verbose_p);
    for (my $i = 0; $i < ($may_be_count // 1); $i++) {
        my $uo
            = $stream->next ()
            or die ();
        add_gfx_label ($pdf, $g, $font, $uo);
        $pos[0]
            += $shift[0];
        ## FIXME: too inflexible (and ugly!)
        if ($pos[0]    - .5 * $l_w >= .05 * $p_dim[0]
            && $pos[0] + .5 * $l_w <  .95 * $p_dim[0]) {
            warn ("D: Moved to: ",
                  Data::Dump::dump (@pos), "\n")
                if ($main::verbose_p);
            $g->translate ($shift[0], 0);
        } else {
            $g->translate ($pos0[0] - $pos[0] + $shift[0],
                           $shift[1]);
            $pos[0]
                =  $pos0[0];
            $pos[1]
                += $shift[1];
            warn ("D: New row at: ",
                  Data::Dump::dump (@pos), "\n")
                if ($main::verbose_p);
        }
    }

    ## .
    return (wantarray ()
            ? ($page, "gfx" => $g)
            :  $page);
}

sub add_gfx_label {
    my ($pdf, $g, $font, $uo) = @_;

    our $pt_mm;
    ## FIXME: shouldn't be hardcoded
    my $font_size
        = (17 * $pt_mm);

    my $img
        = $pdf->image_png (IO::String->new ($uo->qr_png ()))
        or die ();

    ## NB: center the label
    our @label_size;
    my $h
        = $label_size[1];
    my ($w2, $h2)
        = map { .5 * $_; } (@label_size);
    my @c_shift
        = (0, $h2);
    $g->translate (@c_shift);
    $g->move (0, 3 + $h);
    $g->poly   (-$w2, 0,  +$w2, 0,  +$w2, $h, -$w2, $h);
    $g->close ();
    $g->stroke ();
    $g->image ($img, (-$w2 + .25), .25, ($h - .5) x 2);

    # $t->font ($pdf->corefont (qw (Helvetica-Bold  -encode latin1)), 33);
    do {
        my $s
            = $uo->uri ()
            or die ();
        ## FIXME: requires a prefix ending on a /
        my @a
            = ($s =~ m { : ([[:xdigit:]]{4})([[:xdigit:]]{4}) \b
                         | .* / (\S{4})(\S{4}) }xa);
        my $x_a
            = $g->textlabel (0, .65 * $h, $font, $font_size,
                             $a[0] // $a[2],
                             qw (-color #000));
        my $x_b
            = $g->textlabel (0, .15 * $h, $font, $font_size,
                             $a[1] // $a[3],
                             qw (-color #000));
        # print STDERR (Data::Dump::dump ([ $x_a, $x_b ]), "\n");
    };

    ## NB: undo the coordinate shift
    $g->translate (map { - $_; } @c_shift);

    ## .
    $g;
}

Getopt::Long::Configure (qw (gnu_compat));
our $verbose_p
    = 0;
my ($in, $out)
    = (undef, "-");
my ($gen, $start, $every, $per_page)
    = (undef,  1,      1,         1);
my ($pos, $p_shift)
    = (undef, undef);
my ($url_prefix, $url_suffix)
    = ();
my $parsable_p
    = Getopt::Long::GetOptions ("e|every=i"    => \$every,
                                q "generate=i" => \$gen,
                                "i|input=s"    => \$in,
                                "j|start-page=i"  => \$start,
                                "o|output=s"   => \$out,
                                "p|position=s" => \$pos,
                                q "position-shift=s" => \$p_shift,
                                q "per-page=i" => \$per_page,
                                q "url-prefix=s"  => \$url_prefix,
                                q "url-suffix=s"  => \$url_suffix,
                                "v|verbose!"   => \$verbose_p)
    or die ("Cannot parse command line arguments");
die ("--every= (-e) cannot be negative")
    unless ($every >= 0);
die ("--generate= cannot be negative")
    unless ($gen >= 0);
die ("--start-page= (-j) cannot be non-positive")
    unless ($start > 0);

my $pdf
    = (defined ($in)
       ? PDF::API2->open ($in)
       : PDF::API2->new ());
print STDERR ($in, ": PDF file opened\n")
    if ($verbose_p && defined ($in));
$pdf->mediabox ("A4");
my $font
    = $pdf->corefont ("Courier");
my $page_no
    = (defined ($in) ? $start : undef);
my $stream_opts = {
    "uuid-qrcode-options" => {
        (! defined ($url_prefix) ? ()
         : ("url-prefix" => $url_prefix)),
        (! (defined ($url_suffix) || defined ($url_prefix)) ? ()
         : ("url-suffix" => $url_suffix // "/"))
    }
};
my $stream
    = UUID::Stream->new ($stream_opts);

my %opt
    = ("font"     =>  $font,
       "position" =>  $pos,
       "shift"    =>  $p_shift,
       "per-page" =>  $per_page);

for (my $i = 0; $i < $gen; $i += $per_page) {
    add_page_uuid ($pdf, $stream,
                   "page" => (defined ($page_no)
                              ? $pdf->openpage ($page_no)
                              : undef),
                   %opt);
    $page_no
        += $every
        if (defined ($page_no));
}

# unless ($gen > 0 || 1 + $#ARGV > 0) {
#     push (@ARGV, "-");
# }

# foreach my $f (@ARGV) {
# }

if (1 + $#ARGV > 0 || $gen < 1) {
    while (<>) {
        # print STDERR ("Read: ", Data::Dump::dump ($_), "\n");
        chomp ();
        $stream->load ($_);
    }
}

while ($stream->load ()) {
    add_page_uuid ($pdf, $stream,
                   "page" => (defined ($page_no)
                              ? $pdf->openpage ($page_no)
                              : undef),
                   %opt);
    $page_no
        += $every
        if (defined ($page_no));
}

## FIXME: ->saveas () should allow for a filehandle argument
if ($out eq "-") {
    my $o
        = \*STDOUT;
    binmode ($o);
    print $o ($pdf->stringify ());
} else {
    $pdf->saveas ($out);
}

print STDERR ($out eq "-"
              ? ("PDF file written to stdout\n")
              : ($out, ": PDF file written\n"))
    if ($verbose_p);

### Emacs trailer
## Local variables:
## coding: utf-8
## indent-tabs-mode: nil
## ispell-local-dictionary: "american"
## End:
### pdfstampid.perl ends here