File Coverage

blib/lib/Convert/BinHex.pm
Criterion Covered Total %
statement 286 355 80.5
branch 89 148 60.1
condition 16 35 45.7
subroutine 55 64 85.9
pod 20 28 71.4
total 466 630 73.9


line stmt bran cond sub pod time code
1             package Convert::BinHex;
2              
3              
4             =head1 NAME
5              
6             Convert::BinHex - extract data from Macintosh BinHex files
7              
8             I
9             Things may change drastically until the interface is hammered out:
10             if you have suggestions or objections, please speak up now!>
11              
12              
13             =head1 SYNOPSIS
14              
15             B
16              
17             use Convert::BinHex qw(binhex_crc macbinary_crc);
18              
19             # Compute HQX7-style CRC for data, pumping in old CRC if desired:
20             $crc = binhex_crc($data, $crc);
21              
22             # Compute the MacBinary-II-style CRC for the data:
23             $crc = macbinary_crc($data, $crc);
24              
25             B
26             Conversion is actually done via an object (L<"Convert::BinHex::Hex2Bin">)
27             which keeps internal conversion state:
28              
29             # Create and use a "translator" object:
30             my $H2B = Convert::BinHex->hex2bin; # get a converter object
31             while () {
32             print $STDOUT $H2B->next($_); # convert some more input
33             }
34             print $STDOUT $H2B->done; # no more input: finish up
35              
36             B
37             The following operations I be done in the order shown!
38              
39             # Read data in piecemeal:
40             $HQX = Convert::BinHex->open(FH=>\*STDIN) || die "open: $!";
41             $HQX->read_header; # read header info
42             @data = $HQX->read_data; # read in all the data
43             @rsrc = $HQX->read_resource; # read in all the resource
44              
45             B
46             Conversion is actually done via an object (L<"Convert::BinHex::Bin2Hex">)
47             which keeps internal conversion state:
48              
49             # Create and use a "translator" object:
50             my $B2H = Convert::BinHex->bin2hex; # get a converter object
51             while () {
52             print $STDOUT $B2H->next($_); # convert some more input
53             }
54             print $STDOUT $B2H->done; # no more input: finish up
55              
56             B Yes, you can convert I BinHex
57             as well as from it!
58              
59             # Create new, empty object:
60             my $HQX = Convert::BinHex->new;
61              
62             # Set header attributes:
63             $HQX->filename("logo.gif");
64             $HQX->type("GIFA");
65             $HQX->creator("CNVS");
66              
67             # Give it the data and resource forks (either can be absent):
68             $HQX->data(Path => "/path/to/data"); # here, data is on disk
69             $HQX->resource(Data => $resourcefork); # here, resource is in core
70              
71             # Output as a BinHex stream, complete with leading comment:
72             $HQX->encode(\*STDOUT);
73              
74             B
75             I.
76              
77             # Create new, empty object from CAP tree:
78             my $HQX = Convert::BinHex->from_cap("/path/to/root/file");
79             $HQX->encode(\*STDOUT);
80              
81              
82             =head1 DESCRIPTION
83              
84             B is a format used by Macintosh for transporting Mac files
85             safely through electronic mail, as short-lined, 7-bit, semi-compressed
86             data streams. Ths module provides a means of converting those
87             data streams back into into binary data.
88              
89              
90             =head1 FORMAT
91              
92             I<(Some text taken from RFC-1741.)>
93             Files on the Macintosh consist of two parts, called I:
94              
95             =over 4
96              
97             =item Data fork
98              
99             The actual data included in the file. The Data fork is typically the
100             only meaningful part of a Macintosh file on a non-Macintosh computer system.
101             For example, if a Macintosh user wants to send a file of data to a
102             user on an IBM-PC, she would only send the Data fork.
103              
104             =item Resource fork
105              
106             Contains a collection of arbitrary attribute/value pairs, including
107             program segments, icon bitmaps, and parametric values.
108              
109             =back
110              
111             Additional information regarding Macintosh files is stored by the
112             Finder in a hidden file, called the "Desktop Database".
113              
114             Because of the complications in storing different parts of a
115             Macintosh file in a non-Macintosh filesystem that only handles
116             consecutive data in one part, it is common to convert the Macintosh
117             file into some other format before transferring it over the network.
118             The BinHex format squashes that data into transmittable ASCII as follows:
119              
120             =over 4
121              
122             =item 1.
123              
124             The file is output as a B consisting of some basic header
125             information (filename, type, creator), then the data fork, then the
126             resource fork.
127              
128             =item 2.
129              
130             The byte stream is B by looking for series of duplicated
131             bytes and representing them using a special binary escape sequence
132             (of course, any occurences of the escape character must also be escaped).
133              
134             =item 3.
135              
136             The compressed stream is B via the "6/8 hemiola" common
137             to I and I: each group of three 8-bit bytes (24 bits)
138             is chopped into four 6-bit numbers, which are used as indexes into
139             an ASCII "alphabet".
140             (I assume that leftover bytes are zero-padded; documentation is thin).
141              
142             =back
143              
144             =cut
145              
146 5     5   345707 use strict;
  5         11  
  5         187  
147 5     5   27 use warnings;
  5         9  
  5         186  
148 5     5   85 use vars qw(@ISA @EXPORT_OK $VERSION $QUIET);
  5         10  
  5         857  
149 5     5   2898 use integer;
  5         34  
  5         32  
150              
151 5     5   139 use Carp;
  5         11  
  5         429  
152 5     5   26 use Exporter;
  5         10  
  5         209  
153 5     5   4875 use FileHandle;
  5         54571  
  5         30  
154              
155             @ISA = qw(Exporter);
156             @EXPORT_OK = qw(
157             macbinary_crc
158             binhex_crc
159             );
160              
161              
162              
163             our $VERSION = '1.123'; # VERSION
164              
165             # My identity:
166             my $I = 'binhex:';
167              
168             # Utility function:
169             sub min {
170 2     2 0 4 my ($a, $b) = @_;
171 2 100       8 ($a < $b) ? $a : $b;
172             }
173              
174             # An array useful for CRC calculations that use 0x1021 as the "seed":
175             my @MAGIC = (
176             0x0000, 0x1021, 0x2042, 0x3063, 0x4084, 0x50a5, 0x60c6, 0x70e7,
177             0x8108, 0x9129, 0xa14a, 0xb16b, 0xc18c, 0xd1ad, 0xe1ce, 0xf1ef,
178             0x1231, 0x0210, 0x3273, 0x2252, 0x52b5, 0x4294, 0x72f7, 0x62d6,
179             0x9339, 0x8318, 0xb37b, 0xa35a, 0xd3bd, 0xc39c, 0xf3ff, 0xe3de,
180             0x2462, 0x3443, 0x0420, 0x1401, 0x64e6, 0x74c7, 0x44a4, 0x5485,
181             0xa56a, 0xb54b, 0x8528, 0x9509, 0xe5ee, 0xf5cf, 0xc5ac, 0xd58d,
182             0x3653, 0x2672, 0x1611, 0x0630, 0x76d7, 0x66f6, 0x5695, 0x46b4,
183             0xb75b, 0xa77a, 0x9719, 0x8738, 0xf7df, 0xe7fe, 0xd79d, 0xc7bc,
184             0x48c4, 0x58e5, 0x6886, 0x78a7, 0x0840, 0x1861, 0x2802, 0x3823,
185             0xc9cc, 0xd9ed, 0xe98e, 0xf9af, 0x8948, 0x9969, 0xa90a, 0xb92b,
186             0x5af5, 0x4ad4, 0x7ab7, 0x6a96, 0x1a71, 0x0a50, 0x3a33, 0x2a12,
187             0xdbfd, 0xcbdc, 0xfbbf, 0xeb9e, 0x9b79, 0x8b58, 0xbb3b, 0xab1a,
188             0x6ca6, 0x7c87, 0x4ce4, 0x5cc5, 0x2c22, 0x3c03, 0x0c60, 0x1c41,
189             0xedae, 0xfd8f, 0xcdec, 0xddcd, 0xad2a, 0xbd0b, 0x8d68, 0x9d49,
190             0x7e97, 0x6eb6, 0x5ed5, 0x4ef4, 0x3e13, 0x2e32, 0x1e51, 0x0e70,
191             0xff9f, 0xefbe, 0xdfdd, 0xcffc, 0xbf1b, 0xaf3a, 0x9f59, 0x8f78,
192             0x9188, 0x81a9, 0xb1ca, 0xa1eb, 0xd10c, 0xc12d, 0xf14e, 0xe16f,
193             0x1080, 0x00a1, 0x30c2, 0x20e3, 0x5004, 0x4025, 0x7046, 0x6067,
194             0x83b9, 0x9398, 0xa3fb, 0xb3da, 0xc33d, 0xd31c, 0xe37f, 0xf35e,
195             0x02b1, 0x1290, 0x22f3, 0x32d2, 0x4235, 0x5214, 0x6277, 0x7256,
196             0xb5ea, 0xa5cb, 0x95a8, 0x8589, 0xf56e, 0xe54f, 0xd52c, 0xc50d,
197             0x34e2, 0x24c3, 0x14a0, 0x0481, 0x7466, 0x6447, 0x5424, 0x4405,
198             0xa7db, 0xb7fa, 0x8799, 0x97b8, 0xe75f, 0xf77e, 0xc71d, 0xd73c,
199             0x26d3, 0x36f2, 0x0691, 0x16b0, 0x6657, 0x7676, 0x4615, 0x5634,
200             0xd94c, 0xc96d, 0xf90e, 0xe92f, 0x99c8, 0x89e9, 0xb98a, 0xa9ab,
201             0x5844, 0x4865, 0x7806, 0x6827, 0x18c0, 0x08e1, 0x3882, 0x28a3,
202             0xcb7d, 0xdb5c, 0xeb3f, 0xfb1e, 0x8bf9, 0x9bd8, 0xabbb, 0xbb9a,
203             0x4a75, 0x5a54, 0x6a37, 0x7a16, 0x0af1, 0x1ad0, 0x2ab3, 0x3a92,
204             0xfd2e, 0xed0f, 0xdd6c, 0xcd4d, 0xbdaa, 0xad8b, 0x9de8, 0x8dc9,
205             0x7c26, 0x6c07, 0x5c64, 0x4c45, 0x3ca2, 0x2c83, 0x1ce0, 0x0cc1,
206             0xef1f, 0xff3e, 0xcf5d, 0xdf7c, 0xaf9b, 0xbfba, 0x8fd9, 0x9ff8,
207             0x6e17, 0x7e36, 0x4e55, 0x5e74, 0x2e93, 0x3eb2, 0x0ed1, 0x1ef0
208             );
209              
210             # Ssssssssssshhhhhhhhhh:
211             $QUIET = 0;
212              
213              
214              
215             #==============================
216              
217             =head1 FUNCTIONS
218              
219             =head2 CRC computation
220              
221             =over 4
222              
223             =cut
224              
225             #------------------------------------------------------------
226              
227             =item macbinary_crc DATA, SEED
228              
229             Compute the MacBinary-II-style CRC for the given DATA, with the CRC
230             seeded to SEED. Normally, you start with a SEED of 0, and you pump in
231             the previous CRC as the SEED if you're handling a lot of data one chunk
232             at a time. That is:
233              
234             $crc = 0;
235             while () {
236             $crc = macbinary_crc($_, $crc);
237             }
238              
239             I Extracted from the I utility (Doug Moore, April '87),
240             using a "magic array" algorithm by Jim Van Verth for efficiency.
241             Converted to Perl5 by Eryq. B
242              
243             =cut
244              
245             sub macbinary_crc {
246 1     1 1 1040 my $len = length($_[0]);
247 1         2 my $crc = $_[1];
248 1         2 my $i;
249 1         7 for ($i = 0; $i < $len; $i++) {
250 60         66 ($crc ^= (vec($_[0], $i, 8) << 8)) &= 0xFFFF;
251 60         111 $crc = ($crc << 8) ^ $MAGIC[$crc >> 8];
252             }
253 1         3 $crc;
254             }
255              
256             #------------------------------------------------------------
257              
258             =item binhex_crc DATA, SEED
259              
260             Compute the HQX-style CRC for the given DATA, with the CRC seeded to SEED.
261             Normally, you start with a SEED of 0, and you pump in the previous CRC as
262             the SEED if you're handling a lot of data one chunk at a time. That is:
263              
264             $crc = 0;
265             while () {
266             $crc = binhex_crc($_, $crc);
267             }
268              
269             I Extracted from the I utility (Doug Moore, April '87),
270             using a "magic array" algorithm by Jim Van Verth for efficiency.
271             Converted to Perl5 by Eryq.
272              
273             =cut
274              
275             sub binhex_crc {
276 8     8 1 24 my $len = length($_[0]);
277 8         13 my $crc = $_[1];
278 8 100       20 if (! defined $crc) {
279 1         2 $crc = 0;
280             }
281 8         10 my $i;
282 8         23 for ($i = 0; $i < $len; $i++) {
283 2852         2464 my $ocrc = $crc;
284 2852         5994 $crc = (((($crc & 0xFF) << 8) | vec($_[0], $i, 8))
285             ^ $MAGIC[$crc >> 8]) & 0xFFFF;
286             ## printf "CRCin = %04x, char = %02x (%c), CRCout = %04x\n",
287             ## $ocrc, vec($_[0], $i, 8), ord(substr($_[0], $i, 1)), $crc;
288             }
289 8         19 $crc;
290             }
291              
292              
293             =back
294              
295             =cut
296              
297              
298              
299             #==============================
300              
301             =head1 OO INTERFACE
302              
303             =head2 Conversion
304              
305             =over 4
306              
307             =cut
308              
309             #------------------------------------------------------------
310              
311             =item bin2hex
312              
313             I
314             Return a converter object. Just creates a new instance of
315             L<"Convert::BinHex::Bin2Hex">; see that class for details.
316              
317             =cut
318              
319             sub bin2hex {
320 1     1 1 9 return Convert::BinHex::Bin2Hex->new;
321             }
322              
323             #------------------------------------------------------------
324              
325             =item hex2bin
326              
327             I
328             Return a converter object. Just creates a new instance of
329             L<"Convert::BinHex::Hex2Bin">; see that class for details.
330              
331             =cut
332              
333             sub hex2bin {
334 9     9 1 6393 return Convert::BinHex::Hex2Bin->new;
335             }
336              
337             =back
338              
339             =cut
340              
341              
342              
343             #==============================
344              
345             =head2 Construction
346              
347             =over 4
348              
349             =cut
350              
351             #------------------------------------------------------------
352              
353             =item new PARAMHASH
354              
355             I
356             Return a handle on a BinHex'able entity. In general, the data and resource
357             forks for such an entity are stored in native format (binary) format.
358              
359             Parameters in the PARAMHASH are the same as header-oriented method names,
360             and may be used to set attributes:
361              
362             $HQX = new Convert::BinHex filename => "icon.gif",
363             type => "GIFB",
364             creator => "CNVS";
365              
366             =cut
367              
368             sub new {
369 2     2 1 20 my ($class, %params) = @_;
370              
371             # Create object:
372 2         22 my $self = bless {
373             Data => new Convert::BinHex::Fork, # data fork
374             Rsrc => new Convert::BinHex::Fork, # resource fork
375             }, $class; # basic object
376              
377             # Process params:
378 2         7 my $method;
379 2         5 foreach $method (qw(creator filename flags requires type version
380             software_version)){
381 14 50       35 $self->$method($params{$method}) if exists($params{$method});
382             }
383 2         7 $self;
384             }
385              
386             #------------------------------------------------------------
387              
388             =item open PARAMHASH
389              
390             I
391             Return a handle on a new BinHex'ed stream, for parsing.
392             Params are:
393              
394             =over 4
395              
396             =item Data
397              
398             Input a HEX stream from the given data. This can be a scalar, or a
399             reference to an array of scalars.
400              
401             =item Expr
402              
403             Input a HEX stream from any open()able expression. It will be opened and
404             binmode'd, and the filehandle will be closed either on a C
405             or when the object is destructed.
406              
407             =item FH
408              
409             Input a HEX stream from the given filehandle.
410              
411             =item NoComment
412              
413             If true, the parser should not attempt to skip a leading "(This file...)"
414             comment. That means that the first nonwhite characters encountered
415             must be the binhex'ed data.
416              
417             =back
418              
419             =cut
420              
421             sub open {
422 1     1 1 3068 my $self = shift;
423 1         4 my %params = @_;
424              
425             # Create object:
426 1 50       8 ref($self) or $self = $self->new;
427              
428             # Set up input:
429 1         2 my $data;
430 1 50       6 if ($params{FH}) {
    0          
    0          
431 1         8 $self->{FH} = Convert::BinHex::IO_Handle->wrap($params{FH});
432             }
433             elsif ($params{Expr}) {
434 0 0       0 $self->{FH} = FileHandle->new($params{Expr}) or
435             croak "$I can't open $params{Expr}: $!\n";
436 0         0 $self->{FH} = Convert::BinHex::IO_Handle->wrap($self->{FH});
437             }
438             elsif ($params{Data}) {
439 0 0       0 if (!ref($data = $params{Data})) { # scalar
    0          
440 0         0 $self->{FH} = Convert::BinHex::IO_Scalar->wrap(\$data);
441             }
442             elsif (ref($data) eq 'ARRAY') {
443 0         0 $data = join('', @$data);
444 0         0 $self->{FH} = Convert::BinHex::IO_Scalar->wrap(\$data);
445             }
446             }
447 1 50       7 $self->{FH} or croak "$I missing a valid input source\n";
448              
449             # Comments?
450 1         3 $self->{CommentRead} = $params{NoComment};
451              
452             # Reset the converter!
453 1         8 $self->{H2B} = Convert::BinHex::Hex2Bin->new;
454 1         3 $self;
455             }
456              
457              
458             =back
459              
460             =cut
461              
462              
463              
464              
465             #==============================
466              
467             =head2 Get/set header information
468              
469             =over 4
470              
471             =cut
472              
473             #------------------------------
474              
475             =item creator [VALUE]
476              
477             I
478             Get/set the creator of the file. This is a four-character
479             string (though I don't know if it's guaranteed to be printable ASCII!)
480             that serves as part of the Macintosh's version of a MIME "content-type".
481              
482             For example, a document created by "Canvas" might have
483             creator C<"CNVS">.
484              
485             =cut
486              
487 4 100   4 1 31 sub creator { (@_ > 1) ? ($_[0]->{Creator} = $_[1]) : $_[0]->{Creator} }
488              
489             #------------------------------
490              
491             =item data [PARAMHASH]
492              
493             I
494             Get/set the data fork. Any arguments are passed into the
495             new() method of L<"Convert::BinHex::Fork">.
496              
497             =cut
498              
499             sub data {
500 4     4 1 12 my $self = shift;
501 4 100       34 @_ ? $self->{Data} = Convert::BinHex::Fork->new(@_) : $self->{Data};
502             }
503              
504             #------------------------------
505              
506             =item filename [VALUE]
507              
508             I
509             Get/set the name of the file.
510              
511             =cut
512              
513 5 100   5 1 2183 sub filename { (@_ > 1) ? ($_[0]->{Filename} = $_[1]) : $_[0]->{Filename} }
514              
515             #------------------------------
516              
517             =item flags [VALUE]
518              
519             I
520             Return the flags, as an integer. Use bitmasking to get as the values
521             you need.
522              
523             =cut
524              
525 2 100   2 1 34 sub flags { (@_ > 1) ? ($_[0]->{Flags} = $_[1]) : $_[0]->{Flags} }
526              
527             #------------------------------
528              
529             =item header_as_string
530              
531             Return a stringified version of the header that you might
532             use for logging/debugging purposes. It looks like this:
533              
534             X-HQX-Software: BinHex 4.0 (Convert::BinHex 1.102)
535             X-HQX-Filename: Something_new.eps
536             X-HQX-Version: 0
537             X-HQX-Type: EPSF
538             X-HQX-Creator: ART5
539             X-HQX-Data-Length: 49731
540             X-HQX-Rsrc-Length: 23096
541              
542             As some of you might have guessed, this is RFC-822-style, and
543             may be easily plunked down into the middle of a mail header, or
544             split into lines, etc.
545              
546             =cut
547              
548             sub header_as_string {
549 0     0 1 0 my $self = shift;
550 0         0 my @h;
551 0   0     0 push @h, "X-HQX-Software: " .
552             "BinHex " . ($self->requires || '4.0') .
553             " (Convert::BinHex $VERSION)";
554 0         0 push @h, "X-HQX-Filename: " . $self->filename;
555 0         0 push @h, "X-HQX-Version: " . $self->version;
556 0         0 push @h, "X-HQX-Type: " . $self->type;
557 0         0 push @h, "X-HQX-Creator: " . $self->creator;
558 0         0 push @h, "X-HQX-Flags: " . sprintf("%x", $self->flags);
559 0         0 push @h, "X-HQX-Data-Length: " . $self->data->length;
560 0         0 push @h, "X-HQX-Rsrc-Length: " . $self->resource->length;
561 0         0 push @h, "X-HQX-CRC: " . sprintf("%x", $self->{HdrCRC});
562 0         0 return join("\n", @h) . "\n";
563             }
564              
565             #------------------------------
566              
567             =item requires [VALUE]
568              
569             I
570             Get/set the software version required to convert this file, as
571             extracted from the comment that preceded the actual binhex'ed
572             data; e.g.:
573              
574             (This file must be converted with BinHex 4.0)
575              
576             In this case, after parsing in the comment, the code:
577              
578             $HQX->requires;
579              
580             would get back "4.0".
581              
582             =cut
583              
584             sub requires {
585 2 100   2 1 25 (@_ > 1) ? ($_[0]->{Requires} = $_[1]) : $_[0]->{Requires}
586             }
587             *software_version = \&requires;
588              
589             #------------------------------
590              
591             =item resource [PARAMHASH]
592              
593             I
594             Get/set the resource fork. Any arguments are passed into the
595             new() method of L<"Convert::BinHex::Fork">.
596              
597             =cut
598              
599             sub resource {
600 4     4 1 20 my $self = shift;
601 4 100       27 @_ ? $self->{Rsrc} = Convert::BinHex::Fork->new(@_) : $self->{Rsrc};
602             }
603              
604             #------------------------------
605              
606             =item type [VALUE]
607              
608             I
609             Get/set the type of the file. This is a four-character
610             string (though I don't know if it's guaranteed to be printable ASCII!)
611             that serves as part of the Macintosh's version of a MIME "content-type".
612              
613             For example, a GIF89a file might have type C<"GF89">.
614              
615             =cut
616              
617 4 100   4 1 32 sub type { (@_ > 1) ? ($_[0]->{Type} = $_[1]) : $_[0]->{Type} }
618              
619             #------------------------------
620              
621             =item version [VALUE]
622              
623             I
624             Get/set the version, as an integer.
625              
626             =cut
627              
628 2 100   2 1 85 sub version { (@_ > 1) ? ($_[0]->{Version} = $_[1]) : $_[0]->{Version} }
629              
630              
631             =back
632              
633             =cut
634              
635             ### OBSOLETE!!!
636 1     1 0 4 sub data_length { shift->data->length(@_) }
637 1     1 0 4 sub resource_length { shift->resource->length(@_) }
638              
639              
640              
641              
642             #==============================
643              
644             =head2 Decode, high-level
645              
646             =over 4
647              
648             =cut
649              
650             #------------------------------------------------------------
651              
652             =item read_comment
653              
654             I
655             Skip past the opening comment in the file, which is of the form:
656              
657             (This file must be converted with BinHex 4.0)
658              
659             As per RFC-1741, I
660             and any text before it will be ignored.
661              
662             I C will
663             do it for you. After the call, the version number in the comment is
664             accessible via the C method.
665              
666             =cut
667              
668             sub read_comment {
669 1     1 1 3 my $self = shift;
670 1 50       4 return 1 if ($self->{CommentRead}); # prevent accidents
671 1         1 local($_);
672 1         6 while (defined($_ = $self->{FH}->getline)) {
673 1         4 chomp;
674 1 50       9 if (/^\(This file must be converted with BinHex ([\d\.]+).*\)\s*$/i) {
675 1         7 $self->requires($1);
676 1         3 return $self->{CommentRead} = 1;
677             }
678             }
679 0         0 croak "$I comment line (This file must be converted with BinHex...) ".
680             "not found\n";
681             }
682              
683             #------------------------------------------------------------
684              
685             =item read_header
686              
687             I
688             Read in the BinHex file header. You must do this first!
689              
690             =cut
691              
692             sub read_header {
693 1     1 1 6 my $self = shift;
694 1 50       5 return 1 if ($self->{HeaderRead}); # prevent accidents
695              
696             # Skip comment:
697 1         4 $self->read_comment;
698              
699             # Get header info:
700 1         5 $self->filename ($self->read_str($self->read_byte));
701 1         4 $self->version ($self->read_byte);
702 1         5 $self->type ($self->read_str(4));
703 1         3 $self->creator ($self->read_str(4));
704 1         5 $self->flags ($self->read_short);
705 1         6 $self->data_length ($self->read_long);
706 1         3 $self->resource_length ($self->read_long);
707 1         3 $self->{HdrCRC} = $self->read_short;
708 1         6 $self->{HeaderRead} = 1;
709             }
710              
711             #------------------------------------------------------------
712             #
713             # _read_fork
714             #
715             # I
716             # Read in a fork.
717             #
718              
719             sub _read_fork {
720 6     6   11 my $self = shift;
721              
722             # Pass in call if array context:
723 6 100       15 if (wantarray) {
724 2         3 local($_);
725 2         3 my @all;
726 2         10 push @all, $_ while (defined($_ = $self->_read_fork(@_)));
727 2         9 return @all;
728             }
729              
730             # Get args:
731 4         5 my ($fork, $n) = @_;
732 4 100       10 if($self->{$fork}->length == 0) {
733 1         4 $self->{$fork}->crc($self->read_short);
734 1         3 return undef;
735             }
736 3 50       18 defined($n) or $n = 2048;
737              
738             # Reset pointer into fork if necessary:
739 3 100       9 if (!defined($self->{$fork}{Ptr})) {
740 1         3 $self->{$fork}{Ptr} = 0;
741 1         3 $self->{CompCRC} = 0;
742             }
743              
744             # Check for EOF:
745 3 100       14 return undef if ($self->{$fork}{Ptr} >= $self->{$fork}->length);
746              
747             # Read up to, but not exceeding, the number of bytes left in the fork:
748 2         7 my $n2read = min($n, ($self->{$fork}->length - $self->{$fork}{Ptr}));
749 2         6 my $data = $self->read_str($n2read);
750 2         5 $self->{$fork}{Ptr} += length($data);
751              
752             # If we just read the last byte, read the CRC also:
753 2 100 66     7 if (($self->{$fork}{Ptr} == $self->{$fork}->length) && # last byte
754             !defined($self->{$fork}->crc)) { # no CRC
755 1         3 my $comp_CRC;
756              
757             # Move computed CRC forward by two zero bytes, and grab the value:
758 1 50       3 if ($self->{CheckCRC}) {
759 0         0 $self->{CompCRC} = binhex_crc("\000\000", $self->{CompCRC});
760             }
761              
762             # Get CRC as stored in file:
763 1         3 $self->{$fork}->crc($self->read_short); # get stored CRC
764              
765             # Compare, and note corruption if detected:
766 1 50 33     5 if ($self->{CheckCRC} and ($self->{$fork}->crc != $comp_CRC)) {
767 0 0       0 &Carp::carp("CRCs do not match: corrupted data?") unless $QUIET;
768 0         0 $self->{Corrupted} = 1;
769             }
770             }
771              
772             # Return the bytes:
773 2         12 $data;
774             }
775              
776             #------------------------------------------------------------
777              
778             =item read_data [NBYTES]
779              
780             I
781             Read information from the data fork. Use it in an array context to
782             slurp all the data into an array of scalars:
783              
784             @data = $HQX->read_data;
785              
786             Or use it in a scalar context to get the data piecemeal:
787              
788             while (defined($data = $HQX->read_data)) {
789             # do stuff with $data
790             }
791              
792             The NBYTES to read defaults to 2048.
793              
794             =cut
795              
796             sub read_data {
797 1     1 1 9 shift->_read_fork('Data',@_);
798             }
799              
800             #------------------------------------------------------------
801              
802             =item read_resource [NBYTES]
803              
804             I
805             Read in all/some of the resource fork.
806             See C for usage.
807              
808             =cut
809              
810             sub read_resource {
811 1     1 1 7 shift->_read_fork('Rsrc',@_);
812             }
813              
814             =back
815              
816             =cut
817              
818              
819              
820             #------------------------------------------------------------
821             #
822             # read BUFFER, NBYTES
823             #
824             # Read the next NBYTES (decompressed) bytes from the input stream
825             # into BUFFER. Returns the number of bytes actually read, and
826             # undef on end of file.
827             #
828             # I the calling style mirrors the IO::Handle read() function.
829              
830             my $READBUF = '';
831             sub read {
832 13     13 0 19 my ($self, $n) = ($_[0], $_[2]);
833 13         17 $_[1] = ''; # just in case
834 13         19 my $FH = $self->{FH};
835 13         41 local($^W) = 0;
836              
837             # Get more BIN bytes until enough or EOF:
838 13         18 my $bin;
839 13         202 while (length($self->{BIN_QUEUE}) < $n) {
840 1 50       6 $FH->read($READBUF, 4096) or last;
841 1         7 $self->{BIN_QUEUE} .= $self->{H2B}->next($READBUF); # save BIN
842             }
843              
844             # We've got as many bytes as we're gonna get:
845 13         35 $_[1] = substr($self->{BIN_QUEUE}, 0, $n);
846 13         47 $self->{BIN_QUEUE} = substr($self->{BIN_QUEUE}, $n);
847              
848             # Advance the CRC:
849 13 50       33 if ($self->{CheckCRC}) {
850 0         0 $self->{CompCRC} = binhex_crc($_[1], $self->{CompCRC});
851             }
852 13         33 return length($_[1]);
853             }
854              
855             #------------------------------------------------------------
856             #
857             # read_str NBYTES
858             #
859             # Read and return the next NBYTES bytes, or die with "unexpected end of file"
860              
861             sub read_str {
862 13     13 0 24 my ($self, $n) = @_;
863 13         18 my $buf = '';
864 13         25 $self->read($buf, $n);
865 13 50 33     56 croak "$I unexpected end of file (wanted $n, got " . length($buf) . ")\n"
866             if ($n and (length($buf) < $n));
867 13         68 return $buf;
868             }
869              
870             #------------------------------------------------------------
871             #
872             # read_byte
873             # read_short
874             # read_long
875             #
876             # Read 1, 2, or 4 bytes, and return the value read as an unsigned integer.
877             # If not that many bytes remain, die with "unexpected end of file";
878              
879             sub read_byte {
880 2     2 0 6 ord($_[0]->read_str(1));
881             }
882              
883             sub read_short {
884 4     4 0 10 unpack("n", $_[0]->read_str(2));
885             }
886              
887             sub read_long {
888 2     2 0 12 unpack("N", $_[0]->read_str(4));
889             }
890              
891              
892              
893              
894              
895              
896              
897              
898              
899             #==============================
900              
901             =head2 Encode, high-level
902              
903             =over 4
904              
905             =cut
906              
907             #------------------------------------------------------------
908              
909             =item encode OUT
910              
911             Encode the object as a BinHex stream to the given output handle OUT.
912             OUT can be a filehandle, or any blessed object that responds to a
913             C message.
914              
915             The leading comment is output, using the C attribute.
916              
917             =cut
918              
919             sub encode {
920 1     1 1 996 my $self = shift;
921              
922             # Get output handle:
923 1         2 my $OUT = shift; $OUT = wrap Convert::BinHex::IO_Handle $OUT;
  1         9  
924              
925             # Get a new converter:
926 1         17 my $B2H = $self->bin2hex;
927              
928             # Comment:
929 1   50     5 $OUT->print("(This file must be converted with BinHex ",
930             ($self->requires || '4.0'),
931             ")\n");
932              
933             # Build header in core:
934 1         19 my @hdrs;
935 1         6 my $flen = length($self->filename);
936 1         7 push @hdrs, pack("C", $flen);
937 1         5 push @hdrs, pack("a$flen", $self->filename);
938 1         5 push @hdrs, pack('C', $self->version);
939 1   50     5 push @hdrs, pack('a4', $self->type || '????');
940 1   50     5 push @hdrs, pack('a4', $self->creator || '????');
941 1   50     5 push @hdrs, pack('n', $self->flags || 0);
942 1   50     5 push @hdrs, pack('N', $self->data->length || 0);
943 1   50     4 push @hdrs, pack('N', $self->resource->length || 0);
944 1         4 my $hdr = join '', @hdrs;
945              
946             # Compute the header CRC:
947 1         5 my $crc = binhex_crc("\000\000", binhex_crc($hdr, 0));
948              
949             # Output the header (plus its CRC):
950 1         6 $OUT->print($B2H->next($hdr . pack('n', $crc)));
951              
952             # Output the data fork:
953 1         7 $self->data->encode($OUT, $B2H);
954              
955             # Output the resource fork:
956 1         6 $self->resource->encode($OUT, $B2H);
957              
958             # Finish:
959 1         5 $OUT->print($B2H->done);
960 1         19 1;
961             }
962              
963             =back
964              
965             =cut
966              
967              
968              
969             #==============================
970              
971             =head1 SUBMODULES
972              
973             =cut
974              
975             #============================================================
976             #
977             package Convert::BinHex::Bin2Hex;
978             #
979             #============================================================
980              
981             =head2 Convert::BinHex::Bin2Hex
982              
983             A BINary-to-HEX converter. This kind of conversion requires
984             a certain amount of state information; it cannot be done by
985             just calling a simple function repeatedly. Use it like this:
986              
987             # Create and use a "translator" object:
988             my $B2H = Convert::BinHex->bin2hex; # get a converter object
989             while () {
990             print STDOUT $B2H->next($_); # convert some more input
991             }
992             print STDOUT $B2H->done; # no more input: finish up
993              
994             # Re-use the object:
995             $B2H->rewind; # ready for more action!
996             while () { ...
997              
998             On each iteration, C (and C) may return either
999             a decent-sized non-empty string (indicating that more converted data
1000             is ready for you) or an empty string (indicating that the converter
1001             is waiting to amass more input in its private buffers before handing
1002             you more stuff to output.
1003              
1004             Note that C I converts and hands you whatever is left.
1005              
1006             This may have been a good approach. It may not. Someday, the converter
1007             may also allow you give it an object that responds to read(), or
1008             a FileHandle, and it will do all the nasty buffer-filling on its own,
1009             serving you stuff line by line:
1010              
1011             # Someday, maybe...
1012             my $B2H = Convert::BinHex->bin2hex(\*STDIN);
1013             while (defined($_ = $B2H->getline)) {
1014             print STDOUT $_;
1015             }
1016              
1017             Someday, maybe. Feel free to voice your opinions.
1018              
1019             =cut
1020              
1021             #------------------------------
1022             #
1023             # new
1024              
1025             sub new {
1026 1     1   27 my $self = bless {}, shift;
1027 1         6 return $self->rewind;
1028             }
1029              
1030             #------------------------------
1031             #
1032             # rewind
1033              
1034             sub rewind {
1035 1     1   2 my $self = shift;
1036 1         9 $self->{CBIN} = ' ' x 2048; $self->{CBIN} = ''; # BIN waiting for xlation
  1         3  
1037 1         9 $self->{HEX} = ' ' x 2048; $self->{HEX} = ''; # HEX waiting for output
  1         3  
1038 1         2 $self->{LINE} = 0; # current line of output
1039 1         3 $self->{EOL} = "\n";
1040 1         3 $self;
1041             }
1042              
1043             #------------------------------
1044             #
1045             # next MOREDATA
1046              
1047 6     6   19 sub next { shift->_next(0, @_) }
1048              
1049             #------------------------------
1050             #
1051             # done
1052              
1053 1     1   4 sub done { shift->_next(1) }
1054              
1055             #------------------------------
1056             #
1057             # _next ATEOF, [MOREDATA]
1058             #
1059             # Instance method, private. Supply more data, and get any more output.
1060             # Returns the empty string often, if not enough output has accumulated.
1061              
1062             sub _next {
1063 7     7   10 my $self = shift;
1064 7         9 my $eof = shift;
1065              
1066             # Get the BINary data to process this time round, re-queueing the rest:
1067             # Handle EOF and non-EOF conditions separately:
1068 7         8 my $new_bin;
1069 7 100       13 if ($eof) { # No more BINary input...
1070             # Pad the queue with nuls to exactly 3n characters:
1071 1         4 $self->{CBIN} .= ("\x00" x ((3 - length($self->{CBIN}) % 3) % 3))
1072             }
1073             else { # More BINary input...
1074             # "Compress" new stuff, and add it to the queue:
1075 6         30 ($new_bin = $_[0]) =~ s/\x90/\x90\x00/g;
1076 6         13 $self->{CBIN} .= $new_bin;
1077              
1078             # Return if not enough to bother with:
1079 6 100       35 return '' if (length($self->{CBIN}) < 2048);
1080             }
1081              
1082             # ...At this point, QUEUE holds compressed binary which we will attempt
1083             # to convert to some HEX characters...
1084              
1085             # Trim QUEUE to exactly 3n characters, saving the excess:
1086 2         4 my $requeue = '';
1087 2         16 $requeue .= chop($self->{CBIN}) while (length($self->{CBIN}) % 3);
1088              
1089             # Uuencode, adding stuff to hex:
1090 2         6 my $hex = ' ' x 2048; $hex = '';
  2         4  
1091 2         6 pos($self->{CBIN}) = 0;
1092 2         14 while ($self->{CBIN} =~ /(.{1,45})/gs) {
1093 63         139 $hex .= substr(pack('u', $1), 1);
1094 63         220 chop($hex);
1095             }
1096 2         13 $self->{CBIN} = reverse($requeue); # put the excess back on the queue
1097              
1098             # Switch to BinHex alphabet:
1099 2         12 $hex =~ tr
1100             {` -_}
1101             {!!"#$%&'()*+,\x2D012345689@ABCDEFGHIJKLMNPQRSTUVXYZ[`abcdefhijklmpqr};
1102              
1103             # Prepend any HEX we have queued from the last time:
1104 2 100       13 $hex = (($self->{LINE}++ ? '' : ':') . # start with ":" pad?
1105             $self->{HEX} . # any output in the queue?
1106             $hex);
1107              
1108             # Break off largest chunk of 64n characters, put remainder back in queue:
1109 2         5 my $rem = length($hex) % 64;
1110 2 50       11 $self->{HEX} = ($rem ? substr($hex, -$rem) : '');
1111 2         7 $hex = substr($hex, 0, (length($hex)-$rem));
1112              
1113             # Put in an EOL every 64'th character:
1114 2         88 $hex =~ s{(.{64})}{$1$self->{EOL}}sg;
1115              
1116             # No more input? Then tack on the remainder now:
1117 2 100       7 if ($eof) {
1118 1 50       7 $hex .= $self->{HEX} . ":" . ($self->{EOL} ? $self->{EOL} : '');
1119             }
1120              
1121             # Done!
1122 2         19 $hex;
1123             }
1124              
1125              
1126              
1127              
1128             #============================================================
1129             #
1130             package Convert::BinHex::Hex2Bin;
1131             #
1132             #============================================================
1133              
1134             =head2 Convert::BinHex::Hex2Bin
1135              
1136             A HEX-to-BINary converter. This kind of conversion requires
1137             a certain amount of state information; it cannot be done by
1138             just calling a simple function repeatedly. Use it like this:
1139              
1140             # Create and use a "translator" object:
1141             my $H2B = Convert::BinHex->hex2bin; # get a converter object
1142             while () {
1143             print STDOUT $H2B->next($_); # convert some more input
1144             }
1145             print STDOUT $H2B->done; # no more input: finish up
1146              
1147             # Re-use the object:
1148             $H2B->rewind; # ready for more action!
1149             while () { ...
1150              
1151             On each iteration, C (and C) may return either
1152             a decent-sized non-empty string (indicating that more converted data
1153             is ready for you) or an empty string (indicating that the converter
1154             is waiting to amass more input in its private buffers before handing
1155             you more stuff to output.
1156              
1157             Note that C I converts and hands you whatever is left.
1158              
1159             Note that this converter does I find the initial
1160             "BinHex version" comment. You have to skip that yourself. It
1161             only handles data between the opening and closing C<":">.
1162              
1163             =cut
1164              
1165             #------------------------------
1166             #
1167             # new
1168              
1169             sub new {
1170 10     10   34 my $self = bless {}, shift;
1171 10         25 return $self->rewind;
1172             }
1173              
1174             #------------------------------
1175             #
1176             # rewind
1177              
1178             sub rewind {
1179 10     10   31 my $self = shift;
1180 10         23 $self->hex2comp_rewind;
1181 10         26 $self->comp2bin_rewind;
1182 10         25 $self;
1183             }
1184              
1185             #------------------------------
1186             #
1187             # next MOREDATA
1188              
1189             sub next {
1190 1     1   2 my $self = shift;
1191 1 50       66 $_[0] =~ s/\s//g if (defined($_[0])); # more input
1192 1         5 return $self->comp2bin_next($self->hex2comp_next($_[0]));
1193             }
1194              
1195             #------------------------------
1196             #
1197             # done
1198              
1199             sub done {
1200 0     0   0 return "";
1201             }
1202              
1203             #------------------------------
1204             #
1205             # hex2comp_rewind
1206              
1207             sub hex2comp_rewind {
1208 10     10   16 my $self = shift;
1209 10         33 $self->{HEX} = '';
1210             }
1211              
1212             #------------------------------
1213             #
1214             # hex2comp_next HEX
1215             #
1216             # WARNING: argument is modified destructively for efficiency!!!!
1217              
1218             sub hex2comp_next {
1219 1     1   1 my $self = shift;
1220             ### print "hex2comp: newhex = $newhex\n";
1221              
1222             # Concat new with queue, and kill any padding:
1223 1 50       11 my $hex = $self->{HEX} . (defined($_[0]) ? $_[0] : '');
1224 1 50       7 if (index($hex, ':') >= 0) {
1225 1         11 $hex =~ s/^://; # start of input
1226 1 50       20 if ($hex =~ s/:\s*\Z//) { # end of input
1227 1         9 my $leftover = (length($hex) % 4); # need to pad!
1228 1 50       4 $hex .= "\000" x (4 - $leftover) if $leftover; # zero pad
1229             }
1230             }
1231              
1232             # Get longest substring of length 4n possible; put rest back on queue:
1233 1         3 my $rem = length($hex) % 4;
1234 1 50       4 $self->{HEX} = ($rem ? substr($hex, -$rem) : '');
1235 1         5 for (; $rem; --$rem) { chop $hex };
  0         0  
1236 1 50       10 return undef if ($hex eq ''); # nothing to do!
1237              
1238             # Convert to uuencoded format:
1239 1         9 $hex =~ tr
1240             {!"#$%&'()*+,\x2D012345689@ABCDEFGHIJKLMNPQRSTUVXYZ[`abcdefhijklmpqr}
1241             { -_};
1242              
1243             # Now, uudecode:
1244 1         2 my $comp = '';
1245 1         1 my $len;
1246             my $up;
1247 1         4 local($^W) = 0; ### KLUDGE
1248 1         7 while ($hex =~ /\G(.{1,60})/gs) {
1249 63         85 $len = chr(32 + ((length($1)*3)>>2)); # compute length byte
1250 63         254 $comp .= unpack("u", $len . $1 ); # uudecode
1251             }
1252              
1253             # We now have the compressed binary... expand it:
1254             ### print "hex2comp: comp = $comp\n";
1255 1         8 $comp;
1256             }
1257              
1258             #------------------------------
1259             #
1260             # comp2bin_rewind
1261              
1262             sub comp2bin_rewind {
1263 10     10   15 my $self = shift;
1264 10         21 $self->{COMP} = '';
1265 10         20 $self->{LASTC} = '';
1266             }
1267              
1268             #------------------------------
1269             #
1270             # comp2bin_next COMP
1271             #
1272             # WARNING: argument is modified destructively for efficiency!!!!
1273              
1274             sub comp2bin_next {
1275 19     19   84 my $self = shift;
1276              
1277             # Concat new with queue... anything to do?
1278 19 50       60 my $comp = $self->{COMP} . (defined($_[0]) ? $_[0] : '');
1279 19 50       99 return undef if ($comp eq '');
1280              
1281             # For each character in compressed string...
1282 19         28 $self->{COMP} = '';
1283 19         26 my $lastc = $self->{LASTC}; # speed hack
1284 19         21 my $exp = ''; # expanded string
1285 19         19 my $i;
1286 19         20 my ($c, $n);
1287 19         50 for ($i = 0; $i < length($comp); $i++) {
1288 2859 100       4034 if (($c = substr($comp, $i, 1)) eq "\x90") { # MARK
1289             ### print "c = MARK\n";
1290 30 100       66 unless (length($n = substr($comp, ++$i, 1))) {
1291 3         6 $self->{COMP} = "\x90";
1292 3         30 last;
1293             }
1294             ### print "n = ", ord($n), "; lastc = ", ord($lastc), "\n";
1295 27 100       89 $exp .= ((ord($n) ? ($lastc x (ord($n)-1)) # repeat last char
1296             : ($lastc = "\x90"))); # literal MARK
1297             }
1298             else { # other CHAR
1299             ### print "c = ", ord($c), "\n";
1300 2829         4911 $exp .= ($lastc = $c);
1301             }
1302             ### print "exp is now $exp\n";
1303             }
1304              
1305             # Either hit EOS, or there's a MARK char at the very end:
1306 19         36 $self->{LASTC} = $lastc;
1307             ### print "leaving with lastc=$lastc and comp=$self->{COMP}\n";
1308             ### print "comp2bin: exp = $exp\n";
1309 19         66 $exp;
1310             }
1311              
1312              
1313              
1314              
1315              
1316              
1317             #============================================================
1318             #
1319             package Convert::BinHex::Fork;
1320             #
1321             #============================================================
1322              
1323             =head2 Convert::BinHex::Fork
1324              
1325             A fork in a Macintosh file.
1326              
1327             # How to get them...
1328             $data_fork = $HQX->data; # get the data fork
1329             $rsrc_fork = $HQX->resource; # get the resource fork
1330              
1331             # Make a new fork:
1332             $FORK = Convert::BinHex::Fork->new(Path => "/tmp/file.data");
1333             $FORK = Convert::BinHex::Fork->new(Data => $scalar);
1334             $FORK = Convert::BinHex::Fork->new(Data => \@array_of_scalars);
1335              
1336             # Get/set the length of the data fork:
1337             $len = $FORK->length;
1338             $FORK->length(170); # this overrides the REAL value: be careful!
1339              
1340             # Get/set the path to the underlying data (if in a disk file):
1341             $path = $FORK->path;
1342             $FORK->path("/tmp/file.data");
1343              
1344             # Get/set the in-core data itself, which may be a scalar or an arrayref:
1345             $data = $FORK->data;
1346             $FORK->data($scalar);
1347             $FORK->data(\@array_of_scalars);
1348              
1349             # Get/set the CRC:
1350             $crc = $FORK->crc;
1351             $FORK->crc($crc);
1352              
1353             =cut
1354              
1355              
1356             # Import some stuff into our namespace:
1357             *binhex_crc = \&Convert::BinHex::binhex_crc;
1358              
1359             #------------------------------
1360             #
1361             # new PARAMHASH
1362              
1363             sub new {
1364 6     6   16 my ($class, %params) = @_;
1365 6         31 bless \%params, $class;
1366             }
1367              
1368             #------------------------------
1369             #
1370             # length [VALUE]
1371              
1372             sub length {
1373 15     15   21 my $self = shift;
1374              
1375             # Set length?
1376 15 100       40 $self->{Length} = shift if @_;
1377              
1378             # Return explicit length, if any
1379 15 100       74 return $self->{Length} if defined($self->{Length});
1380              
1381             # Compute it:
1382 2 100       9 if (defined($self->{Path})) {
    50          
    0          
1383 1         42 return (-s $self->{Path});
1384             }
1385             elsif (!ref($self->{Data})) {
1386 1         8 return length($self->{Data});
1387             }
1388             elsif (ref($self->{Data} eq 'ARRAY')) {
1389 0         0 my $n = 0;
1390 0         0 foreach (@{$self->{Data}}) { $n += length($_) }
  0         0  
  0         0  
1391 0         0 return $n;
1392             }
1393 0         0 return undef; # unknown!
1394             }
1395              
1396             #------------------------------
1397             #
1398             # path [VALUE]
1399              
1400             sub path {
1401 0     0   0 my $self = shift;
1402 0 0       0 if (@_) { $self->{Path} = shift; delete $self->{Data} }
  0         0  
  0         0  
1403 0         0 $self->{Path};
1404             }
1405              
1406             #------------------------------
1407             #
1408             # data [VALUE]
1409              
1410             sub data {
1411 0     0   0 my $self = shift;
1412 0 0       0 if (@_) { $self->{Data} = shift; delete $self->{Path} }
  0         0  
  0         0  
1413 0         0 $self->{Data};
1414             }
1415              
1416             #------------------------------
1417             #
1418             # crc [VALUE]
1419              
1420             sub crc {
1421 3     3   4 my $self = shift;
1422 3 100       51 @_ ? $self->{CRC} = shift : $self->{CRC};
1423             }
1424              
1425             #------------------------------
1426             #
1427             # encode OUT, B2H
1428             #
1429             # Instance method, private. Encode this fork as part of a BinHex stream.
1430             # It will be printed to handle OUT using the binhexer B2H.
1431              
1432             sub encode {
1433 2     2   4 my ($self, $OUT, $B2H) = @_;
1434 2         5 my $buf = '';
1435 2 50 50     1029 require POSIX if $^O||'' eq "MacOS";
1436 2 50 50     7236 require Fcntl if $^O||'' eq "MacOS";
1437 2         5 my $fd;
1438              
1439             # Reset the CRC:
1440 2         4 $self->{CRC} = 0;
1441              
1442             # Output the data, calculating the CRC as we go:
1443 2 100       13 if (defined($self->{Path})) { # path to fork file
    50          
    50          
    0          
1444 1 50 50     153 if ($^O||'' eq "MacOS" and $self->{Fork} eq "RSRC") {
      33        
1445 0         0 $fd = POSIX::open($self->{Path},&POSIX::O_RDONLY | &Fcntl::O_RSRC);
1446 0         0 while (POSIX::read($fd, $buf, 2048) > 0) {
1447 0         0 $self->{CRC} = binhex_crc($buf, $self->{CRC});
1448 0         0 $OUT->print($B2H->next($buf));
1449             }
1450 0         0 POSIX::close($fd);
1451             }
1452             else {
1453 1 50       86 open FORK, $self->{Path} or die "$self->{Path}: $!";
1454 1         34 while (read(\*FORK, $buf, 2048)) {
1455 2         26 $self->{CRC} = binhex_crc($buf, $self->{CRC});
1456 2         11 $OUT->print($B2H->next($buf));
1457             }
1458 1         20 close FORK;
1459             }
1460             }
1461             elsif (!defined($self->{Data})) { # nothing!
1462 0 0       0 &Carp::carp("no data in fork!") unless $Convert::BinHex::QUIET;
1463             }
1464             elsif (!ref($self->{Data})) { # scalar
1465 1         4 $self->{CRC} = binhex_crc($self->{Data}, $self->{CRC});
1466 1         4 $OUT->print($B2H->next($self->{Data}));
1467             }
1468             elsif (ref($self->{Data}) eq 'ARRAY') { # array of scalars
1469 0         0 foreach $buf (@{$self->{Data}}) {
  0         0  
1470 0         0 $self->{CRC} = binhex_crc($buf, $self->{CRC});
1471 0         0 $OUT->print($B2H->next($buf));
1472             }
1473             }
1474             else {
1475 0         0 &Carp::croak("bad/unsupported data in fork");
1476             }
1477              
1478             # Finish the CRC, and output it:
1479 2         11 $self->{CRC} = binhex_crc("\000\000", $self->{CRC});
1480 2         11 $OUT->print($B2H->next(pack("n", $self->{CRC})));
1481 2         11 1;
1482             }
1483              
1484              
1485              
1486              
1487             #============================================================
1488             #
1489             package Convert::BinHex::IO_Handle;
1490             #
1491             #============================================================
1492              
1493             # Wrap a non-object filehandle inside a blessed, printable interface:
1494             # Does nothing if the given $fh is already a blessed object.
1495             sub wrap {
1496 2     2   6 my ($class, $fh) = @_;
1497 5     5   27375 no strict 'refs';
  5         11  
  5         2534  
1498 2 50       11 $fh or $fh = select; # no filehandle means selected one
1499 2 50       21 ref($fh) or $fh = \*$fh; # scalar becomes a globref
1500 2 100 66     29 return $fh if (ref($fh) and (ref($fh) !~ /^(GLOB|FileHandle)$/));
1501 1         10 bless \$fh, $class; # wrap it in a printable interface
1502             }
1503             sub print {
1504 0     0   0 my $FH = ${shift(@_)};
  0         0  
1505 0         0 print $FH @_;
1506             }
1507             sub getline {
1508 1     1   2 my $FH = ${shift(@_)};
  1         3  
1509 1         24 scalar(<$FH>);
1510             }
1511             sub read {
1512 1     1   2 read ${$_[0]}, $_[1], $_[2];
  1         27  
1513             }
1514              
1515              
1516              
1517             #============================================================
1518             #
1519             package Convert::BinHex::IO_Scalar;
1520             #
1521             #============================================================
1522              
1523             # Wrap a scalar inside a blessed, printable interface:
1524             sub wrap {
1525 0     0     my ($class, $scalarref) = @_;
1526 0 0         defined($scalarref) or $scalarref = \"";
1527 0           pos($$scalarref) = 0;
1528 0           bless $scalarref, $class;
1529             }
1530             sub print {
1531 0     0     my $self = shift;
1532 0           $$self .= join('', @_);
1533 0           1;
1534             }
1535             sub getline {
1536 0     0     my $self = shift;
1537 0 0         ($$self =~ /\G(.*?\n?)/g) or return undef;
1538 0           return $1;
1539             }
1540             sub read {
1541 0     0     my $self = shift;
1542 0           $_[0] = substr($$self, pos($$self), $_[1]);
1543 0           pos($$self) += $_[1];
1544 0           return length($_[0]);
1545             }
1546              
1547              
1548              
1549             #==============================
1550              
1551             =head1 UNDER THE HOOD
1552              
1553             =head2 Design issues
1554              
1555             =over 4
1556              
1557             =item BinHex needs a stateful parser
1558              
1559             Unlike its cousins I and I, BinHex format is not
1560             amenable to being parsed line-by-line. There appears to be no
1561             guarantee that lines contain 4n encoded characters... and even if there
1562             is one, the BinHex compression algorithm interferes: even when you
1563             can I one line at a time, you can't necessarily
1564             I a line at a time.
1565              
1566             For example: a decoded line ending with the byte C<\x90> (the escape
1567             or "mark" character) is ambiguous: depending on the next decoded byte,
1568             it could mean a literal C<\x90> (if the next byte is a C<\x00>), or
1569             it could mean n-1 more repetitions of the previous character (if
1570             the next byte is some nonzero C).
1571              
1572             For this reason, a BinHex parser has to be somewhat stateful: you
1573             cannot have code like this:
1574              
1575             #### NO! #### NO! #### NO! #### NO! #### NO! ####
1576             while () { # read HEX
1577             print hexbin($_); # convert and write BIN
1578             }
1579              
1580             unless something is happening "behind the scenes" to keep track of
1581             what was last done. I
1582             approach will B to work, if you only test it on BinHex files
1583             which do not use compression and which have 4n HEX characters
1584             on each line.>
1585              
1586             Since we have to be stateful anyway, we use the parser object to
1587             keep our state.
1588              
1589              
1590             =item We need to be handle large input files
1591              
1592             Solutions that demand reading everything into core don't cut
1593             it in my book. The first MPEG file that comes along can louse
1594             up your whole day. So, there are no size limitations in this
1595             module: the data is read on-demand, and filehandles are always
1596             an option.
1597              
1598              
1599             =item Boy, is this slow!
1600              
1601             A lot of the byte-level manipulation that has to go on, particularly
1602             the CRC computing (which involves intensive bit-shifting and masking)
1603             slows this module down significantly. What is needed perhaps is an
1604             I extension library where the slow pieces can be done more
1605             quickly... a Convert::BinHex::CRC, if you will. Volunteers, anyone?
1606              
1607             Even considering that, however, it's slower than I'd like. I'm
1608             sure many improvements can be made in the HEX-to-BIN end of things.
1609             No doubt I'll attempt some as time goes on...
1610              
1611             =back
1612              
1613              
1614              
1615             =head2 How it works
1616              
1617             Since BinHex is a layered format, consisting of...
1618              
1619             A Macintosh file [the "BIN"]...
1620             Encoded as a structured 8-bit bytestream, then...
1621             Compressed to reduce duplicate bytes, then...
1622             Encoded as 7-bit ASCII [the "HEX"]
1623              
1624             ...there is a layered parsing algorithm to reverse the process.
1625             Basically, it works in a similar fashion to stdio's fread():
1626              
1627             0. There is an internal buffer of decompressed (BIN) data,
1628             initially empty.
1629             1. Application asks to read() n bytes of data from object
1630             2. If the buffer is not full enough to accomodate the request:
1631             2a. The read() method grabs the next available chunk of input
1632             data (the HEX).
1633             2b. HEX data is converted and decompressed into as many BIN
1634             bytes as possible.
1635             2c. BIN bytes are added to the read() buffer.
1636             2d. Go back to step 2a. until the buffer is full enough
1637             or we hit end-of-input.
1638              
1639             The conversion-and-decompression algorithms need their own internal
1640             buffers and state (since the next input chunk may not contain all the
1641             data needed for a complete conversion/decompression operation).
1642             These are maintained in the object, so parsing two different
1643             input streams simultaneously is possible.
1644              
1645              
1646             =head1 WARNINGS
1647              
1648             Only handles C files, as per RFC-1741.
1649              
1650             Remember that Macintosh text files use C<"\r"> as end-of-line:
1651             this means that if you want a textual file to look normal on
1652             a non-Mac system, you probably want to do this to the data:
1653              
1654             # Get the data, and output it according to normal conventions:
1655             foreach ($HQX->read_data) { s/\r/\n/g; print }
1656              
1657              
1658             =head1 AUTHOR AND CREDITS
1659              
1660             Maintained by Stephen Nelson
1661              
1662             Written by Eryq, F / F
1663              
1664             Support for native-Mac conversion, I invaluable contributions in
1665             Alpha Testing, I a few patches, I the baseline binhex/debinhex
1666             programs, were provided by Paul J. Schinder (NASA/GSFC).
1667              
1668             Ken Lunde (Adobe) suggested incorporating the CAP file representation.
1669              
1670              
1671             =head1 LICENSE
1672              
1673             Copyright (c) 1997 by Eryq. All rights reserved. This program is free
1674             software; you can redistribute it and/or modify it under the same terms as
1675             Perl itself.
1676              
1677             This software comes with B of any kind.
1678             See the COPYING file in the distribution for details.
1679              
1680             =cut
1681              
1682             1;
1683              
1684             __END__