File Coverage

blib/lib/Image/MetaData/JPEG/Segment.pm
Criterion Covered Total %
statement 164 164 100.0
branch 105 118 88.9
condition 20 26 76.9
subroutine 28 28 100.0
pod 0 22 0.0
total 317 358 88.5


line stmt bran cond sub pod time code
1             ###########################################################
2             # A Perl package for showing/modifying JPEG (meta)data. #
3             # Copyright (C) 2004,2005,2006 Stefano Bettelli #
4             # See the COPYING and LICENSE files for license terms. #
5             ###########################################################
6             package Image::MetaData::JPEG::Segment;
7             use Image::MetaData::JPEG::data::Tables
8 15     15   3761 qw(:JPEGgrammar :Endianness :RecordTypes);
  15         19  
  15         3298  
9 15     15   433 use Image::MetaData::JPEG::Backtrace;
  15         21  
  15         245  
10 15     15   6615 use Image::MetaData::JPEG::Record;
  15         33  
  15         453  
11 15     15   86 no integer;
  15         20  
  15         51  
12 15     15   249 use strict;
  15         21  
  15         352  
13 15     15   67 use warnings;
  15         22  
  15         29647  
14              
15             ###########################################################
16             # These simple methods should be used instead of standard #
17             # "warn" and "die" in this package; they print a much #
18             # more elaborated error message (including a stack trace).#
19             # Warnings can be turned off altogether simply by setting #
20             # Image::MetaData::JPEG::show_warnings to false. #
21             ###########################################################
22 13     13 0 726 sub warn { my ($this, $message) = @_;
23 13 100       52 warn Image::MetaData::JPEG::Backtrace::backtrace
24             ($message, "Warning" . $this->info(), $this)
25             if $Image::MetaData::JPEG::show_warnings; }
26 22     22 0 40 sub die { my ($this, $message) = @_;
27 22         67 die Image::MetaData::JPEG::Backtrace::backtrace
28             ($message, "Fatal error" . $this->info(), $this);}
29 34   100 34 0 44 sub info { my ($this) = @_; my $name = $this->{name} || '';
  34         98  
30 34         157 return " [segment type $name]"; }
31              
32             ###########################################################
33             # JPEG segment header constructor. Its arguments are: the #
34             # segment type (a multicharacter string, not the marker), #
35             # a reference to a raw data buffer and a parse flag. The #
36             # raw buffer is saved internally through its reference #
37             # (no copy is done). If its parse flag does not match #
38             # "NOPARSE", and its type is parseable, the Segment has #
39             # its key-value pairs extracted to JPEG::Record's in the #
40             # 'records' list. #
41             #=========================================================#
42             # The first four bytes in the Segment mean: #
43             # #
44             # 2 bytes segment marker (0xff..) #
45             # 2 bytes length (including this value) #
46             # #
47             # The marker is a two byte value, whose first byte is #
48             # always 0xff. The value of the second byte defines the #
49             # segment type. It is assumed that the buffer which is #
50             # passed to this constructor DOES NOT contain these four #
51             # bytes; in fact, the segment type can be deduced by its #
52             # symbolic name (first argument), and the buffer size can #
53             # be calculated with the length() function. This simpli- #
54             # fies a lot of repetitive code, but it must be kept in #
55             # mind when the file is written back to the filesystem. #
56             #=========================================================#
57             # $this->{endianness} (a private field) contains the #
58             # current endianness, i.e. the endianness to be used for #
59             # reading the next values while parsing the data area. #
60             # Its significant is therefore only transient, and it is #
61             # set to undef at the end of the constructor. #
62             #=========================================================#
63             # $this->{error} is normally set to "undef". If, however, #
64             # an error occurred during the parsing stage in the cons- #
65             # tructor, this variable is set to an error message. The #
66             # intended use is the following: a Segment with errors #
67             # can be inspected (partially, of course, because parsing #
68             # did not terminate correctly) but not modified (that is, #
69             # the update method, which overwrites the area pointed to #
70             # by $this->{dataref}, must be inhibited): it can only be #
71             # rewritten to disk as it is. #
72             ###########################################################
73             sub new {
74 826     826 0 23642 my ($pkg, $name, $dataref, $flag) = @_;
75             # if $dataref is undef, point it to a *modifiable* empty string
76 826 100       4904 my $this = bless {
77             name => $name,
78             dataref => defined $dataref ? $dataref : \ (my $ns = ''),
79             records => [],
80             error => undef,
81             endianness => undef,
82             }, $pkg;
83             # die on various error conditions
84 826 100 66     3056 $this->die('Invalid segment name') unless defined $name && ! ref $name;
85 825 50 66     2689 $this->die('Invalid data reference') if defined $dataref && ! ref $dataref;
86             # parse the segment (pass the $flag)
87 825         1398 $this->parse($flag);
88             # return a reference to the constructed object
89 825         2127 return $this;
90             }
91              
92             ###########################################################
93             # This method parses or reparses the current segment. It #
94             # only dispatches the flow to specific subroutines based #
95             # on the segment name. The error flag is reset to undef #
96             # before parse_*, so that, at the end, it reflects only #
97             # errors occurred during this parse session. If the $flag #
98             # argument is set to "NOPARSE", this method simulates an #
99             # error and refuses to proceed further. The parsed data #
100             # array "@records" is flushed when entering this routine. #
101             #=========================================================#
102             # Segment parsing is enclosed in an eval block, so that #
103             # errors are not fatal (they work as trapped exceptions, #
104             # and the die-string is converted into a message). #
105             #=========================================================#
106             # See also the notes in the constructor about the private #
107             # var. $this->{endianness} and the use of $this->{error}. #
108             ###########################################################
109             sub parse {
110 833     833 0 810 my ($this, $flag) = @_;
111             # locally set endianness to big endian
112 833         1566 local $this->{endianness} = $BIG_ENDIAN;
113             # reset the error flag and clear the data set
114 833         879 $this->{error} = undef;
115 833         1017 $this->{records} = [];
116             # call the specific parse routines inside an eval block,
117             # so that errors are not fatal...
118 833         1259 eval {
119             # if $flag matches "NOPARSE", we don't need to parse
120 833 100 66     2353 goto STOP_PARSING if ($flag && $flag =~ /NOPARSE/);
121             # this is a stupid Perl-style switch
122 570         927 for ($this->{name}) {
123             # parse all informative tags
124             $_ eq 'COM' ? $this->parse_com() : # User comments
125             $_ eq 'APP0' ? $this->parse_app0() : # JFIF
126             $_ eq 'APP1' ? $this->parse_app1() : # Exif or XMP
127             $_ eq 'APP2' ? $this->parse_app2() : # FPXR or ICC_Prof
128             $_ eq 'APP3' ? $this->parse_app3() : # Additonal metadata
129             $_ eq 'APP4' ? $this->parse_unknown() : # HPSC
130             $_ eq 'APP12' ? $this->parse_app12() : # PreExif ascii meta
131             $_ eq 'APP13' ? $this->parse_app13() : # IPTC and Photoshop
132             $_ eq 'APP14' ? $this->parse_app14() : # Adobe tags
133             # parse all JPEG image tags (SOI, EOI and RST* are trivial)
134 570 100       5201 /^(SOI|EOI|RST)$/ ? do { /nothing/ } :
  121 100       260  
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    100          
    100          
    100          
    100          
    100          
135             $_ eq 'DQT' ? $this->parse_dqt() :
136             $_ eq 'DHT' ? $this->parse_dht() :
137             $_ eq 'DAC' ? $this->parse_dac() :
138             /^SOF|DHP/ ? $this->parse_sof() :
139             $_ eq 'SOS' ? $this->parse_sos() :
140             $_ eq 'DNL' ? $this->parse_dnl() :
141             $_ eq 'DRI' ? $this->parse_dri() :
142             $_ eq 'EXP' ? $this->parse_exp() :
143             # this is the fallback case
144             $this->parse_unknown(); };
145             STOP_PARSING:
146 820         957 };
147             # parsing was ok if no error was catched by the eval.
148             # Update the "error" member here to reflect this fact.
149 833 100       2059 $this->{error} = $@ if $@;
150             }
151              
152             ###########################################################
153             # This method re-executes the parsing of a segment after #
154             # changing the segment nature (well, its name). This is #
155             # very handy if you have a JPEG file with a correct appli-#
156             # cation segment exception made for its name. I used it #
157             # the first time for a file having an ICC_profile segment #
158             # (usually in APP2) stored as APP13. Note that the name #
159             # of the segment is permanently changed, so, if the file #
160             # is rewritten to disk, it will be "correct". #
161             ###########################################################
162             sub reparse_as {
163 8     8 0 4003 my ($this, $new_name) = @_;
164             # change the nature of this segment by overwriting its name
165 8         17 $this->{name} = $new_name;
166             # re-execute the parsing
167 8         18 $this->parse();
168             }
169              
170             ###########################################################
171             # This method is the entry point for dumping the data #
172             # structures stored in the records into the private data #
173             # area. This method needs to be called before rewriting a #
174             # file to the disk, if any record was changed/added/elimi-#
175             # nated. The routine dispatches to more specific methods. #
176             # ------------------------------------------------------- #
177             # A segment with errors cannot be updated (a security #
178             # measure: do not update what you do not understand). #
179             # Entropy-coded segments or past-the-end garbage do not #
180             # need being updated: the method returns immediately. #
181             # ------------------------------------------------------- #
182             # update() saves a reference to the old segment data area #
183             # and restores it if the specialised update routine fails.#
184             # This only generate a warning! Are there cleverer ways #
185             # to handle this case? It is however better to have a #
186             # corrupt object in memory, than a corrupt object written #
187             # over the original. Currently, this is restricted to the #
188             # possibility that an updated segment becomes too large. #
189             ###########################################################
190             sub update {
191 268     268 0 7752 my ($this) = @_;
192             # get the name of the segment
193 268         482 my $name = $this->{name};
194             # return immediately if this is an entropy-coded segment or
195             # past-the-end garbage. There is no need to "update" them
196 268 50       1124 return if $name =~ /ECS|Post-EOI/;
197             # if the segment was not correctly parsed, warn and return
198 268 100       641 $this->die('This segment is faulty') if $this->{error};
199             # this might come also from 'NOPARSE'
200 265 100       247 $this->die('This segment has no records') unless @{$this->{records}};
  265         666  
201             # save a copy of the old data area.
202 263         382 my $old_content = $this->{dataref};
203             # blank the data area (do not assign directly to a reference to the
204             # null string, since it is not modifiable in some implementations!)
205 263         464 $this->{dataref} = \ (my $ns = '');
206             # an error variable for specific update routines
207 263         315 my $error = undef;
208             # call more specific routines for segments we know how
209             # to update. Generate an error if the type is not managed.
210             # (SOI, EOI and RST* are trivial and should not get here)
211 263         462 for ($name) {
212 263 100       563 $error = $this->dump_com(), next if $_ eq 'COM';
213 261 100       1023 $error = $this->dump_app1(), next if $_ eq 'APP1';
214 98 100       421 $error = $this->dump_app13(), next if $_ eq 'APP13';
215 1         3 $error = "Update routine for '$_' not yet implemented"; }
216             # get the size of the new data area
217 263         716 my $length = $this->size();
218             # if new size is too large, set the error flag
219 263 100       654 $error = "Segment '${name}' too large (len=${length}, " .
220             "max=${JPEG_SEG_MAX_LEN})" if $length > $JPEG_SEG_MAX_LEN;
221             # if the update failed, revert to the old content
222 263 100       1048 if ($error) {
223 5         60 $this->warn("Update failed [$error]: reverting to old content ...");
224 5         60 $this->{dataref} = $old_content; }
225             }
226              
227             ###########################################################
228             # This method outputs the current segment data area into #
229             # a file handle. The segment "preamble" is prepended, ex- #
230             # ception made for raw data (scans). The preamble always #
231             # includes the 0xff byte followed by the segment marker. #
232             # A Segment which can accept real data also requires a #
233             # two-byte data count. The return value is the error #
234             # status of the print calls. #
235             # ------------------------------------------------------- #
236             # If the segment size is too large, a warning is printed #
237             # and 0 is returned (this can make the file invalid); #
238             # this is however just for debugging, I hope .... #
239             #=========================================================#
240             # Note that the data area of a segment can be void and, #
241             # nonetheless, the segment might require a segment length #
242             # word (e.g., a "" comment). In practise, the only seg- #
243             # ments not needing the length word are SOI, EOI and RST*.#
244             ###########################################################
245             sub output_segment_data {
246 282     282 0 1448 my ($this, $out) = @_;
247             # collect the name of the segment and the length of the data area
248 282         358 my $name = $this->{name};
249 282         394 my $length = $this->size();
250             # Check segment length and throw an exception in case it is too
251             # large. Do not run the check for raw data or past-the-end data.
252 282 50 33     605 $this->die(sprintf('Segment %s too large (len=%d, max=%d)',
253             $this->{name}, $length, $JPEG_SEG_MAX_LEN))
254             if $length > $JPEG_SEG_MAX_LEN && $name !~ /ECS|Post-EOI/;
255             # prepare the segment header (not needed for a raw data segment)
256 282 100       1075 my $preamble = ( $name =~ /ECS|Post-EOI/ ? "" :
257             pack("CC", $JPEG_PUNCTUATION, $JPEG_MARKER{$name}) );
258             # prepare the length word (not all segment types need it)
259 282 100       795 $preamble .= pack("n", 2 + $length)
260             unless $name =~ /SOI|EOI|RST|ECS|Post-EOI/;
261             # output the preamble and the data buffer (return the status)
262 282         214 return print {$out} $preamble . $this->data(0, $length);
  282         475  
263             }
264              
265             ###########################################################
266             # This method shows the content of the segment. It prints #
267             # a header, then inspects the directory recursively. #
268             ###########################################################
269             sub get_description {
270 257     257 0 2112 my ($this) = @_;
271             # prepare the marker and the error message
272 257         475 my $amarker = $JPEG_MARKER{$this->{name}};
273 257 50       263 my $error = $this->{error}; chomp $error if defined $error;
  257         399  
274             # prepare a header for this segment (was Segment_Banner)
275 257 100       367 my $description = sprintf("%7dB ", $this->size()) .
    50          
276             ($amarker ? sprintf "<0x%02x %5s>", $amarker, $this->{name} :
277             sprintf "<%10s>", $this->{name} ) .
278             ($error ? " {Faulty segment:\n $error}" : "") . "\n";
279             # a list for successive keys for numeric tag descriptions
280 257         375 my $names = [ $this->{name} ];
281             # show all the records we have in our structures (recursively)
282 257         421 $description .= $this->show_directory($this->{records}, $names);
283             }
284              
285             ###########################################################
286             # This method shows the content of a record directory in #
287             # a segment; the first argument is a record list refe- #
288             # rence; the second argument is a list to a list of names #
289             # used to resolve numeric tags. A string is returned. #
290             ###########################################################
291             sub show_directory {
292 405     405 0 450 my ($this, $records, $names) = @_;
293             # protection againts invalid references
294 405 50       695 return "" unless ref $records eq 'ARRAY';
295             # prepare the string to be returned at the end
296 405         357 my $description = "";
297             # an initially empty list for remembering sub-dirs
298 405         383 my @subdirs = ();
299             # show all records in this directory
300 405         525 foreach (@$records) {
301             # show the record content
302 2437         4359 $description .= $_->get_description($names);
303             # if this is a subdir, remember its reference
304 2437 100       4615 push @subdirs, $_ if $_->get_category() eq 'p';
305             }
306             # for every subdir we found, recurse
307 405         482 foreach (@subdirs) {
308             # get the directory name and reference
309 148         398 my ($dir_name, $directory) = ($_->{key}, $_->get_value());
310             # update the $names list
311 148         227 push @$names, $dir_name;
312             # print a sub-header for this directory
313 148         268 $description .= Directory_Banner($names, $directory);
314             # show the sub directory
315 148         379 $description .= $this->show_directory($directory, $names);
316             # pop the last dir name from @$names
317 148         276 pop @$names;
318             }
319             # return the string we cooked up
320 405         2239 return $description;
321             }
322              
323             ###########################################################
324             # This helper function returns a string to be used as a #
325             # generic header for a segment directory. #
326             ###########################################################
327             sub Directory_Banner {
328 148     148 0 154 my ($names, $dirref) = @_;
329             # protections against invalid references
330 148 50       291 $names = [] unless ref $names eq 'ARRAY';
331 148 50       272 $dirref = [], push @$names, "[invalid]" unless ref $dirref eq 'ARRAY';
332             # prepare parts of the description
333 148         249 my $buffer = join " --> ", @$names;
334 148         146 my $decoration = "*" x 10;
335 148         225 my $indentation = " \t" x scalar @$names;
336             # complete the description and return it
337 148         383 my $description = sprintf "%s%s %s %s (%2d records)",
338             $indentation, $decoration, $buffer, $decoration, scalar @$dirref;
339 148         319 return $description . "\n";
340             }
341              
342             ###########################################################
343             # This helper method is used to test a size condition, #
344             # i.e. that there is enough data (or exactly some amount #
345             # of data) in the data buffer. If the test fails, it dies #
346             ###########################################################
347             sub test_size {
348 6558     6558 0 6590 my ($this, $required, $message) = @_;
349             # positive $require: test not greater
350 6558 100 100     14797 return if $required >= 0 && $this->size() >= $required;
351             # negative $require: test equality (on -$required)
352 120 100 100     430 return if $required < 0 && $this->size() == (- $required);
353             # if test fails, call die and hope it is intercepted
354 4 50       7 my $precise = ""; $message = defined $message ? "($message)" : "";
  4         10  
355 4 100       11 $required *= -1, $precise = "exactly " if $required < 0;
356 4         10 $this->die(sprintf 'Size mismatch in segment %s %s:'
357             . ' required %s%dB, found %dB.', $this->{name},
358             $message, $precise, $required, $this->size());
359             }
360              
361             ###########################################################
362             # This is a helper method returning the size in bytes of #
363             # the data area, i.e. that pointed to by $this->{dataref} #
364             ###########################################################
365 8397     8397 0 6312 sub size { return length ${$_[0]{dataref}}; }
  8397         31630  
366              
367             ###########################################################
368             # This helper method returns a substring of the data area #
369             # (the arguments are offset and length). #
370             ###########################################################
371 25375     25375 0 18019 sub data { substr(${$_[0]{dataref}}, $_[1], $_[2]); }
  25375         61717  
372              
373             ###########################################################
374             # This helper method writes into the segment data area. #
375             # The first argument is a scalar or a scalar reference, #
376             # which (or whose content) is appended to the current #
377             # buffer. The method returns the appended string length. #
378             ###########################################################
379             sub set_data {
380 7820     7820 0 6684 my ($this, $addenda) = @_;
381             # get a reference to new data (remember that the
382             # first argument can be a scalar or a scalar reference)
383 7820 100       9358 my $addref = (ref $addenda) ? $addenda : \$addenda;
384             # append the new data through the ref
385 7820         5407 ${$this->{dataref}} .= $$addref;
  7820         10628  
386             # return the amount of appended data
387 7820         12807 return length $$addref;
388             }
389              
390             ###########################################################
391             # This private method processes the arguments for search #
392             # routines, like search_record and provide_subdirectory. #
393             # 1) a start directory is chosen by looking at the last #
394             # argument: if it is an ARRAY ref it is popped out #
395             # and used, otherwise the top-level directory (i.e., #
396             # $this->{records}) is selected; #
397             # 2) a $keystring is created by joining all remaining #
398             # arguments on '@', then this string is exploded into #
399             # a @keylist on the same character; #
400             # 3) the start directory and the @keylist is returned. #
401             ###########################################################
402             sub process_search_args {
403 14733     14733 0 12441 my $this = shift;
404             # empty list ==> push a single undefined value
405 14733 100       21756 @_ = (undef) unless @_;
406             # initialise the search directory: use the last argument if
407             # it is an array reference, the top-level directory otherwise
408 14733 100       26137 my $directory = ref $_[$#_] eq 'ARRAY' ? pop : $this->{records};
409             # delete all undefined or "false" arguments
410 14733         16275 @_ = grep { defined $_ } @_;
  15322         32060  
411             # join all remaining arguments
412 14733         19792 my $keystring = join('@', @_);
413             # split the resulting string on '@'
414 14733         25744 my @keylist = split('@', $keystring);
415             # delete all false arguments
416 14733         14034 @keylist = grep { $_ } @keylist;
  16626         22673  
417             # return processed arguments
418 14733         28343 return ($directory, @keylist);
419             }
420              
421             ###########################################################
422             # This method searches for a record with a given key in a #
423             # given record directory, returning a reference to the #
424             # record if the search was fruitful, undef otherwise. #
425             # The search is specified as follows: #
426             # 1) a start directory is chosen by looking at the last #
427             # argument: if it is an ARRAY ref it is popped out #
428             # and used, otherwise the top-level directory (i.e., #
429             # $this->{records}) is selected; #
430             # 2) a $keystring is created by joining all remaining #
431             # arguments on '@', then this string is exploded into #
432             # a @keylist on the same character; #
433             # 3) these keys are used for an iterative search start- #
434             # ing from the initially chosen directory: all but #
435             # the last key must correspond to $REFERENCE records. #
436             # ------------------------------------------------------- #
437             # If $key is exactly "FIRST_RECORD" / "LAST_RECORD", the #
438             # first/last record in the current directory is selected. #
439             ###########################################################
440             sub search_record {
441 13408     13408 0 15259 my $this = shift;
442             # transform the arguments
443 13408         18885 my ($directory, @keylist) = $this->process_search_args(@_);
444             # reset the searched $record to a fake record pointing to the root
445 13408         25437 my $record = $this->create_record('Fake', $REFERENCE, \ $this->{records});
446             # search iteratively with all elements in @keylist
447 13408         17171 for my $key (@keylist) {
448             # exit the loop as soon as a key is undefined
449 14574 50       19562 ($record = undef), last unless $key;
450             # update the current $record
451 230338         245323 $record =
452             # reserved key "FIRST_RECORD" returns first record
453             $key eq "FIRST_RECORD" ? $$directory[0] :
454             # reserved key "LAST_RECORD" returns last record
455             $key eq "LAST_RECORD" ? $$directory[$#$directory] :
456             # standard search (get first matching record or undef)
457 14574 100       30996 ((grep { $_->{key} eq $key } @$directory), undef)[0];
    100          
458             # stop if $record is undefined or is not a $REFERENCE
459 14574 100 100     49609 last unless $record && $record->get_category() eq 'p';
460             # update $directory for next search
461 4972         8841 $directory = $record->get_value(); }
462             # return the search result
463 13408         32891 return $record;
464             }
465              
466             ###########################################################
467             # A simple wrapper around search_record(): it returns the #
468             # record value if the search is ok, undef otherwise. #
469             ###########################################################
470             sub search_record_value {
471 3565     3565 0 25097 my $this = shift;
472             # call search_record passing all arguments through
473 3565         5496 my $record = $this->search_record(@_);
474             # return the record value if record is defined
475 3565 100       9120 return $record ? $record->get_value() : undef;
476             }
477              
478             ###########################################################
479             # This method looks for a path of subdirectories from a #
480             # given record list. The treatment of arguments is simi- #
481             # lar to that of search_record: all arguments are joined #
482             # to form a path specification, which is followed, and #
483             # the last directory (record list) is returned. An optio- #
484             # nal last argument may specify an initial directory for #
485             # the search (this defaults to $this->{records}). If any #
486             # subdir entry is not there, it is created on the fly. #
487             ###########################################################
488             sub provide_subdirectory {
489 1325     1325 0 3736 my $this = shift;
490             # transform the arguments
491 1325         2558 my ($dirref, @keylist) = $this->process_search_args(@_);
492             # search iteratively with all elements in @keylist
493 1325         1734 for my $key (@keylist) {
494             # keys cannot be undefined
495 1868 50       2721 $this->die('Undefined key') unless $key;
496             # search the subdirectory record
497 1868   66     2821 my $record = $this->search_record($key, $dirref) ||
498             $this->store_record($dirref, $key, $REFERENCE, \ []);
499             # die if $record is not a $REFERENCE
500 1868 50       3536 $this->die('Not a reference') unless $record->get_category() eq 'p';
501             # update $dirref for next search
502 1868         3143 $dirref = $record->get_value(); }
503             # return the search result
504 1325         2778 return $dirref;
505             }
506              
507             ###########################################################
508             # This method creates a (possibly multi-valued) JPEG seg- #
509             # ment record from a data buffer or from the segment data #
510             # area, and it is the lowest level record-related method, #
511             # the only one actually calling the JPEG::Record ctor. #
512             # It needs the record identifier, the value type, [a sca- #
513             # lar reference to read data from] or [the offset of the #
514             # memory to read in the data area], and an optional count.#
515             # A reference to the record is returned at the end . #
516             #=========================================================#
517             # If a scalar reference is passed, no check is performed #
518             # on the size of the referenced scalar, because it is as- #
519             # sumed that this is dealt with in the caller routine (be #
520             # sure that $count is correct in this case!), and all the #
521             # arguments are simply passed to the Record constructor. #
522             # The correct endianness is read from the value of the #
523             # current endianness, which is a private object member. #
524             ###########################################################
525             sub create_record {
526 38612     38612 0 42084 my ($this, $identifier, $type, $dataref, $count) = @_;
527             # if the third argument is an offset, we need to convert it
528 38612 100       57321 unless (ref $dataref) {
529             # the data reference is indeed an offset
530 23683         17175 my $offset = $dataref;
531             # buffer length is calculated by the Record class
532 23683         45664 my $length = Image::MetaData::JPEG::Record->get_size($type, $count);
533             # for variable-length types, $count is the real length
534 23683 100       33606 $length = $count if $length == 0;
535             # replace the third argument with a scalar reference
536 23683         31595 $dataref = \ $this->data($offset, $length);
537             # update the offset through its alias (dangerous)
538             # but don't complain if we have a read-only offset
539 23683         22472 eval { $_[3] += $length; };
  23683         26308  
540             }
541             # call the record constructor and return its value (a reference)
542 38612         86114 return new Image::MetaData::JPEG::Record
543             ($identifier, $type, $dataref, $count, $this->{endianness});
544             }
545              
546             ###########################################################
547             # This method is a wrapper for create_record returning #
548             # the parsed value and NOT storing the record internally #
549             # (for this reason we can set $identifier = 0). So, the #
550             # arguments are: type, data reference, count. The data #
551             # reference can be replaced by an offset, used to access #
552             # the internal segment data buffer. If the offset is an #
553             # lvalue, it is updated to point after the memory just #
554             # read. The count can be undefined (it defaults to 1). #
555             ###########################################################
556             sub read_record {
557             # @_ = (this, type, dataref/offset, count)
558 16652     16652 0 15565 my $this = shift;
559             # invoke create_record: the first argument (the identifier)
560             # is dummy, for the others we can use @_. Return the value
561 16652         22740 return $this->create_record(0, @_)->get_value();
562             }
563              
564             ###########################################################
565             # This method creates a generic JPEG segment record just #
566             # like read_record, stores it in the "records" list, and #
567             # returns a reference to the newly created record. If the #
568             # offset is an lvalue, it is updated to point after the #
569             # memory just read. See read_record for further details. #
570             #=========================================================#
571             # A list reference can be prepended to the argument list; #
572             # in this case it is used instead of $this->{records}. #
573             ###########################################################
574             sub store_record {
575             # @_ = (this, [record list,] identifier, type, dataref/offset, count)
576 8550     8550 0 8018 my $this = shift;
577             # get a reference to the record list; but if next argument
578             # is a reference, use it instead (and take it out of @_)
579 8550         7986 my $records = $this->{records};
580 8550 100       14299 $records = shift if ref $_[0];
581             # create a new record and insert it into the record
582             # list; we can use @_ for all the arguments.
583 8550         11745 push @$records, $this->create_record(@_);
584             # return a reference to the last record
585 8546         20330 return $$records[$#$records];
586             }
587              
588             ###########################################################
589             # Load other parts for this package. In order to avoid #
590             # that this file becomes too large, only general interest #
591             # methods are written here. #
592             ###########################################################
593             require 'Image/MetaData/JPEG/parsers/parsers.pl';
594             require 'Image/MetaData/JPEG/dumpers/dumpers.pl';
595              
596             # successful package load
597             1;