view release on metacpan or  search on metacpan

lib/Image/ExifTool/Writer.pl  view on Meta::CPAN

        # renaming didn't work, so copy the file instead
        unless ($self->Open(\*EXIFTOOL_SFN_IN, $file)) {
            $self->Error("Error opening '${file}'");
            return -1;
        }
        unless ($self->Open(\*EXIFTOOL_SFN_OUT, $newName, '>')) {
            close EXIFTOOL_SFN_IN;
            $self->Error("Error creating '${newName}'");
            return -1;
        }
        binmode EXIFTOOL_SFN_IN;
        binmode EXIFTOOL_SFN_OUT;
        my ($buff, $err);
        while (read EXIFTOOL_SFN_IN, $buff, 65536) {
            print EXIFTOOL_SFN_OUT $buff or $err = 1;
        }
        close EXIFTOOL_SFN_OUT or $err = 1;
        close EXIFTOOL_SFN_IN;
        if ($err) {
            $self->Unlink($newName);    # erase bad output file
            $self->Error("Error writing '${newName}'");
            return -1;
        }
        # preserve modification time
        my ($aTime, $mTime, $cTime) = $self->GetFileTime($file);
        $self->SetFileTime($newName, $aTime, $mTime, $cTime);
        # remove the original file
        $self->Unlink($file) or $self->Warn('Error removing old file');
    }
    $$self{NewName} = $newName; # remember new file name
    ++$$self{CHANGED};
    $self->VerboseValue('+ FileName', $newName);
    return 1;
}

#------------------------------------------------------------------------------
# Set file permissions, group/user id and various MDItem tags from new tag values
# Inputs: 0) ExifTool ref, 1) file name or glob (must be a name for MDItem tags)
# Returns: 1=something was set OK, 0=didn't try, -1=error (and warning set)
# Notes: There may be errors even if 1 is returned
sub SetSystemTags($$)
{
    my ($self, $file) = @_;
    my $result = 0;

    my $perm = $self->GetNewValue('FilePermissions');
    if (defined $perm) {
        if (eval { chmod($perm & 07777, $file) }) {
            $self->VerboseValue('+ FilePermissions', $perm);
            $result = 1;
        } else {
            $self->Warn('Error setting FilePermissions');
            $result = -1;
        }
    }
    my $uid = $self->GetNewValue('FileUserID');
    my $gid = $self->GetNewValue('FileGroupID');
    if (defined $uid or defined $gid) {
        defined $uid or $uid = -1;
        defined $gid or $gid = -1;
        if (eval { chown($uid, $gid, $file) }) {
            $self->VerboseValue('+ FileUserID', $uid) if $uid >= 0;
            $self->VerboseValue('+ FileGroupID', $gid) if $gid >= 0;
            $result = 1;
        } else {
            $self->Warn('Error setting FileGroup/UserID');
            $result = -1 unless $result;
        }
    }
    my $tag;
    foreach $tag (@writableMacOSTags) {
        my $nvHash;
        my $val = $self->GetNewValue($tag, \$nvHash);
        next unless $nvHash;
        if ($^O eq 'darwin') {
            ref $file and $self->Warn('Setting MDItem tags requires a file name'), last;
            require Image::ExifTool::MacOS;
            my $res = Image::ExifTool::MacOS::SetMacOSTags($self, $file, \@writableMacOSTags);
            $result = $res if $res == 1 or not $result;
            last;
        } elsif ($tag ne 'FileCreateDate') {
            $self->Warn('Can only set MDItem tags on MacOS');
            last;
        }
    }
    # delete Windows Zone.Identifier if specified
    my $zhash = $self->GetNewValueHash($Image::ExifTool::Extra{ZoneIdentifier});
    if ($zhash) {
        my $res = -1;
        if ($^O ne 'MSWin32') {
            $self->Warn('ZoneIdentifer is a Windows-only tag');
        } elsif (ref $file) {
            $self->Warn('Writing ZoneIdentifer requires a file name');
        } elsif (defined $self->GetNewValue('ZoneIdentifier', \$zhash)) {
            $self->Warn('ZoneIndentifier may only be deleted');
        } elsif (not eval { require Win32API::File }) {
            $self->Warn('Install Win32API::File to write ZoneIdentifier');
        } else {
            my ($wattr, $wide);
            my $zfile = "${file}:Zone.Identifier";
            if ($self->EncodeFileName($zfile)) {
                $wide = 1;
                $wattr = eval { Win32API::File::GetFileAttributesW($zfile) };
            } else {
                $wattr = eval { Win32API::File::GetFileAttributes($zfile) };
            }
            if ($wattr == Win32API::File::INVALID_FILE_ATTRIBUTES()) {
                $res = 0; # file doesn't exist, nothing to do
            } elsif ($wattr & Win32API::File::FILE_ATTRIBUTE_READONLY()) {
                $self->Warn('Zone.Identifier stream is read-only');
            } else {
                if ($wide) {
                    $res = 1 if eval { Win32API::File::DeleteFileW($zfile) };
                } else {
                    $res = 1 if eval { Win32API::File::DeleteFile($zfile) };
                }
                if ($res > 0) {
                    $self->VPrint(0, "  Deleting Zone.Identifier stream\n");
                } else {
                    $self->Warn('Error deleting Zone.Identifier stream');
                }

lib/Image/ExifTool/Writer.pl  view on Meta::CPAN

            return 1 if $$tagInfo{Writable};
        }
    }
    return 0;
}

#------------------------------------------------------------------------------
# Check to see if these are the same file
# Inputs: 0) ExifTool ref, 1) first file name, 2) second file name
# Returns: true if file names reference the same file
sub IsSameFile($$$)
{
    my ($self, $file, $file2) = @_;
    return 0 unless lc $file eq lc $file2;  # (only looking for differences in case)
    my ($isSame, $interrupted);
    my $tmp1 = "${file}_ExifTool_tmp_$$";
    my $tmp2 = "${file2}_ExifTool_tmp_$$";
    {
        local *TMP1;
        local $SIG{INT} = sub { $interrupted = 1 };
        if ($self->Open(\*TMP1, $tmp1, '>')) {
            close TMP1;
            $isSame = 1 if $self->Exists($tmp2);
            $self->Unlink($tmp1);
        }
    }
    if ($interrupted and $SIG{INT}) {
        no strict 'refs';
        &{$SIG{INT}}();
    }
    return $isSame;
}

#------------------------------------------------------------------------------
# Is this a raw file type?
# Inputs: 0) ExifTool ref
# Returns: true if FileType is a type of RAW image
sub IsRawType($)
{
    my $self = shift;
    return $rawType{$$self{FileType}};
}

#------------------------------------------------------------------------------
# Copy file attributes from one file to another
# Inputs: 0) ExifTool ref, 1) source file name, 2) destination file name
# Notes: eventually add support for extended attributes?
sub CopyFileAttrs($$$)
{
    my ($self, $src, $dst) = @_;
    my ($mode, $uid, $gid) = (stat($src))[2, 4, 5];
    # copy file attributes unless we already set them
    if (defined $mode and not defined $self->GetNewValue('FilePermissions')) {
        eval { chmod($mode & 07777, $dst) };
    }
    my $newUid = $self->GetNewValue('FileUserID');
    my $newGid = $self->GetNewValue('FileGroupID');
    if (defined $uid and defined $gid and (not defined $newUid or not defined $newGid)) {
        defined $newGid and $gid = $newGid;
        defined $newUid and $uid = $newUid;
        eval { chown($uid, $gid, $dst) };
    }
}

#------------------------------------------------------------------------------
# Get new file path name
# Inputs: 0) existing name (may contain directory),
#         1) new file name, new directory, or new path (dir+name)
# Returns: new file path name
sub GetNewFileName($$)
{
    my ($oldName, $newName) = @_;
    my ($dir, $name) = ($oldName =~ m{(.*/)(.*)});
    ($dir, $name) = ('', $oldName) unless defined $dir;
    if ($newName =~ m{/$}) {
        $newName = "$newName$name"; # change dir only
    } elsif ($newName !~ m{/}) {
        $newName = "$dir$newName";  # change name only if newname doesn't specify dir
    }                               # else change dir and name
    return $newName;
}

#------------------------------------------------------------------------------
# Get next available tag key
# Inputs: 0) hash reference (keys are tag keys), 1) tag name
# Returns: next available tag key
sub NextFreeTagKey($$)
{
    my ($info, $tag) = @_;
    return $tag unless exists $$info{$tag};
    my $i;
    for ($i=1; ; ++$i) {
        my $key = "$tag ($i)";
        return $key unless exists $$info{$key};
    }
}

#------------------------------------------------------------------------------
# Reverse hash lookup
# Inputs: 0) value, 1) hash reference
# Returns: Hash key or undef if not found (plus flag for multiple matches in list context)
sub ReverseLookup($$)
{
    my ($val, $conv) = @_;
    return undef unless defined $val;
    my $multi;
    if ($val =~ /^Unknown\s*\((.*)\)$/i) {
        $val = $1;    # was unknown
        if ($val =~ /^0x([\da-fA-F]+)$/) {
            # disable "Hexadecimal number > 0xffffffff non-portable" warning
            local $SIG{'__WARN__'} = sub { };
            $val = hex($val);   # convert hex value
        }
    } else {
        my $qval = $val;
        $qval =~ s/\s+$//;      # remove trailing whitespace
        $qval = quotemeta $qval;
        my @patterns = (
            "^$qval\$",         # exact match
            "^(?i)$qval\$",     # case-insensitive
            "^(?i)$qval",       # beginning of string