Glass Manager

🌐 ROOT / usr / share / perl5 / vendor_perl / Image

✏️ EDITING: Xbm.pm

package Image::Xbm ;    # Documented at the __END__

# $Id: Xbm.pm,v 1.19 2000/11/09 19:05:31 mark Exp mark $

use strict ;

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

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__

=head1 NAME

Image::Xbm - Load, create, manipulate and save xbm image files.

=head1 SYNOPSIS

use Image::Xbm ;

my $j = Image::Xbm->new( -file, 'balArrow.xbm' ) ;

my $i = Image::Xbm->new( -width => 10, -height => 16 ) ;

my $h = $i->new ; # Copy of $i

my $p = Image::Xbm->new_from_string( "###\n#-#\n###" ) ;

my $q = $p->new_from_string( "H##", "#-#", "###" ) ;

my $s = $q->serialse ; # Compresses a little too.
    my $t = Image::Xbm->new_from_serialsed( $s ) ;

$i->xybit( 5, 8, 1 ) ;           # Set a bit
    print '1' if $i->xybit( 9, 3 ) ; # Get a bit
    print $i->xy( 4, 5 ) ;           # Will print black or white

$i->vec( 24, 0 ) ;            # Set a bit using a vector offset
    print '1' if $i->vec( 24 ) ;  # Get a bit using a vector offset

print $i->get( -width ) ;     # Get and set object and class attributes
    $i->set( -height, 15 ) ;

$i->load( 'test.xbm' ) ;
    $i->save ;

print "equal\n" if $i->is_equal( $j ) ;

print $j->as_string ;

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

print $j->as_binstring ;

1111101110001110001001001000100000010000

View an xbm file from the command line:

% perl -MImage::Xbm -e'print Image::Xbm->new(-file,shift)->as_string' file

Create an xbm file from the command line:

% perl -MImage::Xbm -e'Image::Xbm->new_from_string("###\n#-#\n-#-")->save("test.xbm")'

=head1 DESCRIPTION

This class module provides basic load, manipulate and save functionality for
the xbm file format. It inherits from C<Image::Base> which provides additional
manipulation functionality, e.g. C<new_from_image()>. See the C<Image::Base>
pod for information on adding your own functionality to all the C<Image::Base>
derived classes.

=head2 new()

my $i = Image::Xbm->new( -file => 'test.xbm' ) ;
    my $j = Image::Xbm->new( -width => 12, -height => 18 ) ;
    my $k = $i->new ;

We can create a new xbm image by reading in a file, or by creating an image
from scratch (all the bits are unset by default), or by copying an image
object that we created earlier.

If we set C<-file> then all the other arguments are ignored (since they're
taken from the file). If we don't specify a file, C<-width> and C<-height> are
mandatory.

=over

=item C<-file>

The name of the file to read when creating the image. May contain a full path.
This is also the default name used for C<load>ing and C<save>ing, though it
can be overridden when you load or save.

=item C<-width>

The width of the image; taken from the file or set when the object is created;
read-only.

=item C<-height>

The height of the image; taken from the file or set when the object is created;
read-only.

=item C<-hotx>

The x-coord of the image's hotspot; taken from the file or set when the object
is created. Set to -1 if there is no hotspot.

=item C<-hoty>

The y-coord of the image's hotspot; taken from the file or set when the object
is created. Set to -1 if there is no hotspot.

=item C<-bits>

The bit vector that stores the image; read-only.

=back

=head2 new_from_string()

my $p = Image::Xbm->new_from_string( "###\n#-#\n###" ) ;
    my $q = $p->new_from_string( "H##", "#-#", "###" ) ;
    my $r = $p->new_from_string( $p->as_string ) ;

Create a new bitmap from a string or from an array or list of strings. If you
want to use different characters you can:

Image::Xbm->set( -setch => 'X', -unsetch => ' ' ) ;
    my $s = $p->new_from_string( "XXX", "X X", "XhX" ) ;

You can also specify a hotspot by making one of the characters a 'H' (set bit
hotspot) or 'h' (unset bit hotspot) -- you can use different characters by
setting C<-sethotch> and C<-unsethotch> respectively.

=head2 new_from_serialised()

my $i = Image::Xbm->new_from_serialised( $s ) ;

Creates an image from a string created with the C<serialse()> method. Since
such strings are a little more compressed than xbm files or Image::Xbm objects
they might be useful if storing a lot of bitmaps, or for transferring bitmaps
over comms links.

=head2 serialise()

my $s = $i->serialise ;

Creates a string version of the image which can be completed recreated using
the C<new_from_serialised> method.

=head2 get()
    
    my $width = $i->get( -width ) ;
    my( $hotx, $hoty ) = $i->get( -hotx, -hoty ) ;

Get any of the object's attributes. Multiple attributes may be requested in a
single call.

See C<xy> and C<vec> to get/set bits of the image itself.

=head2 set()

$i->set( -hotx => 120, -hoty => 32 ) ;

Set any of the object's attributes. Multiple attributes may be set in a single
call. Except for C<-setch> and C<-unsetch> all attributes are object
attributes; some attributes are read-only.

See C<xy> and C<vec> to get/set bits of the image itself.

=head2 class attributes

Image::Xbm->set( -setch => 'X' ) ;
    $i->set( -setch => '@', -unsetch => '*' ) ;

=over

=item C<-setch>

The character to print set bits as when using C<as_string>, default is '#'.
This is a class attribute accessible from the class or an object via C<get>
and C<set>.

=item C<-unsetch>

The character to print set bits as when using C<as_string>, default is '-'.
This is a class attribute accessible from the class or an object via C<get>
and C<set>.

=item C<-sethotch>

The character to print set bits as when using C<as_string>, default is 'H'.
This is a class attribute accessible from the class or an object via C<get>
and C<set>.

=item C<-unsethotch>

The character to print set bits as when using C<as_string>, default is 'h'.
This is a class attribute accessible from the class or an object via C<get>
and C<set>.

=back

=head2 xybit()

$i->xy( 4, 11, 1 ) ;      # Set the bit at point 4,11
    my $v = $i->xy( 9, 17 ) ; # Get the bit at point 9,17

Get/set bits using x, y coordinates; coordinates start at 0.

=head2 xy()

$i->xy( 4, 11, 'black' ) ;  # Set the bit from a colour at point 4,11
    my $v = $i->xy( 9, 17 ) ;   # Get the bit as a colour at point 9,17

Get/set bits using colours using x, y coordinates; coordinates start at 0.

If set with a colour of 'black' or a numeric value > 0 or a string not
matching /^#0+$/ then the bit will be set, otherwise it will be cleared.

If you get a colour you will always get 'black' or 'white'.

=head2 vec()

$i->vec( 43, 0 ) ;      # Unset the bit at offset 43
    my $v = $i->vec( 87 ) ; # Get the bit at offset 87

Get/set bits using vector offsets; offsets start at 0.

=head2 load()

$i->load ;
    $i->load( 'test.xbm' ) ;

Load the image whose name is given, or if none is given load the image whose
name is in the C<-file> attribute.

=head2 save()

$i->save ;
    $i->save( 'test.xbm' ) ;

Save the image using the name given, or if none is given save the image using
the name in the C<-file> attribute. The image is saved in xbm format, e.g.

#define test_width 6
    #define test_height 6
    static unsigned char test_bits[] = {
     0x1f, 0x07, 0x07, 0x09, 0x11, 0x20 } ;

=head2 is_equal()

print "equal\n" if $i->is_equal( $j ) ;

Returns true (1) if the images are equal, false (0) otherwise. Note that
hotspots and filenames are ignored, so we compare width, height and the actual
bits only.

=head2 as_string()

print $i->as_string ;

Returns the image as a string, e.g.

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

The characters used may be changed by C<set>ting the C<-setch> and C<-unsetch>
characters. If you give C<as_string> a parameter it will print out the hotspot
if present using C<-sethotch> or C<-unsethotch> as appropriate, e.g.

print $n->as_string( 1 ) ;

H##
    #-#
    ###

=head2 as_binstring()

print $i->as_binstring ;

Returns the image as a string of 0's and 1's, e.g.

1111101110001110001001001000100000010000

=head1 CHANGES

2000/11/09

Added Jerrad Pierce's patch to allow load() to accept filehandles or strings;
will document in next release.

2000/05/05

Added new_from_serialised() and serialise() methods.

2000/05/04

Made xy() compatible with Image::Base, use xybit() for the earlier
functionality.

2000/05/01

Improved speed of vec(), xy() and as_string().

Tried use integer to improve speed but according to Benchmark it made the code
slower so I dropped it; interestingly perl 5.6.0 was around 25% slower than
perl 5.004 with and without use integer.

2000/04/30

Created.

=head1 AUTHOR

Mark Summerfield. I can be contacted as <summer@perlpress.com> -
please include the word 'xbm' in the subject line.

=head1 COPYRIGHT

This module may be used/distributed/modified under the LGPL.

=cut

CANCEL