tar.pm

视频监控网络部分的协议ddns,的模块的实现代码,请大家大胆指正.

                }
    
                unless( $found ) {
                    return $self->_error( 
                        qq[Could not find '$file' in archive] );
                }
            }
        }

    ### just grab all the file items
    } else {
        @files = $self->get_files;
    }

    ### nothing found? that's an error
    unless( scalar @files ) {
        $self->_error( qq[No files found for ] . $self->_file );
        return;
    }

    ### now extract them
    for my $entry ( @files ) {
        unless( $self->_extract_file( $entry ) ) {
            $self->_error(q[Could not extract ']. $entry->full_path .q['] );
            return;
        }
    }

    return @files;
}

=head2 $tar->extract_file( $file, [$extract_path] )

Write an entry, whose name is equivalent to the file name provided to
disk. Optionally takes a second parameter, which is the full native
path (including filename) the entry will be written to.

For example:

    $tar->extract_file( 'name/in/archive', 'name/i/want/to/give/it' );

    $tar->extract_file( $at_file_object,   'name/i/want/to/give/it' );

Returns true on success, false on failure.

=cut

sub extract_file {
    my $self = shift;
    my $file = shift;   return unless defined $file;
    my $alt  = shift;

    my $entry = $self->_find_entry( $file )
        or $self->_error( qq[Could not find an entry for '$file'] ), return;

    return $self->_extract_file( $entry, $alt );
}

sub _extract_file {
    my $self    = shift;
    my $entry   = shift or return;
    my $alt     = shift;

    ### you wanted an alternate extraction location ###
    my $name = defined $alt ? $alt : $entry->full_path;

                            ### splitpath takes a bool at the end to indicate
                            ### that it's splitting a dir
    my ($vol,$dirs,$file);
    if ( defined $alt ) { # It's a local-OS path
        ($vol,$dirs,$file) = File::Spec->splitpath(       $alt,
                                                          $entry->is_dir );
    } else {
        ($vol,$dirs,$file) = File::Spec::Unix->splitpath( $name,
                                                          $entry->is_dir );
    }

    my $dir;
    ### is $name an absolute path? ###
    if( File::Spec->file_name_is_absolute( $dirs ) ) {

        ### absolute names are not allowed to be in tarballs under
        ### strict mode, so only allow it if a user tells us to do it
        if( not defined $alt and not $INSECURE_EXTRACT_MODE ) {
            $self->_error( 
                q[Entry ']. $entry->full_path .q[' is an absolute path. ].
                q[Not extracting absolute paths under SECURE EXTRACT MODE]
            );  
            return;
        }
        
        ### user asked us to, it's fine.
        $dir = $dirs;

    ### it's a relative path ###
    } else {
        my $cwd     = (defined $self->{cwd} ? $self->{cwd} : cwd());

        my @dirs = defined $alt
            ? File::Spec->splitdir( $dirs )         # It's a local-OS path
            : File::Spec::Unix->splitdir( $dirs );  # it's UNIX-style, likely
                                                    # straight from the tarball

        ### paths that leave the current directory are not allowed under
        ### strict mode, so only allow it if a user tells us to do this.
        if( not defined $alt            and 
            not $INSECURE_EXTRACT_MODE  and 
            grep { $_ eq '..' } @dirs
        ) {
            $self->_error(
                q[Entry ']. $entry->full_path .q[' is attempting to leave the ].
                q[current working directory. Not extracting under SECURE ].
                q[EXTRACT MODE]
            );
            return;
        }            
        
        ### '.' is the directory delimiter, of which the first one has to
        ### be escaped/changed.
        map tr/\./_/, @dirs if ON_VMS;        

        my ($cwd_vol,$cwd_dir,$cwd_file) 
                    = File::Spec->splitpath( $cwd );
        my @cwd     = File::Spec->splitdir( $cwd_dir );
        push @cwd, $cwd_file if length $cwd_file;

        ### We need to pass '' as the last elemant to catpath. Craig Berry
        ### explains why (msgid <p0624083dc311ae541393@[172.16.52.1]>):
        ### The root problem is that splitpath on UNIX always returns the 
        ### final path element as a file even if it is a directory, and of
        ### course there is no way it can know the difference without checking
        ### against the filesystem, which it is documented as not doing.  When
        ### you turn around and call catpath, on VMS you have to know which bits
        ### are directory bits and which bits are file bits.  In this case we
        ### know the result should be a directory.  I had thought you could omit
        ### the file argument to catpath in such a case, but apparently on UNIX
        ### you can't.
        $dir        = File::Spec->catpath( 
                            $cwd_vol, File::Spec->catdir( @cwd, @dirs ), '' 
                        );

        ### catdir() returns undef if the path is longer than 255 chars on VMS
        unless ( defined $dir ) {
            $^W && $self->_error( qq[Could not compose a path for '$dirs'\n] );
            return;
        }

    }

    if( -e $dir && !-d _ ) {
        $^W && $self->_error( qq['$dir' exists, but it's not a directory!\n] );
        return;
    }

    unless ( -d _ ) {
        eval { File::Path::mkpath( $dir, 0, 0777 ) };
        if( $@ ) {
            $self->_error( qq[Could not create directory '$dir': $@] );
            return;
        }
        
        ### XXX chown here? that might not be the same as in the archive
        ### as we're only chown'ing to the owner of the file we're extracting
        ### not to the owner of the directory itself, which may or may not
        ### be another entry in the archive
        ### Answer: no, gnu tar doesn't do it either, it'd be the wrong
        ### way to go.
        #if( $CHOWN && CAN_CHOWN ) {
        #    chown $entry->uid, $entry->gid, $dir or
        #        $self->_error( qq[Could not set uid/gid on '$dir'] );
        #}
    }

    ### we're done if we just needed to create a dir ###
    return 1 if $entry->is_dir;

    my $full = File::Spec->catfile( $dir, $file );

    if( $entry->is_unknown ) {
        $self->_error( qq[Unknown file type for file '$full'] );
        return;
    }

    if( length $entry->type && $entry->is_file ) {
        my $fh = IO::File->new;
        $fh->open( '>' . $full ) or (
            $self->_error( qq[Could not open file '$full': $!] ),
            return
        );

        if( $entry->size ) {
            binmode $fh;
            syswrite $fh, $entry->data or (
                $self->_error( qq[Could not write data to '$full'] ),
                return
            );
        }

        close $fh or (
            $self->_error( qq[Could not close file '$full'] ),
            return
        );

    } else {
        $self->_make_special_file( $entry, $full ) or return;
    }

    utime time, $entry->mtime - TIME_OFFSET, $full or
        $self->_error( qq[Could not update timestamp] );

    if( $CHOWN && CAN_CHOWN ) {
        chown $entry->uid, $entry->gid, $full or
            $self->_error( qq[Could not set uid/gid on '$full'] );
    }

    ### only chmod if we're allowed to, but never chmod symlinks, since they'll
    ### change the perms on the file they're linking too...
    if( $CHMOD and not -l $full ) {
        chmod $entry->mode, $full or
            $self->_error( qq[Could not chown '$full' to ] . $entry->mode );
    }

    return 1;
}

sub _make_special_file {
    my $self    = shift;
    my $entry   = shift     or return;
    my $file    = shift;    return unless defined $file;

    my $err;

    if( $entry->is_symlink ) {
        my $fail;
        if( ON_UNIX ) {
            symlink( $entry->linkname, $file ) or $fail++;

        } else {
            $self->_extract_special_file_as_plain_file( $entry, $file )
                or $fail++;
        }

        $err =  qq[Making symbolink link from '] . $entry->linkname .
                qq[' to '$file' failed] if $fail;

    } elsif ( $entry->is_hardlink ) {
        my $fail;
        if( ON_UNIX ) {
            link( $entry->linkname, $file ) or $fail++;

        } else {
            $self->_extract_special_file_as_plain_file( $entry, $file )
                or $fail++;
        }

        $err =  qq[Making hard link from '] . $entry->linkname .
                qq[' to '$file' failed] if $fail;

    } elsif ( $entry->is_fifo ) {
        ON_UNIX && !system('mknod', $file, 'p') or
            $err = qq[Making fifo ']. $entry->name .qq[' failed];

    } elsif ( $entry->is_blockdev or $entry->is_chardev ) {
        my $mode = $entry->is_blockdev ? 'b' : 'c';

        ON_UNIX && !system('mknod', $file, $mode,
                            $entry->devmajor, $entry->devminor) or
            $err =  qq[Making block device ']. $entry->name .qq[' (maj=] .
                    $entry->devmajor . qq[ min=] . $entry->devminor .
                    qq[) failed.];

    } elsif ( $entry->is_socket ) {
        ### the original doesn't do anything special for sockets.... ###
        1;
    }

    return $err ? $self->_error( $err ) : 1;
}

### don't know how to make symlinks, let's just extract the file as
### a plain file
sub _extract_special_file_as_plain_file {
    my $self    = shift;
    my $entry   = shift     or return;
    my $file    = shift;    return unless defined $file;

    my $err;
    TRY: {
        my $orig = $self->_find_entry( $entry->linkname );

        unless( $orig ) {
            $err =  qq[Could not find file '] . $entry->linkname .
                    qq[' in memory.];
            last TRY;
        }

        ### clone the entry, make it appear as a normal file ###
        my $clone = $entry->clone;
        $clone->_downgrade_to_plainfile;
        $self->_extract_file( $clone, $file ) or last TRY;

        return 1;
    }

    return $self->_error($err);
}

=head2 $tar->list_files( [\@properties] )

Returns a list of the names of all the files in the archive.

If C<list_files()> is passed an array reference as its first argument
it returns a list of hash references containing the requested
properties of each file.  The following list of properties is
supported: name, size, mtime (last modified date), mode, uid, gid,
linkname, uname, gname, devmajor, devminor, prefix.

Passing an array reference containing only one element, 'name', is
special cased to return a list of names rather than a list of hash
references, making it equivalent to calling C<list_files> without
arguments.

=cut

sub list_files {
    my $self = shift;
    my $aref = shift || [ ];

    unless( $self->_data ) {
        $self->read() or return;
    }

    if( @$aref == 0 or ( @$aref == 1 and $aref->[0] eq 'name' ) ) {
        return map { $_->full_path } @{$self->_data};
    } else {

        #my @rv;
        #for my $obj ( @{$self->_data} ) {
        #    push @rv, { map { $_ => $obj->$_() } @$aref };
        #}
        #return @rv;

        ### this does the same as the above.. just needs a +{ }
        ### to make sure perl doesn't confuse it for a block
        return map {    my $o=$_;
                        +{ map { $_ => $o->$_() } @$aref }
                    } @{$self->_data};
    }
}

sub _find_entry {
    my $self = shift;
    my $file = shift;

    unless( defined $file ) {
        $self->_error( qq[No file specified] );
        return;
    }

    ### it's an object already
    return $file if UNIVERSAL::isa( $file, 'Archive::Tar::File' );

    for my $entry ( @{$self->_data} ) {
        my $path = $entry->full_path;
        return $entry if $path eq $file;
    }

    $self->_error( qq[No such file in archive: '$file'] );
    return;
}

=head2 $tar->get_files( [@filenames] )

Returns the C<Archive::Tar::File> objects matching the filenames
provided. If no filename list was passed, all C<Archive::Tar::File>
objects in the current Tar object are returned.

Please refer to the C<Archive::Tar::File> documentation on how to
handle these objects.

=cut

sub get_files {
    my $self = shift;

    return @{ $self->_data } unless @_;

    my @list;
    for my $file ( @_ ) {
        push @list, grep { defined } $self->_find_entry( $file );
    }

    return @list;
}

=head2 $tar->get_content( $file )

Return the content of the named file.

=cut

sub get_content {
    my $self = shift;
    my $entry = $self->_find_entry( shift ) or return;

    return $entry->data;
}

=head2 $tar->replace_content( $file, $content )

Make the string $content be the content for the file named $file.

=cut

sub replace_content {
    my $self = shift;
    my $entry = $self->_find_entry( shift ) or return;

    return $entry->replace_content( shift );
}

=head2 $tar->rename( $file, $new_name )

Rename the file of the in-memory archive to $new_name.

Note that you must specify a Unix path for $new_name, since per tar
standard, all files in the archive must be Unix paths.

Returns true on success and false on failure.

=cut

sub rename {
    my $self = shift;
    my $file = shift; return unless defined $file;
    my $new  = shift; return unless defined $new;

    my $entry = $self->_find_entry( $file ) or return;

    return $entry->rename( $new );
}

=head2 $tar->remove (@filenamelist)

Removes any entries with names matching any of the given filenames
from the in-memory archive. Returns a list of C<Archive::Tar::File>
objects that remain.

=cut

sub remove {
    my $self = shift;
    my @list = @_;

    my %seen = map { $_->full_path => $_ } @{$self->_data};
    delete $seen{ $_ } for @list;

    $self->_data( [values %seen] );

    return values %seen;
}

=head2 $tar->clear

C<clear> clears the current in-memory archive. This effectively gives
you a 'blank' object, ready to be filled again. Note that C<clear>
only has effect on the object, not the underlying tarfile.