view release on metacpan or  search on metacpan

lib/Image/MetaData/JPEG/Segment.pm  view on Meta::CPAN

	    $_ eq 'APP12' ? $this->parse_app12()   : # PreExif ascii meta
	    $_ eq 'APP13' ? $this->parse_app13()   : # IPTC and Photoshop
	    $_ eq 'APP14' ? $this->parse_app14()   : # Adobe tags
	    # parse all JPEG image tags (SOI, EOI and RST* are trivial)
	    /^(SOI|EOI|RST)$/ ? do { /nothing/ }   :
	    $_ eq 'DQT'   ? $this->parse_dqt()     :
	    $_ eq 'DHT'   ? $this->parse_dht()     :
	    $_ eq 'DAC'   ? $this->parse_dac()     :
	    /^SOF|DHP/    ? $this->parse_sof()     :
	    $_ eq 'SOS'   ? $this->parse_sos()     :
	    $_ eq 'DNL'   ? $this->parse_dnl()     :
	    $_ eq 'DRI'   ? $this->parse_dri()     :
	    $_ eq 'EXP'   ? $this->parse_exp()     :
	    # this is the fallback case
	    $this->parse_unknown(); };
      STOP_PARSING: 
    };
    # parsing was ok if no error was catched by the eval.
    # Update the "error" member here to reflect this fact.
    $this->{error} = $@ if $@;
}

###########################################################
# This method re-executes the parsing of a segment after  #
# changing the segment nature (well, its name). This is   #
# very handy if you have a JPEG file with a correct appli-#
# cation segment exception made for its name. I used it   #
# the first time for a file having an ICC_profile segment #
# (usually in APP2) stored as APP13. Note that the name   #
# of the segment is permanently changed, so, if the file  #
# is rewritten to disk, it will be "correct".             #
###########################################################
sub reparse_as {
    my ($this, $new_name) = @_;
    # change the nature of this segment by overwriting its name
    $this->{name} = $new_name;
    # re-execute the parsing
    $this->parse();
}

###########################################################
# This method is the entry point for dumping the data     #
# structures stored in the records into the private data  #
# area. This method needs to be called before rewriting a #
# file to the disk, if any record was changed/added/elimi-#
# nated. The routine dispatches to more specific methods. #
# ------------------------------------------------------- #
# A segment with errors cannot be updated (a security     #
# measure: do not update what you do not understand).     #
# Entropy-coded segments or past-the-end garbage do not   #
# need being updated: the method returns immediately.     #
# ------------------------------------------------------- #
# update() saves a reference to the old segment data area #
# and restores it if the specialised update routine fails.#
# This only generate a warning! Are there cleverer ways   #
# to handle this case? It is however better to have a     #
# corrupt object in memory, than a corrupt object written #
# over the original. Currently, this is restricted to the #
# possibility that an updated segment becomes too large.  #
###########################################################
sub update {
    my ($this) = @_;
    # get the name of the segment
    my $name = $this->{name};
    # return immediately if this is an entropy-coded segment or 
    # past-the-end garbage. There is no need to "update" them
    return if $name =~ /ECS|Post-EOI/;
    # if the segment was not correctly parsed, warn and return
    $this->die('This segment is faulty') if $this->{error};
    # this might come also from 'NOPARSE'
    $this->die('This segment has no records') unless @{$this->{records}};
    # save a copy of the old data area.
    my $old_content = $this->{dataref};
    # blank the data area (do not assign directly to a reference to the
    # null string, since it is not modifiable in some implementations!)
    $this->{dataref} = \ (my $ns = '');
    # an error variable for specific update routines
    my $error = undef;
    # call more specific routines for segments we know how
    # to update. Generate an error if the type is not managed.
    # (SOI, EOI and RST* are trivial and should not get here)
    for ($name) {
	$error = $this->dump_com(),   next if $_ eq 'COM';
	$error = $this->dump_app1(),  next if $_ eq 'APP1';
	$error = $this->dump_app13(), next if $_ eq 'APP13';
	$error = "Update routine for '$_' not yet implemented"; }
    # get the size of the new data area
    my $length = $this->size();
    # if new size is too large, set the error flag
    $error = "Segment '${name}' too large (len=${length}, " .
	"max=${JPEG_SEG_MAX_LEN})" if $length > $JPEG_SEG_MAX_LEN;
    # if the update failed, revert to the old content
    if ($error) {
	$this->warn("Update failed [$error]: reverting to old content ...");
	$this->{dataref} = $old_content; }
}

###########################################################
# This method outputs the current segment data area into  #
# a file handle. The segment "preamble" is prepended, ex- #
# ception made for raw data (scans). The preamble always  #
# includes the 0xff byte followed by the segment marker.  #
# A Segment which can accept real data also requires a    #
# two-byte data count. The return value is the error      #
# status of the print calls.                              #
# ------------------------------------------------------- #
# If the segment size is too large, a warning is printed  #
# and 0 is returned (this can make the file invalid);     #
# this is however just for debugging, I hope ....         #
#=========================================================#
# Note that the data area of a segment can be void and,   #
# nonetheless, the segment might require a segment length #
# word (e.g., a "" comment). In practise, the only seg-   #
# ments not needing the length word are SOI, EOI and RST*.#
###########################################################
sub output_segment_data {
    my ($this, $out) = @_;
    # collect the name of the segment and the length of the data area
    my $name   = $this->{name};
    my $length = $this->size();
    # Check segment length and throw an exception in case it is too