File Coverage

blib/lib/Image/Xbm.pm

Criterion	Covered	Total	%
statement	177	214	82.7
branch	64	116	55.1
condition	31	95	32.6
subroutine	17	22	77.2
pod	14	14	100.0
total	303	461	65.7

package Image::Xbm ;    # Documented at the __END__

use strict ;

use vars qw( $VERSION @ISA ) ;
$VERSION = '1.09' ;

use Image::Base ;

@ISA = qw( Image::Base ) ;

use Carp qw( carp croak ) ;
use Symbol () ;


# Private class data

my $DEF_SIZE = 8192 ;
my $UNSET    =   -1 ;
my $MASK     =    7 ;
my $ROWS     =   12 ;

# If you inherit don't clobber these fields!
my @FIELD = qw( -file -width -height -hotx -hoty -bits
                -setch -unsetch -sethotch -unsethotch ) ;

my @MASK  = ( 0x01, 0x02, 0x04, 0x08, 0x10, 0x20, 0x40, 0x80 ) ;


### Private methods
#
# _class_get    class   object
# _class_set    class   object
# _get                  object inherited
# _set                  object inherited

{
    my %Ch = ( -setch    => '#', -unsetch    => '-',
               -sethotch => 'H', -unsethotch => 'h' ) ;


    sub _class_get { # Class and object method
        my $self  = shift ;
        my $class = ref( $self ) || $self ;

        $Ch{shift()} ;
    }


    sub _class_set { # Class and object method
        my $self  = shift ;
        my $class = ref( $self ) || $self ;

        my $field = shift ;
        my $val   = shift ;

        croak "_class_set() `$field' has no value" unless defined $val ;

        $Ch{$field} = $val ;
     }
}


sub DESTROY {
    ; # Save's time
}


### Public methods

sub new_from_string { # Class and object method
    my $self  = shift ;
    my $class = ref( $self ) || $self ;

    my @line ;

    if( @_ > 1 ) {
        chomp( @line = @_ ) ;
    }
    else {
        @line = split /\n/, $_[0] ;
    }

    my( $setch, $sethotch, $unsethotch ) =
        $class->get( '-setch', '-sethotch', '-unsethotch' ) ;

    my $width ;
    my $y = 0 ;

    $self = $class->new( '-width' => $DEF_SIZE, '-height' => $DEF_SIZE ) ;

    foreach my $line ( @line ) {
        next if $line =~ /^\s*$/ ;
        unless( defined $width ) {
            $width = length $line ;
            $self->_set( '-width' => $width ) ;
        }
        for( my $x = 0 ; $x < $width ; $x++ ) {
            my $c = substr( $line, $x, 1 ) ;
            $self->xybit( $x, $y, $c eq $setch ? 1 : $c eq $sethotch ? 1 : 0 ) ;
            $self->set( '-hotx' => $x, '-hoty' => $y )
            if $c eq $sethotch or $c eq $unsethotch ;
        }
        $y++ ;
    }

    $self->_set( '-height' => $y ) ;

    $self ;
}


sub new { # Class and object method
    my $self  = shift ;
    my $class = ref( $self ) || $self ;
    my $obj   = ref $self ? $self : undef ;
    my %arg   = @_ ;

    # Defaults
    $self = {
            '-hotx' => $UNSET,
            '-hoty' => $UNSET,
            '-bits' => '',
        } ;

    bless $self, $class ;

    # If $obj->new copy original object's data
    if( defined $obj ) {
        foreach my $field ( @FIELD ) {
            $self->_set( $field, $obj->get( $field ) ) ;
        }
    }

    # Any options specified override
    foreach my $field ( @FIELD ) {
        $self->_set( $field, $arg{$field} ) if defined $arg{$field} ;
    }

    my $file = $self->get( '-file' ) ;
    $self->load if defined $file and -r $file and not $self->{'-bits'} ;

    croak "new() `$file' not found or unreadable"
    if defined $file and not defined $self->get( '-width' ) ;


    foreach my $field ( qw( -width -height ) ) {
        croak "new() $field must be set" unless defined $self->get( $field ) ;
    }

    $self ;
}


sub new_from_serialised { # Class and object method
    my $self       = shift ;
    my $class      = ref( $self ) || $self ;
    my $serialised = shift ;

    $self = $class->new( '-width' => $DEF_SIZE, '-height' => $DEF_SIZE ) ;

    my( $flen, $blen, $width, $height, $hotx, $hoty, $data ) =
        unpack "n N n n n n A*", $serialised ;

    my( $file, $bits ) = unpack "A$flen A$blen", $data ;

    $self->_set( '-file'   => $file ) ;
    $self->_set( '-width'  => $width ) ;
    $self->_set( '-height' => $height ) ;
    $self->_set( '-hotx'   => $hotx > $width  ? $UNSET : $hotx ) ;
    $self->_set( '-hoty'   => $hoty > $height ? $UNSET : $hoty ) ;
    $self->_set( '-bits'   => $bits ) ;

    $self ;
}


sub serialise { # Object method
    my $self  = shift ;
#    my $class = ref( $self ) || $self ;

    my( $file, $bits ) = $self->get( -file, -bits ) ;
    my $flen = length( $file ) ;
    my $blen = length( $bits ) ;

    pack "n N n n n n A$flen A$blen",
        $flen, $blen,
        $self->get( -width ), $self->get( -height ),
        $self->get( -hotx ),  $self->get( -hoty ),
        $file, $bits ;
}


sub get { # Object method (and class method for class attributes)
    my $self  = shift ;
    my $class = ref( $self ) || $self ;

    my @result ;

    while( @_ ) {
        my $field = shift ;

        if( $field =~ /^-(?:un)?set(?:hot)?ch$/o ) {
            push @result, $class->_class_get( $field ) ;
        }
        else {
            push @result, $self->_get( $field ) ;
        }
    }

    wantarray ? @result : shift @result ;
}


sub set { # Object method (and class method for class attributes)
    my $self  = shift ;
    my $class = ref( $self ) || $self ;

    while( @_ ) {
        my $field = shift ;
        my $val   = shift ;

        carp "set() -field has no value" unless defined $val ;
        carp "set() $field is read-only"
        if $field eq '-bits' or $field eq '-width' or $field eq '-height' ;
        carp "set() -hotx `$val' is out of range"
        if $field eq '-hotx' and ( $val < $UNSET or $val >= $self->get( '-width' ) ) ;
        carp "set() -hoty `$val' is out of range"
        if $field eq '-hoty' and ( $val < $UNSET or $val >= $self->get( '-height' ) ) ;

        if( $field =~ /^-(?:un)?set(?:hot)?ch$/o ) {
            $class->_class_set( $field, $val ) ;
        }
        else {
            $self->_set( $field, $val ) ;
        }
    }
}


sub xybit { # Object method
    my $self  = shift ;
#    my $class = ref( $self ) || $self ;

    my( $x, $y, $val ) = @_ ;

    # No range checking
    my $offset = ( $y * $self->get( '-width' ) ) + $x ;

    if( defined $val ) {
        CORE::vec( $self->{'-bits'}, $offset, 1 ) = $val ;
    }
    else {
        CORE::vec( $self->{'-bits'}, $offset, 1 ) ;
    }
}


sub xy { # Object method
    my $self  = shift ;
#    my $class = ref( $self ) || $self ;

    my( $x, $y, $val ) = @_ ;

    # No range checking
    my $offset = ( $y * $self->get( '-width' ) ) + $x ;

    if( defined $val ) {
        $val = 1 if ( $val =~ /^\d+$/ and $val >= 1 ) or
                    ( lc $val eq 'black' )            or
                    ( $val =~ /^#(\d+)$/ and hex $1 ) ;
        CORE::vec( $self->{'-bits'}, $offset, 1 ) = $val ;
    }
    else {
        CORE::vec( $self->{'-bits'}, $offset, 1 ) ? 'black' : 'white' ;
    }
}


sub vec { # Object method
    my $self  = shift ;
#    my $class = ref( $self ) || $self ;

    my( $offset, $val ) = @_ ;

    # No range checking
    if( defined $val ) {
        CORE::vec( $self->{'-bits'}, $offset, 1 ) = $val ;
    }
    else {
        CORE::vec( $self->{'-bits'}, $offset, 1 ) ;
    }
}


sub is_equal { # Object method
    my $self  = shift ;
    my $class = ref( $self ) || $self ;
    my $obj   = shift ;

    croak "is_equal() can only compare $class objects"
    unless ref $obj and $obj->isa( __PACKAGE__ ) ;

    # We ignore -file, -hotx and -hoty when we consider equality.
    return 0 if $self->get( '-width' )  != $obj->get( '-width' )  or
                $self->get( '-height' ) != $obj->get( '-height' ) or
                $self->get( '-bits' )   ne $obj->get( '-bits' ) ;

    1 ;
}


sub as_string { # Object method
    my $self  = shift ;
#    my $class = ref( $self ) || $self ;

    my $hotch = shift || 0 ;

    my( $setch,    $unsetch,
        $sethotch, $unsethotch,
        $hotx,     $hoty,
        $bits,
        $width,    $height ) =
            $self->get(
                '-setch',    '-unsetch',
                '-sethotch', '-unsethotch',
                '-hotx',     '-hoty',
                '-bits',
                '-width',    '-height' ) ;

    my $bitindex = 0 ;
    my $string   = '' ;

    for( my $y = 0 ; $y < $height ; $y++ ) {
        for( my $x = 0 ; $x < $width ; $x++ ) {
            if( $hotch and $x == $hotx and $y == $hoty ) {
                $string .= CORE::vec( $bits, $bitindex, 1 ) ?
                                $sethotch : $unsethotch ;
            }
            else {
                $string .= CORE::vec( $bits, $bitindex, 1 ) ?
                                $setch : $unsetch ;
            }
            $bitindex++ ;
        }
        $string .= "\n" ;
    }

    $string ;
}


sub as_binstring { # Object method
    my $self  = shift ;
#    my $class = ref( $self ) || $self ;

    unpack "b*", $self->get( '-bits' ) ;
}


# The algorithm is based on the one used in Thomas Boutell's GD library.
sub load { # Object method
    my $self  = shift ;
#    my $class = ref( $self ) || $self ;

    my $file  = shift() || $self->get( '-file' ) ;

    croak "load() no file specified" unless $file ;

    $self->set( '-file', $file ) ;

    my( @val, $width, $height, $hotx, $hoty ) ;
    local $_ ;
    my $fh = Symbol::gensym ;

    if( not ref $file ) {
        open $fh, $file or croak "load() failed to open `$file': $!" ;
    }
    elsif( ref($file) eq 'SCALAR' ) {
        require IO::String;
        $fh = IO::String->new( $$file );
    }
    else {
        seek($file, 0, 0) or croak "load() can't rewind handle for `$file': $!";
        $fh = $file;
    }

    while( <$fh> ) {
        $width  = $1, next if /#define.*width\s+(\d+)/o ;
        $height = $1, next if /#define.*height\s+(\d+)/o ;
        $hotx   = $1, next if /#define.*_x_hot\s+(\d+)/o ;
        $hoty   = $1, next if /#define.*_y_hot\s+(\d+)/o ;
        push @val, map { hex } /0[xX]([A-Fa-f\d][A-Fa-f\d]?)/g ;
    }
    croak "load() failed to find dimension(s) in `$file'"
    unless defined $width and defined $height ;

    close $fh or croak "load() failed to close `$file': $!" ;

    $self->_set( '-width',  $width ) ;
    $self->_set( '-height', $height ) ;
    $self->set( '-hotx',    defined $hotx ? $hotx : $UNSET ) ;
    $self->set( '-hoty',    defined $hoty ? $hoty : $UNSET ) ;

    my( $x, $y ) = ( 0, 0 ) ;
    my $bitindex = 0 ;
    my $bits     = '' ;
    BYTE:
    for( my $i = 0 ; ; $i++ ) {
        BIT:
        for( my $bit = 1 ; $bit <= 128 ; $bit <<= 1 ) {
            CORE::vec( $bits, $bitindex++, 1 ) = ( $val[$i] & $bit ) ? 1 : 0 ;
            $x++ ;
            if( $x == $width ) {
                $x = 0 ;
                $y++ ;
                last BYTE if $y == $height ;
                last BIT ;
            }
        }
    }

    $self->_set( '-bits', $bits ) ;
}


# The algorithm is based on the X Consortium's bmtoa program.
sub save { # Object method
    my $self  = shift ;
#    my $class = ref( $self ) || $self ;

    my $file   = shift() || $self->get( '-file' ) ;

    croak "save() no file specified" unless $file ;

    $self->set( '-file', $file ) ;

    my( $width, $height, $hotx, $hoty ) =
        $self->get( '-width', '-height', '-hotx', '-hoty' ) ;

    my $MASK1  = $MASK + 1 ;
    my $ROWSn1 = $ROWS - 1 ;

    my $fh = Symbol::gensym ;
    open $fh, ">$file" or croak "save() failed to open `$file': $!" ;

    $file =~ s,^.*/,,o ;
    $file =~ s/\.xbm$//o ;
    $file =~ tr/[-_A-Za-z0-9]/_/c ;

    print $fh "#define ${file}_width $width\n#define ${file}_height $height\n" ;
    print $fh "#define ${file}_x_hot $hotx\n#define ${file}_y_hot $hoty\n"
    if $hotx > $UNSET and $hoty > $UNSET ;
    print $fh "static unsigned char ${file}_bits[] = {\n" ;

    my $padded = ( $width & $MASK ) != 0 ;
    my @char ;
    my $char = 0 ;
    for( my $y = 0 ; $y < $height ; $y++ ) {
        for( my $x = 0 ; $x < $width ; $x++ ) {
            my $mask = $x & $MASK ;
            $char[$char] = 0 unless defined $char[$char] ;
            $char[$char] |= $MASK[$mask] if $self->xybit( $x, $y ) ;
            $char++ if $mask == $MASK ;
        }
        $char++ if $padded ;
    }

    my $i = 0 ;
    my $bytes_per_char = ( $width + $MASK ) / $MASK1 ;
    foreach $char ( @char ) {
        printf $fh " 0x%02x", $char ;
        print  $fh "," unless $i == $#char ;
        print  $fh "\n" if $i % $ROWS == $ROWSn1 ;
        $i++ ;
    }
    print $fh " } ;\n";

    close $fh or croak "save() failed to close `$file': $!" ;
}


1 ;


__END__