fetch.pm

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

sub fetch {
    my $self = shift or return;
    my %hash = @_;

    my $to;
    my $tmpl = {
        to  => { default => cwd(), store => \$to },
    };

    check( $tmpl, \%hash ) or return;

    ### On VMS force to VMS format so File::Spec will work.
    $to = VMS::Filespec::vmspath($to) if ON_VMS;

    ### create the path if it doesn't exist yet ###
    unless( -d $to ) {
        eval { mkpath( $to ) };

        return $self->_error(loc("Could not create path '%1'",$to)) if $@;
    }

    ### set passive ftp if required ###
    local $ENV{FTP_PASSIVE} = $FTP_PASSIVE;

    ### we dont use catfile on win32 because if we are using a cygwin tool
    ### under cmd.exe they wont understand windows style separators.
    my $out_to = ON_WIN ? $to.'/'.$self->output_file 
                        : File::Spec->catfile( $to, $self->output_file );
    
    for my $method ( @{ $METHODS->{$self->scheme} } ) {
        my $sub =  '_'.$method.'_fetch';

        unless( __PACKAGE__->can($sub) ) {
            $self->_error(loc("Cannot call method for '%1' -- WEIRD!",
                        $method));
            next;
        }

        ### method is blacklisted ###
        next if grep { lc $_ eq $method } @$BLACKLIST;

        ### method is known to fail ###
        next if $METHOD_FAIL->{$method};

        ### there's serious issues with IPC::Run and quoting of command
        ### line arguments. using quotes in the wrong place breaks things,
        ### and in the case of say, 
        ### C:\cygwin\bin\wget.EXE --quiet --passive-ftp --output-document
        ### "index.html" "http://www.cpan.org/index.html?q=1&y=2"
        ### it doesn't matter how you quote, it always fails.
        local $IPC::Cmd::USE_IPC_RUN = 0;
        
        if( my $file = $self->$sub( 
                        to => $out_to
        )){

            unless( -e $file && -s _ ) {
                $self->_error(loc("'%1' said it fetched '%2', ".
                     "but it was not created",$method,$file));

                ### mark the failure ###
                $METHOD_FAIL->{$method} = 1;

                next;

            } else {

                my $abs = File::Spec->rel2abs( $file );
                return $abs;
            }
        }
    }


    ### if we got here, we looped over all methods, but we weren't able
    ### to fetch it.
    return;
}

########################
### _*_fetch methods ###
########################

### LWP fetching ###
sub _lwp_fetch {
    my $self = shift;
    my %hash = @_;

    my ($to);
    my $tmpl = {
        to  => { required => 1, store => \$to }
    };
    check( $tmpl, \%hash ) or return;

    ### modules required to download with lwp ###
    my $use_list = {
        LWP                 => '0.0',
        'LWP::UserAgent'    => '0.0',
        'HTTP::Request'     => '0.0',
        'HTTP::Status'      => '0.0',
        URI                 => '0.0',

    };

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

        ### setup the uri object
        my $uri = URI->new( File::Spec::Unix->catfile(
                                    $self->path, $self->file
                        ) );

        ### special rules apply for file:// uris ###
        $uri->scheme( $self->scheme );
        $uri->host( $self->scheme eq 'file' ? '' : $self->host );
        $uri->userinfo("anonymous:$FROM_EMAIL") if $self->scheme ne 'file';

        ### set up the useragent object
        my $ua = LWP::UserAgent->new();
        $ua->timeout( $TIMEOUT ) if $TIMEOUT;
        $ua->agent( $USER_AGENT );
        $ua->from( $FROM_EMAIL );
        $ua->env_proxy;

        my $res = $ua->mirror($uri, $to) or return;

        ### uptodate or fetched ok ###
        if ( $res->code == 304 or $res->code == 200 ) {
            return $to;

        } else {
            return $self->_error(loc("Fetch failed! HTTP response: %1 %2 [%3]",
                        $res->code, HTTP::Status::status_message($res->code),
                        $res->status_line));
        }

    } else {
        $METHOD_FAIL->{'lwp'} = 1;
        return;
    }
}

### Net::FTP fetching
sub _netftp_fetch {
    my $self = shift;
    my %hash = @_;

    my ($to);
    my $tmpl = {
        to  => { required => 1, store => \$to }
    };
    check( $tmpl, \%hash ) or return;

    ### required modules ###
    my $use_list = { 'Net::FTP' => 0 };

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

        ### make connection ###
        my $ftp;
        my @options = ($self->host);
        push(@options, Timeout => $TIMEOUT) if $TIMEOUT;
        unless( $ftp = Net::FTP->new( @options ) ) {
            return $self->_error(loc("Ftp creation failed: %1",$@));
        }

        ### login ###
        unless( $ftp->login( anonymous => $FROM_EMAIL ) ) {
            return $self->_error(loc("Could not login to '%1'",$self->host));
        }

        ### set binary mode, just in case ###
        $ftp->binary;

        ### create the remote path 
        ### remember remote paths are unix paths! [#11483]
        my $remote = File::Spec::Unix->catfile( $self->path, $self->file );

        ### fetch the file ###
        my $target;
        unless( $target = $ftp->get( $remote, $to ) ) {
            return $self->_error(loc("Could not fetch '%1' from '%2'",
                        $remote, $self->host));
        }

        ### log out ###
        $ftp->quit;

        return $target;

    } else {
        $METHOD_FAIL->{'netftp'} = 1;
        return;
    }
}

### /bin/wget fetch ###
sub _wget_fetch {
    my $self = shift;
    my %hash = @_;

    my ($to);
    my $tmpl = {
        to  => { required => 1, store => \$to }
    };
    check( $tmpl, \%hash ) or return;

    ### see if we have a wget binary ###
    if( my $wget = can_run('wget') ) {

        ### no verboseness, thanks ###
        my $cmd = [ $wget, '--quiet' ];

        ### if a timeout is set, add it ###
        push(@$cmd, '--timeout=' . $TIMEOUT) if $TIMEOUT;

        ### run passive if specified ###
        push @$cmd, '--passive-ftp' if $FTP_PASSIVE;

        ### set the output document, add the uri ###
        push @$cmd, '--output-document', 
                    ### DO NOT quote things for IPC::Run, it breaks stuff.
                    $IPC::Cmd::USE_IPC_RUN
                        ? ($to, $self->uri)
                        : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE);

        ### shell out ###
        my $captured;
        unless(run( command => $cmd, 
                    buffer  => \$captured, 
                    verbose => $DEBUG  
        )) {
            ### wget creates the output document always, even if the fetch
            ### fails.. so unlink it in that case
            1 while unlink $to;
            
            return $self->_error(loc( "Command failed: %1", $captured || '' ));
        }

        return $to;

    } else {
        $METHOD_FAIL->{'wget'} = 1;
        return;
    }
}


### /bin/ftp fetch ###
sub _ftp_fetch {
    my $self = shift;
    my %hash = @_;

    my ($to);
    my $tmpl = {
        to  => { required => 1, store => \$to }
    };
    check( $tmpl, \%hash ) or return;

    ### see if we have a ftp binary ###
    if( my $ftp = can_run('ftp') ) {

        my $fh = FileHandle->new;

        local $SIG{CHLD} = 'IGNORE';

        unless ($fh->open("|$ftp -n")) {
            return $self->_error(loc("%1 creation failed: %2", $ftp, $!));
        }

        my @dialog = (
            "lcd " . dirname($to),
            "open " . $self->host,
            "user anonymous $FROM_EMAIL",
            "cd /",
            "cd " . $self->path,
            "binary",
            "get " . $self->file . " " . $self->output_file,
            "quit",
        );

        foreach (@dialog) { $fh->print($_, "\n") }
        $fh->close or return;

        return $to;
    }
}

### lynx is stupid - it decompresses any .gz file it finds to be text
### use /bin/lynx to fetch files
sub _lynx_fetch {
    my $self = shift;
    my %hash = @_;

    my ($to);
    my $tmpl = {
        to  => { required => 1, store => \$to }
    };
    check( $tmpl, \%hash ) or return;

    ### see if we have a lynx binary ###
    if( my $lynx = can_run('lynx') ) {

        unless( IPC::Cmd->can_capture_buffer ) {
            $METHOD_FAIL->{'lynx'} = 1;

            return $self->_error(loc( 
                "Can not capture buffers. Can not use '%1' to fetch files",
                'lynx' ));
        }            

        ### write to the output file ourselves, since lynx ass_u_mes to much
        my $local = FileHandle->new(">$to")
                        or return $self->_error(loc(
                            "Could not open '%1' for writing: %2",$to,$!));

        ### dump to stdout ###
        my $cmd = [
            $lynx,
            '-source',
            "-auth=anonymous:$FROM_EMAIL",
        ];

        push @$cmd, "-connect_timeout=$TIMEOUT" if $TIMEOUT;

        ### DO NOT quote things for IPC::Run, it breaks stuff.
        push @$cmd, $IPC::Cmd::USE_IPC_RUN
                        ? $self->uri
                        : QUOTE. $self->uri .QUOTE;


        ### shell out ###
        my $captured;
        unless(run( command => $cmd,
                    buffer  => \$captured,
                    verbose => $DEBUG )
        ) {
            return $self->_error(loc("Command failed: %1", $captured || ''));
        }

        ### print to local file ###
        ### XXX on a 404 with a special error page, $captured will actually
        ### hold the contents of that page, and make it *appear* like the
        ### request was a success, when really it wasn't :(
        ### there doesn't seem to be an option for lynx to change the exit
        ### code based on a 4XX status or so.
        ### the closest we can come is using --error_file and parsing that,
        ### which is very unreliable ;(
        $local->print( $captured );
        $local->close or return;

        return $to;

    } else {
        $METHOD_FAIL->{'lynx'} = 1;
        return;
    }
}

### use /bin/ncftp to fetch files
sub _ncftp_fetch {
    my $self = shift;
    my %hash = @_;

    my ($to);
    my $tmpl = {
        to  => { required => 1, store => \$to }
    };
    check( $tmpl, \%hash ) or return;

    ### we can only set passive mode in interactive sesssions, so bail out
    ### if $FTP_PASSIVE is set
    return if $FTP_PASSIVE;

    ### see if we have a ncftp binary ###
    if( my $ncftp = can_run('ncftp') ) {

        my $cmd = [
            $ncftp,
            '-V',                   # do not be verbose
            '-p', $FROM_EMAIL,      # email as password
            $self->host,            # hostname
            dirname($to),           # local dir for the file
                                    # remote path to the file
            ### DO NOT quote things for IPC::Run, it breaks stuff.
            $IPC::Cmd::USE_IPC_RUN
                        ? File::Spec::Unix->catdir( $self->path, $self->file )
                        : QUOTE. File::Spec::Unix->catdir( 
                                        $self->path, $self->file ) .QUOTE
            
        ];

        ### shell out ###
        my $captured;
        unless(run( command => $cmd,
                    buffer  => \$captured,
                    verbose => $DEBUG )
        ) {
            return $self->_error(loc("Command failed: %1", $captured || ''));
        }

        return $to;

    } else {
        $METHOD_FAIL->{'ncftp'} = 1;
        return;
    }
}

### use /bin/curl to fetch files