view release on metacpan or  search on metacpan

lib/Tk/Wizard/Installer.pm  view on Meta::CPAN

                        || !$self->confirm_download_again( scalar keys %{ $args->{-files} } ) )
                    {
                        INFO "Not trying again";
                        $self->{-failed} = $args->{-files};
                        $args->{-files}  = {};
                    }
                }
            }

            if ( scalar keys %{ $self->{-failed} } > 0 and $args->{-on_error} ) {
                DEBUG "Failed to download";
                if ( ref $args->{-on_error} eq 'CODE' ) {
                    DEBUG "Calling -on_error handler.";
                    &{ $args->{-on_error} };
                }
                elsif ( $args->{-on_error} ) {
                    DEBUG "Calling self/download_quit.";
                    $self->download_quit( scalar keys %{ $self->{-failed} } );
                }
            }
            else {
                INFO "Failures: ", scalar keys %{ $self->{-failed} };
                foreach ( keys %{ $self->{-failed} } ) {
                    INFO "\t$_\n";
                }
                $self->{-failed} = 0;
            }
            $self->{-bar}->packForget;
            $args->{-file_bar}->packForget;
            $args->{file_label}->packForget;
            $all->packForget;
            $frame->Label( -text => $args->{-done_text} || "Finished", )->pack( -fill => "both", -expand => 1 );

            # $self->{backButton}->configure(-state=>"normal");
            $self->{nextButton}->configure( -state => "normal" );
            if ( $args->{-wait} ) {
                Tk::Wizard::_fix_wait( \$args->{-wait} );

                $frame->after(
                    $args->{-wait},
                    sub {
                        $self->{nextButton}->configure( -state => 'normal' );
                        $self->{nextButton}->invoke;
                      }
                );
            }
          }
    );
    return $frame;
}

# c/o PPM.pm
sub _read_uri {
    my ( $self, $args ) = ( shift, {@_} );
    carp "Require uri param"    unless defined $args->{uri};
    carp "Require target param" unless defined $args->{target};
    my ( $proxy_user, $proxy_pass );
    ( $self->{response}, $self->{bytes_transferred}, $self->{errstr} ) = ( undef, 0, undef );
    my $ua = LWP::UserAgent->new;
    $ua->timeout( $args->{timeout}     || 10 );
    $ua->agent( $ENV{HTTP_PROXY_AGENT} || ( "$0/$Tk::Wizard::Installer::VERSION " . $ua->agent ) );

    if ( defined $args->{proxy} ) {
        $proxy_user = $args->{HTTP_PROXY_USER};
        $proxy_pass = $args->{HTTP_PROXY_PASS};
        DEBUG "_read_uri: calling env_proxy: $args->{http_proxy}";
        $ua->env_proxy;
    }
    elsif ( defined $ENV{HTTP_PROXY} ) {
        $proxy_user = $ENV{HTTP_PROXY_USER};
        $proxy_pass = $ENV{HTTP_PROXY_PASS};
        DEBUG "_read_uri: calling env_proxy: $ENV{HTTP_proxy}";
        $ua->env_proxy;
    }
    my $req = HTTP::Request->new( GET => $args->{uri} );
    if ( defined $proxy_user and defined $proxy_pass ) {
        DEBUG "_read_uri: calling proxy_authorization_basic($proxy_user, $proxy_pass)";
        $req->proxy_authorization_basic( $proxy_user, $proxy_pass );
    }

    # update the progress bar
    ( $self->{response}, $self->{bytes_transferred} ) = ( undef, 0 );
    $self->{response} = $ua->request( $req, sub { &_lwp_callback( $self, $args->{bar}, @_ ) },, 4096 );
    if ( $self->{response} && $self->{response}->is_success ) {
        my ( $dirs, $file ) = $args->{target} =~ /^(.*?)([^\\\/]+)$/;
        if ( $dirs and $dirs !~ /^\.{1,2}$/ and !-d $dirs ) {
            eval { File::Path::mkpath($dirs) };
            if ($@) {
                Carp::croak "Could not make path $dirs : $!";
            }
        }
        my $TARGET;
        if ( !open $TARGET, '>', $args->{target} ) {
            ERROR "_read_uri: Couldn't open $args->{target} for writing";
            $self->{errstr} = "Couldn't open $args->{target} for writing: $!\n";
            return;
        }
        DEBUG "# Writing to $args->{target}...";
        $TARGET->binmode;
        $TARGET->print( $self->{response}->content ) or warn;
        $TARGET->close                               or warn;
        return 1;
    }

    my $sMsg = "Error(2) reading $args->{uri}\n";
    if ( $self->{response} ) {
        $sMsg =
          join( ' ', qq{Error(1) reading $args->{uri}:}, $self->{response}->code, $self->{response}->message, "\n" );
    }
    DEBUG "_read_uri: $sMsg";
    $self->{errstr} = $sMsg;
    return 0;
}

# c/o PPM.pm
sub _lwp_callback {
    my $self = shift;
    my ( $bar, $data, $res, $protocol ) = @_;
    $bar->configure( -to => $res->header('Content-Length') );

    #  $bar->configure(-to => $res->{_headers}->content_length);
    $bar->value( $bar->value + length $data );
    $bar->update;
    $self->{response} = $res;
    $self->{response}->add_content($data);
    $self->{bytes_transferred} += length $data;
}


=head1 CALLBACKS