File Coverage

blib/lib/PostScript/PPD.pm

Criterion	Covered	Total	%
statement	280	310	90.3
branch	105	130	80.7
condition	20	28	71.4
subroutine	43	46	93.4
pod	6	6	100.0
total	454	520	87.3

package PostScript::PPD;

# use 5.008008;
use strict;
use warnings;

use Compress::Zlib qw( gzopen );
use Carp qw( carp croak confess cluck );
use Storable qw( dclone );
use IO::File;

our $VERSION = '0.0401';

sub DEBUG () { 0 }

################################################
sub new
{
    my( $package, $file ) = @_;
    my $self = bless { file => $file }, $package;
    $self->load if $file;
    return $self;
}

################################################
sub load
{
    my( $self, $file ) = @_;
    croak "Usage: $self->load( [ $file ] );"
            unless $file or $self->{file};

    $file ||= $self->{file};
    return unless $file;

    delete @{ $self }{ keys %$self };

    local $self->{__read_state};
    local $self->{__position} = { file=>$file, line=>0};

    eval {
        if( $file =~ /\.gz$/ ) {
            my $gz = gzopen( $file, "rb" );
            croak "Unable to read $file: $!" unless $gz;
            $self->{file} = $file;

            my( $line, $size );
            while( $size = $gz->gzreadline( $line ) ) {
                $self->{__position}{line}++;
                $self->__read_line( $line );
            }
        }
        else {
            my $fh = IO::File->new( $file );
            croak "Unable to read $file: $!" unless $fh;
            $self->{file} = $file;
            while( <$fh> ) {
                $self->{__position}{line}++;
                $self->__read_line( $_ );
            }
        }
    };
    if( $@ ) {
        die "File $self->{__position}{file} line $self->{__position}{line}: $@";
    }
}

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

    delete @{ $self }{ keys %$self };

    local $self->{__read_state};
    local $self->{__position} = { file=>'string', line=>0};
    eval {
        foreach my $line ( split /\n/, $text ) {
            $self->{__position}{line}++;
            $self->__read_line( $line );
        }
    };
    if( $@ ) {
        die "String line $self->{__position}{line}: $@";
    }
}

################################################
sub __read_line
{
    my( $self, $line ) = @_;

    $self->{__read_state} ||= { state => 0,
                                value => '',
                                key   => '',
                                current => [ $self ]
                              };
    my $S = $self->{__read_state};

    if( $S->{key} ) {
        if( $line =~ /^\*/ and $S->{value} =~ /^".*"\s*$/s ) {
            $self->__new_tupple;
        }
        else {
            $self->__append( $line );
            return;
        }
    }

    # comment
    return if $line =~ /^\*%/;
    # End a multi-line tupple
    if( $line =~ /^\*End\s*$/ ) {
        $self->__new_tupple;    # missing *End?
        return;
    }

    # Start a config group
    if( $line =~ /^\*OpenGroup:\s*(.+)/ ) {
        my $name = $1;
        $self->__new_tupple;    # missing *End?
        $self->__new_group( $name );
        return;
    }
    # End a config group
    if( $line =~ /^\*CloseGroup:\s*(.+)/ ) {
        my $name = $1;
        $self->__new_tupple;    # missing *End?
        $self->__end_group( $name );
        return;
    }
    # Open a UI option
    if( $line =~ /^\*(?:JCL)?OpenUI\s*\*(.+?):\s*(.+)/ ) {
        my( $name, $value ) = ( $1, $2 );
        $self->__new_tupple;    # missing *End?
        $self->__new_UI( $name, $value );
        return;
    }
    # End the UI option
    if( $line =~ /^\*(?:JCL)?CloseUI:?\s*\*(.+)/ ) {
        my $name = $1;
        $self->__new_tupple;    # missing *End?
        $self->__end_UI( $name );
        return;
    }

    # Translation tupple, that contains bad UTF-8 (Gestetner)
    if( $line =~ /^(\*zh_([^:]+)\s+)""$/ ) {
        my( $used, $name ) = ( $1, $2 );
        $self->__new_tupple;    # missing *End?
        $S->{key} = $name;
        $S->{value} = '';
        $self->__new_tupple;
        return;
    }
    # New tupple
    if( $line =~ /^(\*\s*([^:]+):\s*)/ ) {
        my( $used, $name ) = ( $1, $2 );
        $self->__new_tupple;    # missing *End?

        $used = length $used;
        $S->{key} = $name;
        $S->{value} = '';
        local $S->{first} = 1;
        $self->__append( substr $line, $used );
        return;
    }
    return unless $line =~ /\S/;

    warn "What's with line '$line' at $self->{__position}{file} line $self->{__position}{line}";
}

################################################
sub __append
{
    my( $self, $line ) = @_;

    my $S = $self->{__read_state};
    my $exit = 0;
    $exit = 1 if not $S->{value};

    # *Something: "honk" <- here
    if( $line =~ m/^"(.*)" *$/ ) {
        $S->{quoted} = 1;
        $exit = 1;
    }
    # *Something: "honk
    # " <- here
    # *End
    # *Something: "<- here
    # "
    # *End
    elsif( $line =~ m/^"/ ) {
        $S->{quoted} = 1;
        $exit = ( $line =~ /" *$/ );
        $exit = 0 if $S->{first};
    }
    # *Something: "
    # with trailing
    # "
    # *End <- here
    elsif( $line eq "*End\n" ) {
        $line = '';
        $exit = 1;
    }
    # *Something: "
    # with trailing <- here
    # "
    # *End
    elsif( not $S->{first} ) {
        $line =~ s/ +$//;
    }

    # *Something: "
    # Ho&& <- here
    # nk"
    if( $line =~ s/&&\s*$// ) {
        $exit = 0;
    }

    $S->{value} .= $line;

    if( $exit ) {
        $self->__new_tupple;
        return;
    }
}

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

    my $S = $self->{__read_state};
    return unless $S->{key};

    chomp( $S->{value} ) unless $S->{quoted};

    my $C = $S->{current}[-1];
    if( $S->{key} =~ /^([^ ]+)\s+(.+(\/.+)?)$/ ) {
        $self->__new_option( $1, $2, $S->{value} );
    }
    else {
        my $v = $self->__fix_value( $S->{value} );
        my $k = $S->{key};
        if( $C->{ $k } ) {
            $C->{ $k } = [ $C->{$k} ] unless ref $C->{$k};
            push @{ $C->{$k} }, $v;
        }
        else {
            $C->{ $k } = $v;
        }
        $C->{__sorted} ||= [];
        $self->__new_key( $k );
    }
    $S->{key} = '';
    $S->{value} = '';
    $S->{quoted} = 0;
}

sub __fix_value
{
    my( $self, $v ) = @_;
    if( $v eq 'False' ) {
        return 0;
    }
    elsif( $v =~ s/"(.*)"\s*/$1/s ) {
        $v =~ s/"?/"/g;
    }
    return $v;
}

sub __new_key
{
    my( $self, $key ) = @_;
    my $S = $self->{__read_state};
    my $C = $S->{current}[-1];
    push @{ $C->{__sorted} }, $key unless exists $C->{$key};
}

################################################
sub __new_option
{
    my( $self, $key, $name, $value ) = @_;
    my( $tname, $text ) = $self->__parse_name( $name );
    my $S = $self->{__read_state};
    my $C = $S->{current}[-1];

    $self->__new_key( $key );

    if( $C->{$key} ) {
        unless( 'HASH' eq ref $C->{$key} ) {
            # Promote *foo: "something" to *foo _: "something"
            # wish I had a better name for _
            $C->{$key} = { '_' => {  __name => '_',
                                     __text => '_',
                                     value => $C->{$key}
                                    }
                         };
        }
    }
    else {
        $C->{$key} = {
                       __sorted => []
                   };
    }
    DEBUG and warn "new option key=$key tname=$tname";

    $C->{$key}{$tname} = { __name => $tname,
                           __text => $text,
                           value  => $self->__fix_value( $value )
                         };
    push @{ $C->{$key}{__sorted} }, $tname;
}

################################################
sub __new_group
{
    my( $self, $name ) = @_;
    my( $tname, $text ) = $self->__parse_name( $name );
    $self->__push( group => { __name => $tname,
                              __text => $text
                            }
                 );
}

################################################
sub __end_group
{
    my( $self, $name ) = @_;


    my $S = $self->{__read_state};
    my $data = $S->{current}[-1];
    if( 'HASH' eq ref $data ) {
        if( 'group' ne $data->{__type} ) {    # Missing *CloseUI
            $self->__pop( $data->{__type}, $data->{__name} );
        }
    }


    my( $tname, $text ) = $self->__parse_name( $name );
    $self->__pop( group => $tname );
}

################################################
sub __new_UI
{
    my( $self, $name, $type ) = @_;
    my( $tname, $text ) = $self->__parse_name( $name );
    $self->__push( UI => { __name => $tname,
                           __text => $text,
                           __option => $type
                         }
                 );
}

################################################
sub __end_UI
{
    my( $self, $name ) = @_;
    $self->__pop( UI => $name );
}

################################################
sub __parse_name
{
    my( $self, $name ) = @_;
    my @bits = split '/', $name, 2;
    $bits[1] ||= $name;
    return @bits;
}

################################################
sub __push
{
    my( $self, $type, $data ) = @_;
    $data->{__type} = $type;

    my $S = $self->{__read_state};
    my $C = $S->{current}[-1];
    $C->{$type}{ $data->{__name} } = $data;
    push @{ $C->{"__${type}_sorted"} }, $data->{__name};

    # warn "PUSH $type.$data->{__name}\n";
    $self->__new_key( "$type.$data->{__name}" );
    push @{ $S->{current} }, $data;
}

################################################
sub __pop
{
    my( $self, $type, $name ) = @_;

    my $S = $self->{__read_state};
    # warn "POP $type.$name\n";

#    die "Trying to pop unknown $type $name"
#            unless $C->{$type}{$name};
    my $current = pop @{ $S->{current} };
    $name =~ s/\s+$//;
    $name =~ s(/.+$)();

    die "Closing $type $name that was never open"
        unless $current->{__name};

    # Missing *CloseUI
    die "Current $type is $current->{__name}, not $name"
            unless $current->{__name} eq $name;
}

############################################################################
## Introspection

our $AUTOLOAD;
sub AUTOLOAD
{
    my $self = shift;
    $AUTOLOAD =~ s/^PostScript::PPD:://;
    return if $AUTOLOAD eq 'DESTROY';
    return $self->get( $self, $AUTOLOAD, @_ );
}

sub get
{
    my( $self, $D, $name, $subkey ) = @_;
    if( @_ == 2 ) {
        $name = $D;
        $D = $self;
    }

    return unless exists $D->{$name};
    my $ret = $D->{$name};
    if( ref $ret ) {
        if( not $subkey and 'HASH' eq ref $ret and $ret->{"_"} ) {
            $subkey = "_";
        }
        if( $subkey ) {
            $D = $ret;
            $name = $subkey;
            $ret = $D->{ $name };
        }
        $ret = $self->__mk_subkey( $ret, $D, $name ) if 'HASH' eq ref $ret;
    }
    return $ret;
}

sub __mk_subkey
{
    my( $self, $value, $parent, $subkey ) = @_;
    return PostScript::PPD::Subkey->new( $value, ($parent||$self), $subkey );
}

sub Group
{
    my( $self, $name ) = @_;
    if( $name eq '_default' ) {
        my $ret = dclone $self;
        return $self->__mk_subkey( $ret, $self, $name );
    }
    return $self->get( $self->{group}, $name );
}

sub Groups
{
    my( $self ) = @_;
    my @ret = @{ $self->{__group_sorted}||[] };
    unshift @ret, '_default' if $self->{__UI_sorted};
    return @ret if wantarray;
    return \@ret;
}

############################################################################
package PostScript::PPD::Subkey;

use strict;
use warnings;
use Carp;
use Data::Dumper;

use overload '""' => \&as_string,
    fallback => 1;

sub new
{
    my( $package, $data, $parent, $subkey ) = @_;
    my $self = bless { %$data }, $package;
    $self->{__parent} = $parent;
    $self->{__subkey} = $subkey;
    confess "Need a subkey" unless defined $subkey;
    return $self;
}

sub default
{
    my( $self ) = @_;
    die Dumper $self unless $self->{__subkey};
    return $self->{__parent}->get( "Default$self->{__subkey}" );
}

sub as_string
{
    my( $self ) = @_;
    return $self->{value} if $self->{value};
    return $self;
}

sub name
{
    my( $self ) = @_;
    return $self->{__name};
}

sub text
{
    my( $self ) = @_;
    return $self->{__text};
}

sub option
{
    my( $self ) = @_;
    return $self->{__option};
}



sub list
{
    my( $self ) = @_;
    return $self->{__sorted} unless wantarray;
    return @{ $self->{__sorted} };
}

sub sorted_list
{
    my( $self ) = @_;
    my @ret = sort { $self->{$a}{__text} cmp $self->{$b}{__text} }
                    @{ $self->{__sorted} };
}

our $AUTOLOAD;
sub AUTOLOAD
{
    my $self = shift;
    $AUTOLOAD =~ s/^PostScript::PPD::Subkey:://;
    return if $AUTOLOAD eq 'DESTROY';
    return $self->get( $self, $AUTOLOAD, @_ );
}

sub UIs
{
    my( $self ) = @_;
    return unless $self->{__UI_sorted};
    return @{ $self->{__UI_sorted} } if wantarray;
    return [ @{ $self->{__UI_sorted} } ];
}

sub UI
{
    my( $self, $name, $subkey ) = @_;
    return $self->get( $self->{UI}, $name, $subkey );
}

sub get
{
    my( $self, $D, $name, $subkey ) = @_;
    if( @_ == 2 ) {
        $name = $D;
        $D = $self;
    }

    if( $name =~ s/^UI\.// ) {
        $D = $self->{UI};
    }

    return unless exists $D->{$name};
    my $ret = $D->{$name};
    if( ref $ret ) {
        if( $subkey ) {
            $ret = $ret->{ $subkey };
        }
        $ret = $self->__mk_subkey( $ret, $D, $name ) if 'HASH' eq ref $ret;
    }
    return $ret;
}

sub __mk_subkey
{
    my( $self, $value, $parent, $subkey ) = @_;
    return PostScript::PPD::Subkey->new( $value, ($parent||$self), $subkey );
}

sub Dump
{
    my( $self ) = @_;
    local $self->{__parent} = $self->{__parent}{__name};
    return Dumper $self;
}


1;
__END__