1package File::Binary; 2 3# importage 4use strict; 5use Carp; 6use Config; 7use IO::File; 8use vars qw(@EXPORT_OK $VERSION $BIG_ENDIAN $LITTLE_ENDIAN $NATIVE_ENDIAN $AUTOLOAD $DEBUG); 9use Fcntl qw(:DEFAULT); 10 11$VERSION='1.7'; 12 13# for seekable stuff 14$DEBUG = 0; 15 16# set up some constants 17$BIG_ENDIAN = 2; 18$LITTLE_ENDIAN = 1; 19$NATIVE_ENDIAN = 0; 20 21# and export them 22@EXPORT_OK = qw($BIG_ENDIAN $LITTLE_ENDIAN $NATIVE_ENDIAN guess_endian); 23 24 25=head1 NAME 26 27File::Binary - Binary file reading module 28 29=head1 SYNOPSIS 30 31 use File::Binary qw($BIG_ENDIAN $LITTLE_ENDIAN $NATIVE_ENDIAN); 32 33 my $fb = File::Binary->new("myfile"); 34 35 $fb->get_ui8(); 36 $fb->get_ui16(); 37 $fb->get_ui32(); 38 $fb->get_si8(); 39 $fb->get_si16(); 40 $fb->get_si32(); 41 42 $fb->close(); 43 44 $fb->open(">newfile"); 45 46 $fb->put_ui8(255); 47 $fb->put_ui16(65535); 48 $fb->put_ui32(4294967295); 49 $fb->put_si8(-127); 50 $fb->put_si16(-32767); 51 $fb->put_si32(-2147483645); 52 53 $fb->close(); 54 55 56 $fb->open(IO::Scalar->new($somedata)); 57 $fb->set_endian($BIG_ENDIAN); # force endianness 58 59 # do what they say on the tin 60 $fb->seek($pos); 61 $fb->tell(); 62 63 # etc etc 64 65 66=head1 DESCRIPTION 67 68B<File::Binary> is a Binary file reading module, hence the name, 69and was originally used to write a suite of modules for manipulating 70Macromedia SWF files. 71 72However it's grown beyond that and now actually, err, works. 73And is generalised. And EVERYTHING! Yay! 74 75It has methods for reading and writing signed and unsigned 8, 16 and 7632 bit integers, at some point in the future I'll figure out a way of 77putting in methods for >32bit integers nicely but until then, patches 78welcome. 79 80It hasn't retained backwards compatability with the old version of this 81module for cleanliness sakes and also because the old interface was 82pretty braindead. 83 84=head1 METHODS 85 86=head2 new 87 88Pass in either a file name or something which isa an IO::Handle. 89 90=cut 91 92sub new { 93 my ($class, $file) = @_; 94 95 my $self = {}; 96 97 bless $self, $class; 98 99 $self->open($file); 100 $self->set_endian($NATIVE_ENDIAN); 101 102 103 return $self; 104} 105 106=head2 open 107 108Pass in either a file name or something which isa an IO::Handle. 109 110Will try and set binmode for the handle on if possible (i.e 111if the object has a C<binmode> method) otherwise you should do 112it yourself. 113 114=cut 115 116sub open { 117 my ($self, $file) = @_; 118 119 my $fh; 120 my $writeable = -1; 121 122 if (ref($file) =~ /^IO::/ && $file->isa('IO::Handle')) { 123 $fh = $file; 124 $writeable = 2; # read and write mode 125 } else { 126 $fh = IO::File->new($file) || die "No such file $file\n"; 127 if ($file =~ /^>/) { 128 $writeable = 1; 129 } elsif ($file =~ /^\+>/) { 130 $writeable=2; 131 } 132 } 133 $fh->binmode if $fh->can('binmode'); 134 135 $self->{_bitbuf} = ''; 136 $self->{_bitpos} = 0; 137 $self->{_fh} = $fh; 138 $self->{_fhpos} = 0; 139 $self->{_flush} = 1; 140 $self->{_writeable} = $writeable; 141 $self->{_is_seekable} = UNIVERSAL::isa($fh,'IO::Seekable')?1:0; 142 143 144 return $self; 145} 146 147=head2 seek 148 149Seek to a position. 150 151Return our current position. If our file handle is not 152B<ISA IO::Seekable> it will return 0 and, if 153B<$File::Binary::DEBUG> is set to 1, there will be a warning. 154 155You can optionally pass a whence option in the same way as 156the builtin Perl seek() method. It defaults to C<SEEK_SET>. 157 158Returns the current file position. 159 160 161=cut 162 163sub seek { 164 my $self = shift; 165 my $seek = shift; 166 my $whence = shift || SEEK_SET; 167 unless ($self->{_is_seekable}) { 168 carp "FH is not seekable" if $DEBUG; 169 return 0; 170 } 171 172 $self->{_fh}->seek($seek, $whence) if defined $seek; 173 $self->_init_bits(); 174 return $self->{_fh}->tell(); 175 176 177 178} 179 180=head2 tell 181 182Return our current position. If our file handle is not 183B<ISA IO::Seekable> then it will return 0 and, if 184B<$File::Binary::DEBUG> is set to 1, there will be a 185warning. 186 187=cut 188 189sub tell { 190 my $self = shift; 191 unless ($self->{_is_seekable}) { 192 carp "FH is not seekable" if $DEBUG; 193 return 0; 194 } 195 196 return $self->{_fh}->tell(); 197} 198 199 200 201=head2 set_flush 202 203To flush or not to flush. That is the question 204 205=cut 206 207sub set_flush { 208 my ($self, $flush) = @_; 209 210 $self->{_flush} = $flush; 211} 212 213 214=head2 set_endian 215 216Set the how the module reads files. The options are 217 218 $BIG_ENDIAN 219 $LITTLE_ENDIAN 220 $NATIVE_ENDIAN 221 222 223I<NATIVE> will deduce the endianess of the current system. 224 225=cut 226 227sub set_endian { 228 my ($self, $endian) = @_; 229 230 $endian ||= $NATIVE_ENDIAN; 231 232 $endian = guess_endian() if ($endian == $NATIVE_ENDIAN); 233 234 if ($endian == $BIG_ENDIAN) { 235 $self->{_ui16} = 'v'; 236 $self->{_ui32} = 'V'; 237 } else { 238 $self->{_ui16} = 'n'; 239 $self->{_ui32} = 'N'; 240 } 241 242 $self->{_endian} = $endian; 243 244} 245 246 247sub _init_bits { 248 my $self = shift; 249 250 if ($self->{_writeable}) { 251 $self->_init_bits_write(); 252 } else { 253 $self->_init_bits_read(); 254 } 255} 256 257 258sub _init_bits_write { 259 my $self = shift; 260 261 my $bits = $self->{'_bitbuf'}; 262 263 my $len = length($bits); 264 265 return if $len<=0; 266 267 $self->{'_bitbuf'} = ''; 268 $self->{_fh}->write(pack('B8', $bits.('0'x(8-$len)))); 269 270} 271 272sub _init_bits_read { 273 my $self = shift; 274 275 $self->{_pos} = 0; 276 $self->{_bits} = 0; 277 278} 279 280 281=head2 get_bytes 282 283Get an arbitary number of bytes from the file. 284 285=cut 286 287sub get_bytes { 288 my ($self, $bytes) = @_; 289 290 $bytes = int $bytes; 291 292 carp("Must be positive number") if ($bytes <1); 293 carp("This file has been opened in write mode.") if $self->{_writeable} == 1; 294 295 $self->_init_bits() if $self->{_flush}; 296 297 $self->{_fh}->read(my $data, $bytes); 298 299 $self->{_fhpos} += $bytes; 300 301 return $data; 302} 303 304 305=head2 put_bytes 306 307Write some bytes 308 309=cut 310 311sub put_bytes { 312 my ($self, $bytes) = @_; 313 314 315 carp("This file has been opened in read mode.") unless $self->{_writeable}; 316 317 ## TODO? 318 #$self->_init_bits; 319 $self->{_fh}->write($bytes); 320} 321 322 323 324 325# we could use POSIX::ceil here but I ph34r the POSIX lib 326sub _round { 327 my $num = shift || 0; 328 329 return int ($num + 0.5 * ($num <=> 0 ) ); 330} 331 332 333 334 335 336sub _get_num { 337 my ($self, $bytes, $template)=@_; 338 339 unpack $template, $self->get_bytes($bytes); 340} 341 342 343sub _put_num { 344 my ($self, $num, $template) = @_; 345 346 347 $self->put_bytes(pack($template, _round($num))); 348} 349 350 351 352## 8 bit 353 354=head2 get_ui8 get_si8 put_ui8 put_si8 355 356read or write signed or unsigned 8 bit integers 357 358=cut 359 360sub get_ui8 { 361 my $self = shift; 362 $self->_get_num(1, 'C'); 363} 364 365 366 367 368sub get_si8 { 369 my $self = shift; 370 $self->_get_num(1, 'c'); 371} 372 373 374 375sub put_ui8 { 376 my ($self,$num) = @_; 377 $self->_put_num($num, 'C'); 378} 379 380 381sub put_si8 { 382 my ($self,$num) = @_; 383 $self->_put_num($num, 'c'); 384 385} 386 387 388## 16 bit 389 390=head2 get_ui16 get_si16 put_ui16 put_si16 391 392read or write signed or unsigned 16 bit integers 393 394=cut 395 396sub get_ui16 { 397 my $self = shift; 398 $self->_get_num(2, $self->{_ui16}); 399} 400 401 402sub get_si16 { 403 my $self = shift; 404 405 my $num = $self->get_ui16(); 406 $num -= (1<<16) if $num>=(1<<15); 407 408 return $num; 409} 410 411 412 413sub put_ui16 { 414 my ($self,$num) = @_; 415 416 $self->_put_num($num, $self->{_ui16}); 417} 418 419*put_si16 = \&put_ui16; 420 421 422 423## 32 bit 424 425=head2 get_ui32 get_s32 put_ui32 put_si32 426 427read or write signed or unsigned 32 bit integers 428 429=cut 430 431 432 433sub get_ui32 { 434 my $self = shift; 435 return $self->_get_num(4, $self->{_ui32}); 436} 437 438 439sub get_si32 { 440 my $self = shift; 441 442 my $num = $self->get_ui32(); 443 $num -= (2**32) if ($num>=(2**31)); 444 return $num; 445} 446 447 448sub put_ui32 { 449 my ($self, $num) = @_; 450 451 $self->_put_num($num, $self->{_ui32}); 452} 453 454*put_si32 = \&put_ui32; 455 456 457 458 459=head2 guess_endian 460 461Guess the endianness of this system. Returns either I<$LITTLE_ENDIAN> 462or I<$BIG_ENDIAN> 463 464=cut 465 466sub guess_endian { 467 468 469 #my $svalue = int rand (2**16)-1; 470 #my $lvalue = int rand (2**32)-1; 471 472 #my $sp = pack("S", $svalue); 473 #my $lp = pack("L", $lvalue); 474 475 476 #if (unpack("V", $lp) == $lvalue && unpack("v", $sp) == $svalue) { 477 # return $LITTLE_ENDIAN; 478 #} elsif (unpack("N", $lp) == $lvalue && unpack("n", $sp) == $svalue) { 479 # return $BIG_ENDIAN; 480 #} else { 481 # carp "Couldn't determine whether this machine is big-endian or little-endian\n"; 482 #} 483 484 my $bo = $Config{'byteorder'}; 485 486 if (1234 == $bo or 12345678 == $bo) { 487 return $LITTLE_ENDIAN; 488 } elsif (4321 == $bo or 87654321 == $bo) { 489 return $BIG_ENDIAN; 490 } else { 491 carp "Unsupported architecture (probably a Cray or weird order)\n"; 492 } 493 494 495} 496 497 498=head2 close 499 500Close the file up. The I<File::Binary> object will then be useless 501until you open up another file; 502 503=cut 504 505sub close { 506 my $self = shift; 507 $self->{_fh}->close(); 508 $self = {}; 509} 510 511 512 513=pod 514 515=head1 BUGS 516 517Can't do numbers greater than 32 bits. 518 519Can't extract Floating Point or Fixed Point numbers. 520 521Can't extract null terminated strings. 522 523Needs tests for seeking and telling. 524 525=head1 COPYING 526 527(c)opyright 2002, Simon Wistow 528 529Distributed under the same terms as Perl itself. 530 531This software is under no warranty and will probably ruin your life, kill your friends, burn your house and bring about the apocalypse 532 533 534=head1 AUTHOR 535 536Copyright 2003, Simon Wistow <simon@thegestalt.org> 537 538 539=cut 540 541 5421; 543