#!/usr/bin/perl
#=======================================================================
#    ____  ____  _____              _    ____ ___   ____
#   |  _ \|  _ \|  ___|  _   _     / \  |  _ \_ _| |___ \
#   | |_) | | | | |_    (_) (_)   / _ \ | |_) | |    __) |
#   |  __/| |_| |  _|    _   _   / ___ \|  __/| |   / __/
#   |_|   |____/|_|     (_) (_) /_/   \_\_|  |___| |_____|
#
#   A Perl Module Chain to faciliate the Creation and Modification
#   of High-Quality "Portable Document Format (PDF)" Files.
#
#   Copyright 1999-2004 Alfred Reibenschuh <areibens@cpan.org>.
#
#=======================================================================
#
#   PERMISSION TO USE, COPY, MODIFY, AND DISTRIBUTE THIS FILE FOR
#   ANY PURPOSE WITH OR WITHOUT FEE IS HEREBY GRANTED, PROVIDED THAT
#   THE ABOVE COPYRIGHT NOTICE AND THIS PERMISSION NOTICE APPEAR IN ALL
#   COPIES.
#
#   THIS FILE IS PROVIDED ``AS IS'' AND ANY EXPRESSED OR IMPLIED
#   WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
#   MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
#   IN NO EVENT SHALL THE AUTHORS AND COPYRIGHT HOLDERS AND THEIR
#   CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
#   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
#   LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
#   USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
#   ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
#   OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT
#   OF THE USE OF THIS FILE, EVEN IF ADVISED OF THE POSSIBILITY OF
#   SUCH DAMAGE.
#
#   $Id: 022_truefonts,v 2.1 2006/06/19 19:20:13 areibens Exp $
#
#=======================================================================

use File::Basename;
use PDF::API2;
use PDF::API2::Util;
use Unicode::UCD 'charinfo';
use Getopt::Long;

my $sx=33;
my $sy=45;
my $fx=20;

my $encoding='latin1';

GetOptions(
    "encode|e=s" => \$encoding,
);

foreach $fn (@ARGV) {

    $pdf=PDF::API2->new(-file => basename($0).'.'.basename($fn).".pdf");

    $f1=$pdf->corefont('Helvetica', -encode => 'latin1');
    $f2=$pdf->corefont('Helvetica-Bold', -encode => 'latin1');

    print STDERR "\n$fn\n";

    my $font=$pdf->ttfont($fn, -encode => $encoding);
	$font->data->{nosubset}=1;
    if(1)
    {
        my $page = $pdf->page;
        $page->mediabox(595,842);

        my $gfx=$page->gfx;

        my $txt=$page->text;
            $txt->font($font,$fx);

        my $txt2=$page->text;
        #delete $txt->{Filter};
        #delete $txt2->{Filter};

        $txt2->textlabel(50,800,$f1,20,"font='".$font->fontname."'");
        $txt2->textlabel(50,780,$f1,20,"encoding='$encoding'");

        $txt2->font($f1,5);
        $txt2->hspace(80);

        my $u=$font->underlineposition*$fx/1000;

        foreach $x (0..15) 
        {
            print STDERR ".";
            foreach $y (0..15) 
            {
                $txt->translate(50+($sx*$x),50+($sy*$y));
                $txt->text(chr($y*16+$x));

                my $wx=$font->width(chr($y*16+$x))*$fx;

                $gfx->strokecolor('lightblue');
                $gfx->move(50+($sx*$x),50+($sy*$y)+$fx);
                $gfx->line(50+($sx*$x),50+($sy*$y)+$u);
                $gfx->line(50+($sx*$x)+$wx,50+($sy*$y)+$u);
                $gfx->line(50+($sx*$x)+$wx,50+($sy*$y)+$fx);
                $gfx->close;
                $gfx->stroke;

                $gfx->strokecolor('gray');
                $gfx->move(50+($sx*$x),50+($sy*$y));
                $gfx->line(50+($sx*$x)+$wx,50+($sy*$y));
                $gfx->stroke;

                $txt2->translate(50+($sx*$x)-2,50+($sy*$y)-6);
                $txt2->text_right($y*16+$x);
                $txt2->translate(50+($sx*$x)-2,50+($sy*$y)-11);
                $txt2->text_right(sprintf('U=0x%04X',$font->uniByEnc($y*16+$x)));
                $txt2->translate(50+($sx*$x)-2,50+($sy*$y)-16);
                $txt2->text_right($font->glyphByEnc($y*16+$x));
                $txt2->translate(50+($sx*$x)-2,50+($sy*$y)-21);
                $txt2->text_right(sprintf('wx=%i',$font->wxByEnc($y*16+$x)));
            }
        }
    }

    my @cids=(0 .. $font->glyphNum-1);
    my @fbbx = $font->fontbbox;
    my $xw = int(($fbbx[2]-$fbbx[0])/20)*20;
    my $yw = int(($fbbx[3]-$fbbx[1])/20)*20;
    my $fw = $xw>$yw ? $yw : $xw;
    my $mw=800/$fw;
    my $y0=int((20-$fbbx[1])/20)*20*$mw;

    while(scalar @cids>0) {

        $page = $pdf->page;
        $page->mediabox(595,842);

        $gfx=$page->gfx;
        #delete $gfx->{Filter};

        foreach my $y (750,700,650,600,550,500,450,400,350,300,250,200,150,100,50) {
            foreach my $x (50,100,150,200,250,300,350,400,450,500) {
                my $xo=shift @cids;
                $gfx->save;
                $gfx->fillcolor('black');
                $gfx->transform(-translate => [$x, $y], -scale => [0.045, 0.045]);

                $gfx->linewidth(10);
                $gfx->rect(0,0,1000,1000);
                $gfx->stroke;

                my $wx=$font->wxByCId($xo)*$mw;
                my $x0=(1000-$wx)/2;

                $gfx->linedash(10,20);
                $gfx->linewidth(0.5);
                $gfx->move($x0,0);
                $gfx->line($x0,1000);
                $gfx->move($x0+$wx,1000);
                $gfx->line($x0+$wx,0);
                $gfx->move(0,$y0);
                $gfx->line(1000,$y0);
                $gfx->stroke;

                $gfx->textstart;
                $gfx->font($font,1000*$mw);
                $gfx->translate($x0,$y0);
                $gfx->add($font->text_cid(pack('n',$xo)),'Tj');

                $gfx->font($f1,100);
                $gfx->hspace(80);
                $gfx->translate(25,860);
                $gfx->text("G+$xo"); 
                $gfx->translate(25,10);
                $gfx->text(sprintf('U+0x%04X',$font->uniByCId($xo)));

                my $name=$font->glyphByCId($xo);
                if($name eq '') {
                    $gfx->fillcolor('red');
                    $name="NONE";
                } else {
                    $gfx->fillcolor('blue');
                }

                $gfx->hspace(70);
                $gfx->translate(975,860);
                $gfx->text_right($name);

                $gfx->fillcolor('black');
                $gfx->translate(975,10);
                $gfx->text_right('wx='.$font->wxByCId($xo));

                $gfx->fillcolor('#008000');
                $gfx->translate(500,950);
                $gfx->hspace(70);
                my $ci = charinfo($font->uniByCId($xo) || 0);
                $gfx->font($f2,50);
                $gfx->text_center($ci->{name});

                $gfx->textend;
                $gfx->restore;

                last unless(scalar @cids>0);
            }
            last unless(scalar @cids>0);
        }
        print STDERR ".";
        $pdf->finishobjects($page,$gfx);
    }
    $pdf->save;
    $pdf->end;
}

exit;

__END__

=head1 HISTORY

    $Log: 022_truefonts,v $
    Revision 2.1  2006/06/19 19:20:13  areibens
    added details

    Revision 2.0  2005/11/16 02:16:00  areibens
    revision workaround for SF cvs import not to screw up CPAN

    Revision 1.2  2005/11/16 01:27:48  areibens
    genesis2

    Revision 1.1  2005/11/16 01:19:24  areibens
    genesis

    Revision 1.3  2005/09/12 16:55:05  fredo
    various updates

    Revision 1.2  2004/12/31 02:58:49  fredo
    no message

    Revision 1.1  2004/04/06 23:04:06  fredo
    genesis


=cut