extract.pm

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

=pod

=head2 $ae->bin_tar

Returns the full path to your tar binary, if found.

=head2 $ae->bin_gzip

Returns the full path to your gzip binary, if found

=head2 $ae->bin_unzip

Returns the full path to your unzip binary, if found

=cut

### paths to commandline tools ###
sub bin_gzip        { return $PROGRAMS->{'gzip'}    if $PROGRAMS->{'gzip'}  }
sub bin_unzip       { return $PROGRAMS->{'unzip'}   if $PROGRAMS->{'unzip'} }
sub bin_tar         { return $PROGRAMS->{'tar'}     if $PROGRAMS->{'tar'}   }
sub bin_bunzip2     { return $PROGRAMS->{'bunzip2'} if $PROGRAMS->{'bunzip2'} }
sub bin_uncompress  { return $PROGRAMS->{'uncompress'} 
                                                 if $PROGRAMS->{'uncompress'} }
=head2 $bool = $ae->have_old_bunzip2

Older versions of C</bin/bunzip2>, from before the C<bunzip2 1.0> release,
require all archive names to end in C<.bz2> or it will not extract
them. This method checks if you have a recent version of C<bunzip2>
that allows any extension, or an older one that doesn't.

=cut

sub have_old_bunzip2 {
    my $self = shift;

    ### no bunzip2? no old bunzip2 either :)
    return unless $self->bin_bunzip2;

    ### if we can't run this, we can't be sure if it's too old or not    
    ### XXX stupid stupid stupid bunzip2 doesn't understand --version
    ### is not a request to extract data:
    ### $ bunzip2 --version
    ### bzip2, a block-sorting file compressor.  Version 1.0.2, 30-Dec-2001.
    ### [...]
    ### bunzip2: I won't read compressed data from a terminal.
    ### bunzip2: For help, type: `bunzip2 --help'.
    ### $ echo $?
    ### 1
    ### HATEFUL!
    my $buffer;
    scalar run( command => [$self->bin_bunzip2, '--version'],
         verbose => 0,
         buffer  => \$buffer
    );

    ### no output
    return unless $buffer;
    
    my ($version) = $buffer =~ /version \s+ (\d+)/ix;

    return 1 if $version < 1;
    return;
}

#################################
#
# Untar code
#
#################################


### untar wrapper... goes to either Archive::Tar or /bin/tar
### depending on $PREFER_BIN
sub _untar {
    my $self = shift;

    ### bzip2 support in A::T via IO::Uncompress::Bzip2
    my   @methods = qw[_untar_at _untar_bin];
         @methods = reverse @methods if $PREFER_BIN;

    for my $method (@methods) {
        $self->_extractor($method) && return 1 if $self->$method();
    }

    return $self->_error(loc("Unable to untar file '%1'", $self->archive));
}

### use /bin/tar to extract ###
sub _untar_bin {
    my $self = shift;

    ### check for /bin/tar ###
    return $self->_error(loc("No '%1' program found", '/bin/tar'))
        unless $self->bin_tar;

    ### check for /bin/gzip if we need it ###
    return $self->_error(loc("No '%1' program found", '/bin/gzip'))
        if $self->is_tgz && !$self->bin_gzip;

    return $self->_error(loc("No '%1' program found", '/bin/bunzip2'))
        if $self->is_tbz && !$self->bin_bunzip2;

    ### XXX figure out how to make IPC::Run do this in one call --
    ### currently i don't know how to get output of a command after a pipe
    ### trapped in a scalar. Mailed barries about this 5th of june 2004.



    ### see what command we should run, based on whether
    ### it's a .tgz or .tar

    ### XXX solaris tar and bsdtar are having different outputs
    ### depending whether you run with -x or -t
    ### compensate for this insanity by running -t first, then -x
    {    my $cmd = 
            $self->is_tgz ? [$self->bin_gzip, '-cdf', $self->archive, '|',
                             $self->bin_tar, '-tf', '-'] :
            $self->is_tbz ? [$self->bin_bunzip2, '-cd', $self->archive, '|',                             
                             $self->bin_tar, '-tf', '-'] :
            [$self->bin_tar, '-tf', $self->archive];

        ### run the command ###
        my $buffer = '';
        unless( scalar run( command => $cmd,
                            buffer  => \$buffer,
                            verbose => $DEBUG )
        ) {
            return $self->_error(loc(
                            "Error listing contents of archive '%1': %2",
                            $self->archive, $buffer ));
        }

        ### no buffers available?
        if( !IPC::Cmd->can_capture_buffer and !$buffer ) {
            $self->_error( $self->_no_buffer_files( $self->archive ) );
        
        } else {
            ### if we're on solaris we /might/ be using /bin/tar, which has
            ### a weird output format... we might also be using
            ### /usr/local/bin/tar, which is gnu tar, which is perfectly
            ### fine... so we have to do some guessing here =/
            my @files = map { chomp;
                          !ON_SOLARIS ? $_
                                      : (m|^ x \s+  # 'xtract' -- sigh
                                            (.+?),  # the actual file name
                                            \s+ [\d,.]+ \s bytes,
                                            \s+ [\d,.]+ \s tape \s blocks
                                        |x ? $1 : $_);

                    } split $/, $buffer;

            ### store the files that are in the archive ###
            $self->files(\@files);
        }
    }

    ### now actually extract it ###
    {   my $cmd = 
            $self->is_tgz ? [$self->bin_gzip, '-cdf', $self->archive, '|',
                             $self->bin_tar, '-xf', '-'] :
            $self->is_tbz ? [$self->bin_bunzip2, '-cd', $self->archive, '|',                             
                             $self->bin_tar, '-xf', '-'] :
            [$self->bin_tar, '-xf', $self->archive];

        my $buffer = '';
        unless( scalar run( command => $cmd,
                            buffer  => \$buffer,
                            verbose => $DEBUG )
        ) {
            return $self->_error(loc("Error extracting archive '%1': %2",
                            $self->archive, $buffer ));
        }

        ### we might not have them, due to lack of buffers
        if( $self->files ) {
            ### now that we've extracted, figure out where we extracted to
            my $dir = $self->__get_extract_dir( $self->files );
    
            ### store the extraction dir ###
            $self->extract_path( $dir );
        }
    }

    ### we got here, no error happened
    return 1;
}

### use archive::tar to extract ###
sub _untar_at {
    my $self = shift;

    ### we definitely need A::T, so load that first
    {   my $use_list = { 'Archive::Tar' => '0.0' };

        unless( can_load( modules => $use_list ) ) {

            return $self->_error(loc("You do not have '%1' installed - " .
                                 "Please install it as soon as possible.",
                                 'Archive::Tar'));
        }
    }

    ### we might pass it a filehandle if it's a .tbz file..
    my $fh_to_read = $self->archive;

    ### we will need Compress::Zlib too, if it's a tgz... and IO::Zlib
    ### if A::T's version is 0.99 or higher
    if( $self->is_tgz ) {
        my $use_list = { 'Compress::Zlib' => '0.0' };
           $use_list->{ 'IO::Zlib' } = '0.0'
                if $Archive::Tar::VERSION >= '0.99';

        unless( can_load( modules => $use_list ) ) {
            my $which = join '/', sort keys %$use_list;

            return $self->_error(loc(
                                "You do not have '%1' installed - Please ".
                                "install it as soon as possible.", $which));

        }
    } elsif ( $self->is_tbz ) {
        my $use_list = { 'IO::Uncompress::Bunzip2' => '0.0' };
        unless( can_load( modules => $use_list ) ) {
            return $self->_error(loc(
                    "You do not have '%1' installed - Please " .
                    "install it as soon as possible.", 
                     'IO::Uncompress::Bunzip2'));
        }

        my $bz = IO::Uncompress::Bunzip2->new( $self->archive ) or
            return $self->_error(loc("Unable to open '%1': %2",
                            $self->archive,
                            $IO::Uncompress::Bunzip2::Bunzip2Error));

        $fh_to_read = $bz;
    }

    my $tar = Archive::Tar->new();

    ### only tell it it's compressed if it's a .tgz, as we give it a file
    ### handle if it's a .tbz
    unless( $tar->read( $fh_to_read, ( $self->is_tgz ? 1 : 0 ) ) ) {
        return $self->_error(loc("Unable to read '%1': %2", $self->archive,
                                    $Archive::Tar::error));
    }

    ### workaround to prevent Archive::Tar from setting uid, which
    ### is a potential security hole. -autrijus
    ### have to do it here, since A::T needs to be /loaded/ first ###
    {   no strict 'refs'; local $^W;

        ### older versions of archive::tar <= 0.23
        *Archive::Tar::chown = sub {};
    }

    ### for version of archive::tar > 1.04
    local $Archive::Tar::Constant::CHOWN = 0;

    {   local $^W;  # quell 'splice() offset past end of array' warnings
                    # on older versions of A::T

        ### older archive::tar always returns $self, return value slightly
        ### fux0r3d because of it.
        $tar->extract()
            or return $self->_error(loc("Unable to extract '%1': %2",
                                    $self->archive, $Archive::Tar::error ));
    }

    my @files   = $tar->list_files;
    my $dir     = $self->__get_extract_dir( \@files );

    ### store the files that are in the archive ###
    $self->files(\@files);

    ### store the extraction dir ###
    $self->extract_path( $dir );

    ### check if the dir actually appeared ###
    return 1 if -d $self->extract_path;

    ### no dir, we failed ###
    return $self->_error(loc("Unable to extract '%1': %2",
                                $self->archive, $Archive::Tar::error ));
}

#################################
#
# Gunzip code
#
#################################

### gunzip wrapper... goes to either Compress::Zlib or /bin/gzip
### depending on $PREFER_BIN
sub _gunzip {
    my $self = shift;

    my @methods = qw[_gunzip_cz _gunzip_bin];
       @methods = reverse @methods if $PREFER_BIN;

    for my $method (@methods) {
        $self->_extractor($method) && return 1 if $self->$method();
    }

    return $self->_error(loc("Unable to gunzip file '%1'", $self->archive));
}

sub _gunzip_bin {
    my $self = shift;

    ### check for /bin/gzip -- we need it ###
    return $self->_error(loc("No '%1' program found", '/bin/gzip'))
        unless $self->bin_gzip;


    my $fh = FileHandle->new('>'. $self->_gunzip_to) or
        return $self->_error(loc("Could not open '%1' for writing: %2",
                            $self->_gunzip_to, $! ));

    my $cmd = [ $self->bin_gzip, '-cdf', $self->archive ];

    my $buffer;
    unless( scalar run( command => $cmd,
                        verbose => $DEBUG,
                        buffer  => \$buffer )
    ) {
        return $self->_error(loc("Unable to gunzip '%1': %2",
                                    $self->archive, $buffer));
    }

    ### no buffers available?
    if( !IPC::Cmd->can_capture_buffer and !$buffer ) {
        $self->_error( $self->_no_buffer_content( $self->archive ) );
    }

    print $fh $buffer if defined $buffer;

    close $fh;

    ### set what files where extract, and where they went ###
    $self->files( [$self->_gunzip_to] );
    $self->extract_path( File::Spec->rel2abs(cwd()) );

    return 1;
}

sub _gunzip_cz {
    my $self = shift;

    my $use_list = { 'Compress::Zlib' => '0.0' };
    unless( can_load( modules => $use_list ) ) {
        return $self->_error(loc("You do not have '%1' installed - Please " .
                        "install it as soon as possible.", 'Compress::Zlib'));
    }

    my $gz = Compress::Zlib::gzopen( $self->archive, "rb" ) or
                return $self->_error(loc("Unable to open '%1': %2",
                            $self->archive, $Compress::Zlib::gzerrno));

    my $fh = FileHandle->new('>'. $self->_gunzip_to) or
        return $self->_error(loc("Could not open '%1' for writing: %2",
                            $self->_gunzip_to, $! ));

    my $buffer;
    $fh->print($buffer) while $gz->gzread($buffer) > 0;
    $fh->close;

    ### set what files where extract, and where they went ###
    $self->files( [$self->_gunzip_to] );
    $self->extract_path( File::Spec->rel2abs(cwd()) );

    return 1;
}

#################################
#
# Uncompress code
#
#################################


### untar wrapper... goes to either Archive::Tar or /bin/tar
### depending on $PREFER_BIN
sub _uncompress {
    my $self = shift;

    my   @methods = qw[_gunzip_cz _uncompress_bin];
         @methods = reverse @methods if $PREFER_BIN;

    for my $method (@methods) {
        $self->_extractor($method) && return 1 if $self->$method();
    }

    return $self->_error(loc("Unable to untar file '%1'", $self->archive));
}

sub _uncompress_bin {
    my $self = shift;

    ### check for /bin/gzip -- we need it ###
    return $self->_error(loc("No '%1' program found", '/bin/uncompress'))
        unless $self->bin_uncompress;


    my $fh = FileHandle->new('>'. $self->_gunzip_to) or
        return $self->_error(loc("Could not open '%1' for writing: %2",
                            $self->_gunzip_to, $! ));

    my $cmd = [ $self->bin_uncompress, '-c', $self->archive ];

    my $buffer;
    unless( scalar run( command => $cmd,
                        verbose => $DEBUG,
                        buffer  => \$buffer )
    ) {
        return $self->_error(loc("Unable to uncompress '%1': %2",
                                    $self->archive, $buffer));
    }

    ### no buffers available?
    if( !IPC::Cmd->can_capture_buffer and !$buffer ) {
        $self->_error( $self->_no_buffer_content( $self->archive ) );
    }

    print $fh $buffer if defined $buffer;

    close $fh;

    ### set what files where extract, and where they went ###
    $self->files( [$self->_gunzip_to] );
    $self->extract_path( File::Spec->rel2abs(cwd()) );