view release on metacpan or  search on metacpan

lib/Image/ExifTool/Jpeg2000.pm  view on Meta::CPAN

                # not sure why, but EXIF box is padded with leading 0's in my sample
                my $pad = $dirName eq 'Exif' ? "\0\0\0\0" : '';
                if ($$et{IsJXL} and $compress) {
                    # create as Brotli-compressed metadata
                    if (eval { require IO::Compress::Brotli }) {
                        my $compressed;
                        eval { $compressed = IO::Compress::Brotli::bro($pad . $newdir) };
                        if ($@ or not $compressed) {
                            BrotliWarn($et, $dirName);
                        } else {
                            $et->VPrint(0, "  Writing Brotli-compressed $dir\n");
                            $newdir = $compressed;
                            $pad = $tag;
                            $tag = 'brob';
                        }
                    } else {
                        $et->Warn('Install IO::Compress::Brotli to create Brotli-compressed metadata');
                    }
                }
                my $boxhdr = pack('N', length($newdir) + length($pad) + 8) . $tag;
                Write($outfile, $boxhdr, $pad, $newdir) or return 0;
                next;
            }
        }
        next unless $uuid{$dirName};
        my $tagInfo;
        foreach $tagInfo (@{$Image::ExifTool::Jpeg2000::Main{uuid}}) {
            next unless $$tagInfo{Name} eq $dirName;
            my $subdir = $$tagInfo{SubDirectory};
            my $tagTable = GetTagTable($$subdir{TagTable});
            my %dirInfo = (
                DirName => $$subdir{DirName} || $dirName,
                Parent => 'JP2',
            );
            # remove "UUID-" from start of directory name to allow appropriate
            # directories to be written as a block
            $dirInfo{DirName} =~ s/^UUID-//;
            my $newdir = $et->WriteDirectory(\%dirInfo, $tagTable, $$subdir{WriteProc});
            if (defined $newdir and length $newdir) {
                my $boxhdr = pack('N', length($newdir) + 24) . 'uuid' . $uuid{$dirName};
                Write($outfile, $boxhdr, $newdir) or return 0;
                last;
            }
        }
    }
    return 1;
}

#------------------------------------------------------------------------------
# Create Color Specification Box
# Inputs: 0) ExifTool object ref, 1) Output file or scalar ref
# Returns: 1 on success
sub CreateColorSpec($$)
{
    my ($et, $outfile) = @_;
    my $meth   = $et->GetNewValue('Jpeg2000:ColorSpecMethod');
    my $prec   = $et->GetNewValue('Jpeg2000:ColorSpecPrecedence') || 0;
    my $approx = $et->GetNewValue('Jpeg2000:ColorSpecApproximation') || 0;
    my $icc    = $et->GetNewValue('ICC_Profile');
    my $space  = $et->GetNewValue('Jpeg2000:ColorSpace');
    my $cdata  = $et->GetNewValue('Jpeg2000:ColorSpecData');
    unless ($meth) {
        if ($icc) {
            $meth = 2;
        } elsif (defined $space) {
            $meth = 1;
        } elsif (defined $cdata) {
            $meth = 4;
        } else {
            $et->Warn('Color space not defined'), return 0;
        }
    }
    if ($meth eq '1') {
        defined $space or $et->Warn('Must specify ColorSpace'), return 0;
        $cdata = pack('N', $space);
    } elsif ($meth eq '2' or $meth eq '3') {
        defined $icc or $et->Warn('Must specify ICC_Profile'), return 0;
        $cdata = $icc;
    } elsif ($meth eq '4') {
        defined $cdata or $et->Warn('Must specify ColorSpecData'), return 0;
    } else {
        $et->Warn('Unknown ColorSpecMethod'), return 0;
    }
    my $boxhdr = pack('N', length($cdata) + 11) . 'colr';
    Write($outfile, $boxhdr, pack('CCC',$meth,$prec,$approx), $cdata) or return 0;
    ++$$et{CHANGED};
    $et->VPrint(1, "    + Jpeg2000:ColorSpec\n");
    return 1;
}

#------------------------------------------------------------------------------
# Process JPEG 2000 box
# Inputs: 0) ExifTool object reference, 1) dirInfo reference, 2) Pointer to tag table
# Returns: 1 on success when reading, or -1 on write error
#          (or JP2 box or undef when writing from buffer)
sub ProcessJpeg2000Box($$$)
{
    my ($et, $dirInfo, $tagTablePtr) = @_;
    my $dataPt = $$dirInfo{DataPt};
    my $dataLen = $$dirInfo{DataLen};
    my $dataPos = $$dirInfo{DataPos} || 0;
    my $dirLen = $$dirInfo{DirLen} || 0;
    my $dirStart = $$dirInfo{DirStart} || 0;
    my $base = $$dirInfo{Base} || 0;
    my $outfile = $$dirInfo{OutFile};
    my $dirName = $$dirInfo{DirName} || '';
    my $dirEnd = $dirStart + $dirLen;
    my ($err, $outBuff, $verbose, $doColour, $hash, $raf);

    if ($dataPt) {
        # save C2PA JUMBF as a block if requested
        if ($dirName eq 'JUMBF' and $$et{REQ_TAG_LOOKUP}{jumbf} and not $$dirInfo{NoBlockSave}) {
            if ($dirStart or $dirLen ne length($$dataPt)) {
                my $dat = substr($$dataPt, $dirStart, $dirLen);
                $et->FoundTag(JUMBF => \$dat);
            } else {
                $et->FoundTag(JUMBF => $dataPt);
            }
        }
    } else {
        $raf = $$dirInfo{RAF};  # read from RAF
    }

    if ($outfile) {
        unless ($raf) {
            # buffer output to be used for return value
            $outBuff = '';
            $outfile = \$outBuff;
        }
        # determine if we will be writing colr box
        if ($dirName eq 'JP2Header') {
            $doColour = 2 if defined $et->GetNewValue('ColorSpecMethod') or $et->GetNewValue('ICC_Profile') or
                             defined $et->GetNewValue('ColorSpecPrecedence') or defined $et->GetNewValue('ColorSpace') or
                             defined $et->GetNewValue('ColorSpecApproximation') or defined $et->GetNewValue('ColorSpecData');
        }
    } else {
        # (must not set verbose flag when writing!)
        $verbose = $$et{OPTIONS}{Verbose};
        $et->VerboseDir($dirName) if $verbose;
        # do hash if requested, but only for top-level image data
        $hash = $$et{ImageDataHash} if $raf;
    }
    # loop through all contained boxes
    my ($pos, $boxLen, $lastBox);
    for ($pos=$dirStart; ; $pos+=$boxLen) {