HTML::FormatPS - Format HTML as PostScript

    use HTML::TreeBuilder;
    $tree = HTML::TreeBuilder->new->parse_file("test.html");

    use HTML::FormatPS;
    $formatter = HTML::FormatPS->new(
        FontFamily => 'Helvetica',
        PaperSize  => 'Letter',
    );
    print $formatter->format($tree);

    use HTML::FormatPS;
    print HTML::FormatPS->format_file(
        "test.html",
        'FontFamily' => 'Helvetica',
        'PaperSize'  => 'Letter',
    );

    my $formatter = FormatterClass->new(
        option1 => value1, option2 => value2, ...
    );

package HTML::FormatPS;

# ABSTRACT: Format HTML as PostScript


use 5.006_001;
use strict;
use warnings;
use Carp;
use IO::File;

use base 'HTML::Formatter';

our $VERSION = '2.07'; # VERSION
our $AUTHORITY = 'cpan:NIGELM'; # AUTHORITY

# We now use Smart::Comments in place of the old DEBUG framework.
# this should be commented out in release versions....
##use Smart::Comments;

# ------------------------------------------------------------------------
# A few routines that convert lengths into points
sub mm { $_[0] * 72 / 25.4; }
sub in { $_[0] * 72; }

# ------------------------------------------------------------------------
my %PaperSizes = (
    A3        => [ mm(297), mm(420) ],
    A4        => [ mm(210), mm(297) ],
    A5        => [ mm(148), mm(210) ],
    B4        => [ 729,     1032 ],
    B5        => [ 516,     729 ],
    Letter    => [ in(8.5), in(11) ],
    Legal     => [ in(8.5), in(14) ],
    Executive => [ in(7.5), in(10) ],
    Tabloid   => [ in(11),  in(17) ],
    Statement => [ in(5.5), in(8.5) ],
    Folio     => [ in(8.5), in(13) ],
    "10x14"   => [ in(10),  in(14) ],
    Quarto    => [ 610,     780 ],
);

# ------------------------------------------------------------------------
my %FontFamilies = (
    Courier => [
        qw(Courier
            Courier-Bold
            Courier-Oblique
            Courier-BoldOblique)
    ],

    Helvetica => [
        qw(Helvetica
            Helvetica-Bold
            Helvetica-Oblique
            Helvetica-BoldOblique)
    ],

    Times => [
        qw(Times-Roman
            Times-Bold
            Times-Italic
            Times-BoldItalic)
    ],
);

# ------------------------------------------------------------------------
# size            0  1  2  3   4   5   6   7   8
my @FontSizes = ( 5, 6, 8, 10, 12, 14, 18, 24, 32 );

sub BOLD   { 0x01; }
sub ITALIC { 0x02; }

my %param = (
    papersize        => 'papersize',
    paperwidth       => 'paperwidth',
    paperheight      => 'paperheigth',
    leftmargin       => 'lmW',
    rightmargin      => 'rmW',
    horizontalmargin => 'mW',
    topmargin        => 'tmH',
    bottommargin     => 'bmH',
    verticalmargin   => 'mH',
    no_prolog        => 'no_prolog',
    no_trailer       => 'no_trailer',
    pageno           => 'printpageno',
    startpage        => 'startpage',
    fontfamily       => 'family',
    fontscale        => 'fontscale',
    leading          => 'leading',
);

# ------------------------------------------------------------------------


sub new {
    my $class = shift;

    my $self = $class->SUPER::new(@_);

    # Obtained from the <title> element
    $self->{title} = "";

    # The font ID last sent to the PostScript output (this may be
    # temporarily different from the "current font" as read from
    # the HTML input).  Initially none.
    $self->{psfontid} = "";

    # Pending horizontal space.  A list [ " ", $fontid, $width ],
    # or undef if no space is pending.
    $self->{hspace} = undef;

    $self;
}

# ------------------------------------------------------------------------
sub default_values {
    (   shift->SUPER::default_values(),

        family      => "Times",
        mH          => mm(40),
        mW          => mm(20),
        printpageno => 1,
        startpage   => 1,         # yes, you can start numbering at 10, or whatever.
        fontscale   => 1,
        leading     => 0.1,
        papersize   => 'A4',
        paperwidth  => mm(210),
        paperheight => mm(297),
    );
}

# ------------------------------------------------------------------------
sub configure {
    my ( $self, $hash ) = @_;

    my ( $key, $val );
    while ( ( $key, $val ) = each %$hash ) {
        $key = lc $key;
        croak "Illegal parameter ($key => $val)" unless exists $param{$key};
        $key = $param{$key};
        {
            $key eq "family" && do {
                $val = "\u\L$val";
                croak "Unknown font family ($val)"
                    unless exists $FontFamilies{$val};
                $self->{family} = $val;
                last;
            };
            $key eq "papersize" && do {
                $self->papersize($val)
                    || croak sprintf "Unknown papersize '%s'.\nThe knowns are: %s.\nAborting",
                    $val,
                    join( ', ', sort keys %PaperSizes );
                last;
            };
            $self->{$key} = lc $val;
        }
    }
}

# ------------------------------------------------------------------------
sub papersize {
    my ( $self, $val ) = @_;

    $val = "\u\L$val";
    my ( $width, $height ) = @{ $PaperSizes{$val} || return 0 };
    return 0 unless defined $width;
    $self->{papersize}   = $val;
    $self->{paperwidth}  = $width;
    $self->{paperheight} = $height;
    1;
}

# ------------------------------------------------------------------------
sub fontsize {
    my $self = shift;

    my $size = $self->{font_size}[-1];
    $size = 8 if $size > 8;
    $size = 3 if $size < 0;
    $FontSizes[$size] * $self->{fontscale};
}

# Determine the current font and set font-related members.
# If $plain_with_size is given (a number), use a plain font
# of that size.  Otherwise, use the font specified by the
# HTML context.  Returns the "font ID" of the current font.

# ------------------------------------------------------------------------
sub setfont {
    my ( $self, $plain_with_size ) = @_;

    my $index  = 0;
    my $family = $self->{family} || 'Times';
    my $size   = $plain_with_size;
    unless ($plain_with_size) {
        $index |= BOLD if $self->{bold};
        $index |= ITALIC if $self->{italic} || $self->{underline};
        $family = 'Courier' if $self->{teletype};
        $size = $self->fontsize;
    }
    my $font           = $FontFamilies{$family}[$index];
    my $font_with_size = "$font-$size";
    if ( $self->{currentfont} eq $font_with_size ) {
        return $self->{currentfontid};
    }
    $self->{currentfont} = $font_with_size;
    $self->{pointsize}   = $size;
    my $fontmod = "Font::Metrics::$font";
    $fontmod =~ s/-//g;
    my $fontfile = $fontmod . ".pm";
    $fontfile =~ s,::,/,g;
    require $fontfile;
    {
        ## no critic
        no strict 'refs';
        $self->{wx} = \@{"${fontmod}::wx"};
        ## use critic
    }
    $font = $self->{fonts}{$font_with_size} || do {
        my $fontID = "F" . ++$self->{fno};
        $self->{fonts}{$font_with_size} = $fontID;
        $fontID;
    };
    $self->{currentfontid} = $font;
    return $font;
}

# ------------------------------------------------------------------------
# Construct PostScript code for setting the current font according
# to $fontid, or an empty string if no font change is needed.
# Assumes the return string will always be output as PostScript if
# nonempty, so that our notion of the current PostScript font
# stays in sync with that of the PostScript interpreter.
#
sub switchfont {
    my ( $self, $fontid ) = @_;

    if ( $self->{psfontid} eq $fontid ) {
        return "";
    }
    else {
        $self->{psfontid} = $fontid;
        return "$fontid SF";
    }
}

# ------------------------------------------------------------------------
# Like setfont + switchfont.
sub findfont {
    my ( $self, $plain_with_size ) = @_;

    return $self->switchfont( $self->setfont($plain_with_size) );
}

# ------------------------------------------------------------------------
sub width {
    my $self = shift;

    my $w  = 0;
    my $wx = $self->{wx};
    my $sz = $self->{pointsize};
    for ( unpack( "C*", $_[0] ) ) {
        $w += $wx->[$_] * $sz    # unless  $_ eq 0xAD; # optional hyphen
    }
    $w;
}

# ------------------------------------------------------------------------
sub begin {
    my $self = shift;

    $self->SUPER::begin;

    # Margins are in points
    $self->{lm} = $self->{lmW} || $self->{mW};
    $self->{rm} = $self->{paperwidth} -  ( $self->{rmW} || $self->{mW} );
    $self->{tm} = $self->{paperheight} - ( $self->{tmH} || $self->{mH} );
    $self->{bm} = $self->{bmH} || $self->{mH};

    $self->{'orig_margins'} =    # used only by the debug-mode print-area marker
        [ map { sprintf "%.1f", $_ } @{$self}{qw(lm bm rm tm)} ];

    # Font setup
    $self->{fno}   = 0;
    $self->{fonts} = {};
    $self->{en}    = 0.55 * $self->fontsize(3);

    # Initial position
    $self->{xpos} = $self->{lm};    # top of the current line
    $self->{ypos} = $self->{tm};

    $self->{pageno}              = 1;
    $self->{visible_page_number} = $self->{startpage};

    $self->{line}              = "";
    $self->{showstring}        = "";
    $self->{currentfont}       = "";
    $self->{prev_currentfont}  = "";
    $self->{largest_pointsize} = 0;

    $self->newpage;
}

# ------------------------------------------------------------------------
sub end {
    my $self = shift;

    $self->showline;
    $self->endpage if $self->{'out'};
    my $pages = $self->{pageno} - 1;

    my @prolog = ();
    push( @prolog, "%!PS-Adobe-3.0\n" );

    #push(@prolog,"%%Title: No title\n"); # should look for the <title> element
    push( @prolog, "%%Creator: " . $self->version_tag . "\n" );
    push( @prolog, "%%CreationDate: " . localtime() . "\n" );
    push( @prolog, "%%Pages: $pages\n" );
    push( @prolog, "%%PageOrder: Ascend\n" );
    push( @prolog, "%%Orientation: Portrait\n" );
    my ( $pw, $ph ) = map { int($_); } @{$self}{qw(paperwidth paperheight)};

    push( @prolog, "%%DocumentMedia: Plain $pw $ph 0 white ()\n" );
    push( @prolog, "%%DocumentNeededResources: \n" );
    my %seenfont;
    for my $full ( sort keys %{ $self->{fonts} } ) {
        $full =~ s/-\d+$//;
        next if $seenfont{$full}++;
        push( @prolog, "%%+ font $full\n" );
    }
    push( @prolog, "%%DocumentSuppliedResources: procset newencode 1.0 0\n" );
    push( @prolog, "%%+ encoding ISOLatin1Encoding\n" );
    push( @prolog, "%%EndComments\n" );
    push( @prolog, <<'EOT');

%%BeginProlog
/S/show load def
/M/moveto load def
/SF/setfont load def

%%BeginResource: encoding ISOLatin1Encoding
systemdict /ISOLatin1Encoding known not {
    /ISOLatin1Encoding [
    /space /space /space /space /space /space /space /space
    /space /space /space /space /space /space /space /space
    /space /space /space /space /space /space /space /space
    /space /space /space /space /space /space /space /space

    /space /exclam /quotedbl /numbersign /dollar /percent /ampersand
        /quoteright
    /parenleft /parenright /asterisk /plus /comma /minus /period /slash
    /zero /one /two /three /four /five /six /seven
    /eight /nine /colon /semicolon /less /equal /greater /question
    /at /A /B /C /D /E /F /G
    /H /I /J /K /L /M /N /O
    /P /Q /R /S /T /U /V /W
    /X /Y /Z /bracketleft /backslash /bracketright /asciicircum /underscore
    /quoteleft /a /b /c /d /e /f /g
    /h /i /j /k /l /m /n /o
    /p /q /r /s /t /u /v /w
    /x /y /z /braceleft /bar /braceright /asciitilde /space

    /space /space /space /space /space /space /space /space
    /space /space /space /space /space /space /space /space
    /dotlessi /grave /acute /circumflex /tilde /macron /breve /dotaccent
    /dieresis /space /ring /cedilla /space /hungarumlaut /ogonek /caron

    /space /exclamdown /cent /sterling /currency /yen /brokenbar /section
    /dieresis /copyright /ordfeminine /guillemotleft /logicalnot /hyphen
        /registered /macron
    /degree /plusminus /twosuperior /threesuperior /acute /mu /paragraph
        /periodcentered
    /cedillar /onesuperior /ordmasculine /guillemotright /onequarter
        /onehalf /threequarters /questiondown
    /Agrave /Aacute /Acircumflex /Atilde /Adieresis /Aring /AE /Ccedilla
    /Egrave /Eacute /Ecircumflex /Edieresis /Igrave /Iacute /Icircumflex
        /Idieresis
    /Eth /Ntilde /Ograve /Oacute /Ocircumflex /Otilde /Odieresis /multiply
    /Oslash /Ugrave /Uacute /Ucircumflex /Udieresis /Yacute /Thorn
        /germandbls
    /agrave /aacute /acircumflex /atilde /adieresis /aring /ae /ccedilla
    /egrave /eacute /ecircumflex /edieresis /igrave /iacute /icircumflex
        /idieresis
    /eth /ntilde /ograve /oacute /ocircumflex /otilde /odieresis /divide
    /oslash /ugrave /uacute /ucircumflex /udieresis /yacute /thorn
        /ydieresis
    ] def
} if
%%EndResource
%%BeginResource: procset newencode 1.0 0
/NE { %def
   findfont begin
      currentdict dup length dict begin
     { %forall
        1 index/FID ne {def} {pop pop} ifelse
     } forall
     /FontName exch def
     /Encoding exch def
     currentdict dup
      end
   end
   /FontName get exch definefont pop
} bind def
%%EndResource
%%EndProlog
EOT

    push( @prolog, "\n%%BeginSetup\n" );
    for my $full ( sort keys %{ $self->{fonts} } ) {
        my $short = $self->{fonts}{$full};
        $full =~ s/-(\d+)$//;
        my $size = $1;
        push( @prolog, "ISOLatin1Encoding/$full-ISO/$full NE\n" );
        push( @prolog, "/$short/$full-ISO findfont $size scalefont def\n" );
    }
    push( @prolog, "%%EndSetup\n" );

    $self->collect("\n%%Trailer\n%%EOF\n")
        unless $self->{'no_trailer'};

    unshift( @{ $self->{output} }, @prolog )
        unless $self->{'no_prolog'};
}

# ------------------------------------------------------------------------
sub header_start {
    my ( $self, $level ) = @_;

    # If we are close enough to be bottom of the page, start a new page
    # instead of this:
    ### Heading of level: $level
    $self->vspace( 1 + ( 6 - $level ) * 0.4 );
    $self->{bold}++;
    push( @{ $self->{font_size} }, 8 - $level );
    1;
}

# ------------------------------------------------------------------------
sub header_end {
    my ($self) = @_;

    $self->vspace(1);
    $self->{bold}--;
    pop( @{ $self->{font_size} } );
    1;
}

# ------------------------------------------------------------------------
sub hr_start {
    my $self = shift;

    ### Making an HR...
    $self->showline;
    $self->vspace(0.5);
    $self->skip_vspace;
    my $lm = $self->{lm};
    my $rm = $self->{rm};
    my $y  = $self->{ypos};
    $self->collect( sprintf "newpath %.1f %.1f M %.1f %.1f lineto stroke\n", $lm, $y, $rm, $y );
    $self->vspace(0.5);
}

# ------------------------------------------------------------------------
sub skip_vspace {
    my $self = shift;

    ### Skipping some amount of vspace...
    if ( defined $self->{vspace} ) {
        $self->showline;
        if ( $self->{'out'} ) {
            $self->{ypos} -= $self->{vspace} * 10 * $self->{fontscale};

            if ( $self->{ypos} < $self->{bm} ) {
                ### vspace skip forced new page...
                $self->newpage;
            }
            else {
                ### Skipped vspace making y: $self->{'ypos'},
            }
        }
        else {
            ### Not skipping vspace as out is false: $self->{ypos}
        }
        $self->{xpos}   = $self->{lm};
        $self->{vspace} = undef;
        $self->{hspace} = undef;
    }
    else {
        ### No vspace to skip...
    }

    return;
}

# ------------------------------------------------------------------------
sub show {
    my $self = shift;

    my $str = $self->{showstring};
    $str =~ tr/\x01//d;
    return unless length $str;

    $str =~ s/[^\x00-\xff]/\xA4/g;

    # replace any Unicode characters with the otherwise useless
    #  International Communist Conspiracy money logo!

    $str =~ s/([\(\)\\])/\\$1/g;    # must escape parentheses and backslash
    $self->{line} .= "($str)S\n";
    $self->{showstring} = "";
}

# ------------------------------------------------------------------------
sub showline {
    my $self = shift;

    $self->show;
    my $line = $self->{line};
    unless ( length $line ) {
        ### Showline is a no-op because line buffer is empty...
        return;
    }

    ### Showline emitting: $line

    $self->{ypos} -= $self->{largest_pointsize} || $self->{pointsize};
    if ( $self->{ypos} < $self->{bm} ) {
        ### Showline forcing new page...
        $self->newpage;

        # newpage might alter currentfont!
        ### Showline sets vspace: $self->{vspace} || 0

        $self->{ypos} -= $self->{pointsize};
        #### Showline/Newpage x: $self->{xpos}
        #### Showline/Newpage y: $self->{ypos}

        # must set current font again
        my $font = $self->{prev_currentfont};
        if ($font) {
            $self->collect("$self->{fonts}{$font} SF\n\n");
        }

        ### End of doing newpage...
    }

    my $lm = $self->{lm};
    my $x  = $lm;
    if ( $self->{center} ) {

        # Unfortunately, the center attribute is gone when we get here,
        # so this code is never activated
        my $linewidth = $self->{xpos} - $lm;
        $x += ( $self->{rm} - $lm - $linewidth ) / 2;
    }

    $self->collect( sprintf "%.1f %.1f M\n", $x, $self->{ypos} );    # moveto
    $line =~ s/\s\)S$/)S/;                                           # many lines will end uselessly with space
    $self->collect($line);
    $self->{'out'}++;

    if ( $self->{bullet} ) {

        # Putting this behind the first line of the list item
        # makes it more likely that we get the right font.  We should
        # really set the font that we want to use.
        my $bullet = $self->{bullet};
        if ( $bullet eq '*' ) {

            # There is no character that is really suitable.  Let's make
            # a medium-sized filled cirle ourself.
            my $radius = $self->{pointsize} / 8;
            ### Adding code for a '*' bullet for that line...

            $self->collect(
                sprintf "newpath %.1f %.1f %.1f 0 360 arc fill\n",
                $self->{bullet_pos} + $radius,
                $self->{ypos} + $radius * 2, $radius,
            );
        }
        else {
            ### Adding code for other bullet for that line...

            $self->collect(
                sprintf "%.1f (%s) stringwidth pop sub %.1f add %.1f M\n",    # moveto
                $self->{bullet_pos},
                $bullet,
                $self->{pointsize} * 0.62,
                $self->{ypos},
            );
            $self->collect("($bullet)S\n");
        }
        $self->{bullet} = '';

    }

    $self->{prev_currentfont}  = $self->{currentfont};
    $self->{largest_pointsize} = 0;
    $self->{line}              = "";
    $self->{xpos}              = $lm;

    # Additional linespacing

    $self->{ypos} -= $self->{leading} * $self->{pointsize};
    #### Showline/end x: $self->{xpos}
    #### Showline/end y: $self->{ypos}

    return;
}

# ------------------------------------------------------------------------
sub endpage {
    my $self = shift;

    ### End page: $self->{pageno}
    # End previous page
    $self->collect("showpage\n");
    $self->{visible_page_number}++;
    $self->{pageno}++;
}

# ------------------------------------------------------------------------
sub newpage {
    my $self = shift;

    local $self->{'pointsize'} = $self->{'pointsize'};

    # That's needed for protecting against one bit of the
    #  potential side-effects from from page-numbering code

    if ( $self->{'out'} ) {    # whether we've sent anything to the current page so far.
        ### Newpage calls endpage...
        $self->endpage;
        $self->collect( sprintf "%% %s has sent %s write-events to the above page.\n", ref($self), $self->{'out'}, );
    }

    $self->{'out'} = 0;
    my $pageno              = $self->{pageno};
    my $visible_page_number = $self->{visible_page_number};

    $self->collect("\n%%Page: $pageno $pageno\n");
    ### Starting page: $pageno

    # Print page number
    if ( $self->{printpageno} ) {
        ### Printing page number: $visible_page_number
        $self->collect("%% Title and pageno\n");
        my $f = $self->findfont(8);
        $self->collect("$f\n") if $f;
        my $x = $self->{paperwidth};
        if ($x) { $x -= 30; }
        else    { $x = 30; }
        $self->collect( sprintf "%.1f 30.0 M($visible_page_number)S\n", $x );
        $x = $self->{lm};
        $self->{title} =~ tr/\x01//d;
        $self->collect( sprintf "%.1f 30.0 M($self->{title})S\n", $x );
    }
    else {
        ### Pointedly not printing page number...
    }
    $self->collect("\n");

    $self->{xpos} = $self->{lm};
    $self->{ypos} = $self->{tm};
    #### Newpage/end x: $self->{xpos}
    #### Newpage/end y: $self->{ypos}
}

# ------------------------------------------------------------------------
sub out {    # Output a word
    my ( $self, $text ) = @_;

    $text =~ tr/\xA0\xAD/ /d;
    ### Trapping new word: $text

    if ( $self->{collectingTheTitle} ) {

        # Both collect and print the title
        $text =~ s/([\(\)\\])/\\$1/g;    # Escape parens and the backslash
        $self->{title} .= $text;
        return;
    }

    my $fontid = $self->setfont();
    my $w      = $self->width($text);

    if ( $text =~ /^\s*$/ ) {
        $self->{hspace} = [ " ", $fontid, $w ];
        return;
    }

    $self->skip_vspace;

    # determine spacing / line breaks needed before text
    if ( $self->{hspace} ) {
        my ( $stext, $sfont, $swidth ) = @{ $self->{hspace} };
        if ( $self->{xpos} + $swidth + $w > $self->{rm} ) {

            # line break
            $self->showline;
        }
        else {

            # no line break; output a space
            $self->show_with_font( $stext, $sfont, $swidth );
        }
        $self->{hspace} = undef;
    }

    # output the text
    $self->show_with_font( $text, $fontid, $w );
}

# ------------------------------------------------------------------------
sub show_with_font {
    my ( $self, $text, $fontid, $w ) = @_;

    my $fontps = $self->switchfont($fontid);
    if ( length $fontps ) {
        $self->show;
        $self->{line} .= "$fontps\n";
    }

    $self->{xpos} += $w;
    $self->{showstring} .= $text;

    #### Append to string buffer: $text
    #### with font: $fontid
    #### with xpos: $self->{xpos}

    $self->{largest_pointsize} = $self->{pointsize}
        if $self->{largest_pointsize} < $self->{pointsize};
    $self->{'out'}++;
}

# ------------------------------------------------------------------------
sub pre_out {
    my ( $self, $text ) = @_;

    $self->skip_vspace;
    $self->tt_start;
    my $font = $self->findfont();
    if ( length $font ) {
        $self->show;
        $self->{line} .= "$font\n";
    }
    while ( $text =~ s/(.*)\n// ) {
        $self->{'out'}++;
        $self->{showstring} .= $1;
        $self->showline;
    }
    $self->{showstring} .= $text;
    $self->tt_end;
    1;
}

# ------------------------------------------------------------------------
sub bullet {
    my ( $self, $bullet ) = @_;

    $self->{bullet}     = $bullet;
    $self->{bullet_pos} = $self->{lm};
}

# ------------------------------------------------------------------------
sub adjust_lm {
    my $self = shift;

    $self->showline;

    $self->{lm} += $_[0] * $self->{en};
    1;
}

# ------------------------------------------------------------------------
sub adjust_rm {
    my $self = shift;

    $self->showline;

    $self->{rm} += $_[0] * $self->{en};
}

# ------------------------------------------------------------------------
sub head_start { 1; }
sub head_end   { 1; }

sub title_start {
    my ($self) = @_;

    $self->{collectingTheTitle} = 1;
    1;
}

sub title_end {
    my ($self) = @_;

    $self->{collectingTheTitle} = 0;
    1;
}

# ------------------------------------------------------------------------
my ( $counter, $last_state_filename );

# For use in circumstances of total desperation:

sub dump_state {
    my $self = shift;
    require Data::Dumper;

    ++$counter;
    my $filename = sprintf( "state%04d.txt", $counter );
    my $state = IO::File->new( $filename, 'w' ) or die "Can't write-open $filename: $!";
    $state->printf( "%s line %s\n", ( caller(1) )[ 3, 2 ] );
    {
        local ( $self->{'wx'} )     = '<SUPPRESSED>';
        local ( $self->{'output'} ) = '<SUPPRESSED>';
        $state->print( Data::Dumper::Dumper($self) );
    }
    $state->close;
    sleep 0;

    if ($last_state_filename) {
        system("perl -S diff.bat $last_state_filename $filename > $filename.diff");
    }

    $last_state_filename = $filename;
    return 1;
}

# ------------------------------------------------------------------------


1;

__END__