Image-Xbm-1.11/0000755000175000017500000000000014714167225012553 5ustar eserteeserteImage-Xbm-1.11/META.json0000644000175000017500000000221314714167225014172 0ustar eserteeserte{ "abstract" : "Load, create, manipulate and save xbm image files.", "author" : [ "Mark Summerfield " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.64, CPAN::Meta::Converter version 2.150010", "license" : [ "unknown" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Image-Xbm", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "File::Temp" : "0", "Image::Base" : "1.06", "Test::More" : "0" } } }, "release_status" : "stable", "resources" : { "repository" : { "type" : "git", "url" : "git://github.com/eserte/Image-Xbm.git" } }, "version" : "1.11", "x_serialization_backend" : "JSON::PP version 4.07" } Image-Xbm-1.11/MANIFEST.SKIP0000644000175000017500000000224412663145505014451 0ustar eserteeserte #!start included /usr/perl5.20.2p/lib/site_perl/5.20.2/ExtUtils/MANIFEST.SKIP # Avoid version control files. \bRCS\b \bCVS\b \bSCCS\b ,v$ \B\.svn\b \B\.git\b \B\.gitignore\b \b_darcs\b \B\.cvsignore$ # Avoid VMS specific MakeMaker generated files \bDescrip.MMS$ \bDESCRIP.MMS$ \bdescrip.mms$ # Avoid Makemaker generated and utility files. \bMANIFEST\.bak \bMakefile$ \bblib/ \bMakeMaker-\d \bpm_to_blib\.ts$ \bpm_to_blib$ \bblibdirs\.ts$ # 6.18 through 6.25 generated this \b_eumm/ # 7.05_05 and above # Avoid Module::Build generated and utility files. \bBuild$ \b_build/ \bBuild.bat$ \bBuild.COM$ \bBUILD.COM$ \bbuild.com$ # and Module::Build::Tiny generated files \b_build_params$ # Avoid temp and backup files. ~$ \.old$ \#$ \b\.# \.bak$ \.tmp$ \.# \.rej$ \..*\.sw.?$ # Avoid OS-specific files/dirs # Mac OSX metadata \B\.DS_Store # Mac OSX SMB mount metadata files \B\._ # Avoid Devel::Cover and Devel::CoverX::Covered files. \bcover_db\b \bcovered\b # Avoid prove files \B\.prove$ # Avoid MYMETA files ^MYMETA\. #!end included /usr/perl5.20.2p/lib/site_perl/5.20.2/ExtUtils/MANIFEST.SKIP ^\.travis\.yml$ ^appveyor\.yml$ ^Image-Xbm-[0-9.]+\.tar\.gz$ Image-Xbm-1.11/Xbm.pm0000644000175000017500000005150014714166506013641 0ustar eserteesertepackage Image::Xbm ; # Documented at the __END__ use strict ; use vars qw( $VERSION @ISA ) ; $VERSION = '1.11' ; 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' ) ; if (defined $file and not $self->{-bits}) { $self->load if ref $file or -r $file; } 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]?)\b/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 which provides additional manipulation functionality, e.g. C. See the C pod for information on adding your own functionality to all the C 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 Cing and Cing, 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 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 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 and C 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 and C 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, default is '#'. This is a class attribute accessible from the class or an object via C and C. =item C<-unsetch> The character to print set bits as when using C, default is '-'. This is a class attribute accessible from the class or an object via C and C. =item C<-sethotch> The character to print set bits as when using C, default is 'H'. This is a class attribute accessible from the class or an object via C and C. =item C<-unsethotch> The character to print set bits as when using C, default is 'h'. This is a class attribute accessible from the class or an object via C and C. =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 Cting the C<-setch> and C<-unsetch> characters. If you give C 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 2024/11/10 Allow filehandles in new() 2016/02/23 (Slaven Rezic) Make sure macro/variable names are always sane. More strict parsing of bits. 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 - please include the word 'xbm' in the subject line. =head1 COPYRIGHT Copyright (c) Mark Summerfield 2000. All Rights Reserved. This module may be used/distributed/modified under the LGPL. =cut Image-Xbm-1.11/META.yml0000644000175000017500000000126014714167225014023 0ustar eserteeserte--- abstract: 'Load, create, manipulate and save xbm image files.' author: - 'Mark Summerfield ' build_requires: ExtUtils::MakeMaker: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.64, CPAN::Meta::Converter version 2.150010' license: unknown meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Image-Xbm no_index: directory: - t - inc requires: File::Temp: '0' Image::Base: '1.06' Test::More: '0' resources: repository: git://github.com/eserte/Image-Xbm.git version: '1.11' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Image-Xbm-1.11/MANIFEST0000644000175000017500000000037114714167225013705 0ustar eserteeserteXbm.pm t/xbm.t t/xbm-badfile.t Changes MANIFEST MANIFEST.SKIP Makefile.PL README META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Image-Xbm-1.11/README0000644000175000017500000002114214714166625013436 0ustar eserteeserte=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 which provides additional manipulation functionality, e.g. C. See the C pod for information on adding your own functionality to all the C 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 Cing and Cing, 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 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 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 and C 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 and C 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, default is '#'. This is a class attribute accessible from the class or an object via C and C. =item C<-unsetch> The character to print set bits as when using C, default is '-'. This is a class attribute accessible from the class or an object via C and C. =item C<-sethotch> The character to print set bits as when using C, default is 'H'. This is a class attribute accessible from the class or an object via C and C. =item C<-unsethotch> The character to print set bits as when using C, default is 'h'. This is a class attribute accessible from the class or an object via C and C. =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 Cting the C<-setch> and C<-unsetch> characters. If you give C 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 2024/11/10 Allow filehandles in new() 2016/02/23 (Slaven Rezic) Make sure macro/variable names are always sane. More strict parsing of bits. 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 - please include the word 'xbm' in the subject line. =head1 COPYRIGHT Copyright (c) Mark Summerfield 2000. All Rights Reserved. This module may be used/distributed/modified under the LGPL. =cut Image-Xbm-1.11/Changes0000644000175000017500000000047114714166410014043 0ustar eserteeserteRevision history for Image::Xbm. 1.11 2024-11-10 - allow filehandles in new (GH PR #2) 1.10 2016-02-23 - make sure macro/variable names are always sane - more strict parsing of bits 1.09 2015-10-05 - test script modernization and fix for Windows (RT #97600) - distribution with META files (RT #107480) Image-Xbm-1.11/Makefile.PL0000644000175000017500000000251214714166760014530 0ustar eserteeserteuse strict ; use ExtUtils::MakeMaker ; my $is_devel_host = defined $ENV{USER} && $ENV{USER} eq 'eserte' && ($^O =~ /bsd/i || $ENV{PERL_RELEASE_READY}) && -f "../../perl.release.mk"; my $eumm_recent_enough = $ExtUtils::MakeMaker::VERSION >= 6.54 ; if (!$eumm_recent_enough) { *MY::dist_core = sub { <<'EOF' ; dist : $(NOECHO) $(ECHO) "Sorry, use a newer EUMM!" EOF } ; } WriteMakefile( 'NAME' => 'Image::Xbm', 'VERSION_FROM' => 'Xbm.pm', # finds $VERSION 'DISTNAME' => 'Image-Xbm', ($] >= 5.005 ? ( ABSTRACT => 'Load, create, manipulate and save xbm image files.', AUTHOR => 'Mark Summerfield ', ) : () ), 'LIBS' => [''], # e.g., '-lm' 'DEFINE' => '', # e.g., '-DHAVE_SOMETHING' 'INC' => '', # e.g., '-I/usr/include/other' 'PREREQ_PM' => { 'Image::Base' => '1.06', 'Test::More' => 0, 'File::Temp' => 0, }, ($eumm_recent_enough ? (META_ADD => { resources => { repository => 'git://github.com/eserte/Image-Xbm.git' } }) : ()), ) ; sub MY::postamble { my $postamble = '' ; if ($is_devel_host) { $postamble .= <<'EOF' ; PERL_TEST_DISTRIBUTION_CHANGES=yes .include "../../perl.release.mk" .include "../../perl.git.mk" EOF } $postamble ; } Image-Xbm-1.11/t/0000755000175000017500000000000014714167225013016 5ustar eserteeserteImage-Xbm-1.11/t/xbm.t0000755000175000017500000000352514714166263014002 0ustar eserteeserte#!/usr/bin/perl -w # Copyright (c) 2000 Mark Summerfield. All Rights Reserved. # May be used/distributed under the GPL. use strict ; use File::Temp qw(tempfile); use Test::More tests => 19 ; use Image::Xbm ; pass 'loaded module' ; my(undef, $fp) = tempfile('image-xbm-XXXXXXXX', SUFFIX => '.xbm', UNLINK => 1); my $i = Image::Xbm->new_from_string( "#####\n#---#\n-###-\n--#--\n--#--\n#####" ) ; isa_ok $i, 'Image::Xbm' ; is $i->as_binstring, '11111100010111000100001001111100', 'expected new_from_string result' ; my $j = $i->new ; isa_ok $j, 'Image::Xbm' ; is $j->as_binstring, '11111100010111000100001001111100', 'expected clone result' ; $i->save( $fp ) ; ok -e $fp, 'saved xbm file exists' ; my $s = $i->serialise ; ok $s, 'call serialiase' ; my $k = Image::Xbm->new_from_serialised( $s ) ; isa_ok $k, 'Image::Xbm' ; ok $k->is_equal( $i ), 'new_from_serialised is_equal' ; $i = undef ; ok !defined $i, 'destroy image' ; $i = Image::Xbm->new( -file => $fp ) ; isa_ok $i, 'Image::Xbm' ; is $i->as_binstring, '11111100010111000100001001111100', 'loaded image from file' ; is $i->get( -file ), $fp, '-file accessor' ; is $i->get( -width ), 5, '-width accessor' ; is $i->get( -height ), 6, '-height accessor' ; { open my $fh, '<', "$fp" or die "Can't open previously created temporary file $fp: $!" ; my $ixbm = Image::Xbm->new( -file => $fh ) ; isa_ok $i, 'Image::Xbm' ; is $i->as_binstring, '11111100010111000100001001111100', 'loaded image from filehandle' ; } { open my $fh, '<', "$fp" or die "Can't open previously created temporary file $fp: $!" ; my $xbm_string = do { local $/; <$fh> } ; open my $scalar_fh, '<', \$xbm_string or die $! ; my $ixbm = Image::Xbm->new( -file => $scalar_fh ) ; isa_ok $i, 'Image::Xbm' ; is $i->as_binstring, '11111100010111000100001001111100', 'loaded image from scalar filehandle' ; } Image-Xbm-1.11/t/xbm-badfile.t0000644000175000017500000000316012663145156015355 0ustar eserteeserte#!/usr/bin/perl -w # -*- cperl -*- # Copyright (C) 2016 Slaven Rezic. All rights reserved. # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. use strict; use File::Temp qw(tempfile); use Test::More 'no_plan'; use Image::Xbm; for my $tempfile_template ( 'image-xbm-0x00-XXXXXXXX', # filename contains valid hex value, causing extra wrong bits 'image-xbm-file with spaces-XXXXXXXX', # spaces are properly transliterated 'image-xbm-file^-with-^special-XXXXXXXX', # other special characters are properly transliterated ) { my(undef, $fp) = tempfile($tempfile_template, SUFFIX => '.xbm', UNLINK => 1); my $i1 = Image::Xbm->new_from_string("#####\n#---#\n-###-\n--#--\n--#--\n#####"); $i1->save($fp); my($width_name, $height_name, $bits_name); { open my $fh, '<', $fp or die $!; while(<$fh>) { if (/^#define\s+(.*_width)\s+5$/) { $width_name = $1; } elsif (/^#define\s+(.*_height)\s+6$/) { $height_name = $1; } elsif (/^static\s+unsigned\s+char\s+(.*_bits)\[\]\s+=\s+\{$/) { $bits_name = $1; } } } like $width_name, qr{^image_xbm_[A-Za-z0-9_]+_width}, 'width define without strange characters'; like $height_name, qr{^image_xbm_[A-Za-z0-9_]+_height}, 'height define without strange characters'; like $bits_name, qr{^image_xbm_[A-Za-z0-9_]+_bits}, 'bits variable without strange characters'; my $i2 = Image::Xbm->new(-file => $fp); is $i2->as_binstring, $i1->as_binstring, "loaded image from file has same bits (tempfile template: $tempfile_template)"; unlink $fp; } __END__