internet.pm

ARM上的如果你对底层感兴趣

#######################################################################
#
# Win32::Internet - Perl Module for Internet Extensions
# ^^^^^^^^^^^^^^^
# This module creates an object oriented interface to the Win32
# Internet Functions (WININET.DLL).
#
# Version: 0.08 (14 Feb 1997)
#
#######################################################################

# changes:
# - fixed 2 bugs in Option(s) related subs
# - works with build 30x also

package Win32::Internet;

require Exporter;       # to export the constants to the main:: space
require DynaLoader;     # to dynuhlode the module.

# use Win32::WinError;    # for windows constants.

@ISA= qw( Exporter DynaLoader );
@EXPORT = qw(
    HTTP_ADDREQ_FLAG_ADD
    HTTP_ADDREQ_FLAG_REPLACE
    HTTP_QUERY_ALLOW
    HTTP_QUERY_CONTENT_DESCRIPTION
    HTTP_QUERY_CONTENT_ID
    HTTP_QUERY_CONTENT_LENGTH
    HTTP_QUERY_CONTENT_TRANSFER_ENCODING
    HTTP_QUERY_CONTENT_TYPE
    HTTP_QUERY_COST
    HTTP_QUERY_CUSTOM
    HTTP_QUERY_DATE
    HTTP_QUERY_DERIVED_FROM
    HTTP_QUERY_EXPIRES
    HTTP_QUERY_FLAG_REQUEST_HEADERS
    HTTP_QUERY_FLAG_SYSTEMTIME
    HTTP_QUERY_LANGUAGE
    HTTP_QUERY_LAST_MODIFIED
    HTTP_QUERY_MESSAGE_ID
    HTTP_QUERY_MIME_VERSION
    HTTP_QUERY_PRAGMA
    HTTP_QUERY_PUBLIC
    HTTP_QUERY_RAW_HEADERS
    HTTP_QUERY_RAW_HEADERS_CRLF
    HTTP_QUERY_REQUEST_METHOD
    HTTP_QUERY_SERVER
    HTTP_QUERY_STATUS_CODE
    HTTP_QUERY_STATUS_TEXT
    HTTP_QUERY_URI
    HTTP_QUERY_USER_AGENT
    HTTP_QUERY_VERSION
    HTTP_QUERY_WWW_LINK
    ICU_BROWSER_MODE
    ICU_DECODE
    ICU_ENCODE_SPACES_ONLY
    ICU_ESCAPE
    ICU_NO_ENCODE
    ICU_NO_META
    ICU_USERNAME
    INTERNET_CONNECT_FLAG_PASSIVE
    INTERNET_FLAG_ASYNC
    INTERNET_HYPERLINK
    INTERNET_FLAG_KEEP_CONNECTION
    INTERNET_FLAG_MAKE_PERSISTENT
    INTERNET_FLAG_NO_AUTH
    INTERNET_FLAG_NO_AUTO_REDIRECT
    INTERNET_FLAG_NO_CACHE_WRITE
    INTERNET_FLAG_NO_COOKIES
    INTERNET_FLAG_READ_PREFETCH
    INTERNET_FLAG_RELOAD
    INTERNET_FLAG_RESYNCHRONIZE
    INTERNET_FLAG_TRANSFER_ASCII
    INTERNET_FLAG_TRANSFER_BINARY
    INTERNET_INVALID_PORT_NUMBER
    INTERNET_INVALID_STATUS_CALLBACK
    INTERNET_OPEN_TYPE_DIRECT
    INTERNET_OPEN_TYPE_PROXY
    INTERNET_OPEN_TYPE_PROXY_PRECONFIG
    INTERNET_OPTION_CONNECT_BACKOFF
    INTERNET_OPTION_CONNECT_RETRIES
    INTERNET_OPTION_CONNECT_TIMEOUT
    INTERNET_OPTION_CONTROL_SEND_TIMEOUT
    INTERNET_OPTION_CONTROL_RECEIVE_TIMEOUT
    INTERNET_OPTION_DATA_SEND_TIMEOUT
    INTERNET_OPTION_DATA_RECEIVE_TIMEOUT
    INTERNET_OPTION_HANDLE_SIZE
    INTERNET_OPTION_LISTEN_TIMEOUT
    INTERNET_OPTION_PASSWORD
    INTERNET_OPTION_READ_BUFFER_SIZE
    INTERNET_OPTION_USER_AGENT
    INTERNET_OPTION_USERNAME
    INTERNET_OPTION_VERSION
    INTERNET_OPTION_WRITE_BUFFER_SIZE
    INTERNET_SERVICE_FTP
    INTERNET_SERVICE_GOPHER
    INTERNET_SERVICE_HTTP
    INTERNET_STATUS_CLOSING_CONNECTION
    INTERNET_STATUS_CONNECTED_TO_SERVER    
    INTERNET_STATUS_CONNECTING_TO_SERVER
    INTERNET_STATUS_CONNECTION_CLOSED
    INTERNET_STATUS_HANDLE_CLOSING
    INTERNET_STATUS_HANDLE_CREATED
    INTERNET_STATUS_NAME_RESOLVED
    INTERNET_STATUS_RECEIVING_RESPONSE
    INTERNET_STATUS_REDIRECT    
    INTERNET_STATUS_REQUEST_COMPLETE    
    INTERNET_STATUS_REQUEST_SENT    
    INTERNET_STATUS_RESOLVING_NAME    
    INTERNET_STATUS_RESPONSE_RECEIVED
    INTERNET_STATUS_SENDING_REQUEST    
);


#######################################################################
# This AUTOLOAD is used to 'autoload' constants from the constant()
# XS function.  If a constant is not found then control is passed
# to the AUTOLOAD in AutoLoader.
#

sub AUTOLOAD {
    my($constname);
    ($constname = $AUTOLOAD) =~ s/.*:://;
    #reset $! to zero to reset any current errors.
    $!=0;
    my $val = constant($constname, @_ ? $_[0] : 0);
    if ($! != 0) {

        # [dada] This results in an ugly Autoloader error
        #if ($! =~ /Invalid/) {
        #  $AutoLoader::AUTOLOAD = $AUTOLOAD;
        #  goto &AutoLoader::AUTOLOAD;
        #} else {
      
        # [dada] ... I prefer this one :)
  
            ($pack,$file,$line) = caller; undef $pack;
            die "Win32::Internet::$constname is not defined, used at $file line $line.";
  
        #}
    }
    eval "sub $AUTOLOAD { $val }";
    goto &$AUTOLOAD;
}


#######################################################################
# STATIC OBJECT PROPERTIES
#
$VERSION = "0.08";

%callback_code = ();
%callback_info = ();


#######################################################################
# PUBLIC METHODS
#

#======== ### CLASS CONSTRUCTOR
sub new {
#========
    my($class, $useragent, $opentype, $proxy, $proxybypass, $flags) = @_;
    my $self = {};  

    if(ref($useragent) and ref($useragent) eq "HASH") {
        $opentype       = $useragent->{'opentype'};
        $proxy          = $useragent->{'proxy'};
        $proxybypass    = $useragent->{'proxybypass'};
        $flags          = $useragent->{'flags'};
        my $myuseragent = $useragent->{'useragent'};
        undef $useragent;
        $useragent      = $myuseragent;
    }

    $useragent = "Perl-Win32::Internet/".$VERSION       unless defined($useragent);
    $opentype = constant("INTERNET_OPEN_TYPE_DIRECT",0) unless defined($opentype);
    $proxy = ""                                         unless defined($proxy);
    $proxybypass = ""                                   unless defined($proxybypass);
    $flags = 0                                          unless defined($flags);


    my $handle = InternetOpen($useragent, $opentype, $proxy, $proxybypass, $flags);
    if ($handle) {
        $self->{'connections'} = 0;
        $self->{'pasv'}        = 0;
        $self->{'handle'}      = $handle; 
        $self->{'useragent'}   = $useragent;
        $self->{'proxy'}       = $proxy;
        $self->{'proxybypass'} = $proxybypass;
        $self->{'flags'}       = $flags;
        $self->{'Type'}        = "Internet";
    
        # [dada] I think it's better to call SetStatusCallback explicitly...
        #if($flags & constant("INTERNET_FLAG_ASYNC",0)) {
        #  my $callbackresult=InternetSetStatusCallback($handle);
        #  if($callbackresult==&constant("INTERNET_INVALID_STATUS_CALLBACK",0)) {
        #    $self->{'Error'} = -2;
        #  }
        #}

        bless $self;
    } else {
        $self->{'handle'} = undef;
        bless $self;
    }
    $self;
}  


#============
sub OpenURL {
#============
    my($self,$new,$URL) = @_;
    return undef unless ref($self);

    my $newhandle=InternetOpenUrl($self->{'handle'},$URL,"",0,0,0);
    if(!$newhandle) {
        $self->{'Error'} = "Cannot open URL.";
        return undef;
    } else {
        $self->{'connections'}++;
        $_[1] = _new($newhandle);
        $_[1]->{'Type'} = "URL";
        $_[1]->{'URL'}  = $URL;
        return $newhandle;
    }
}


#================
sub TimeConvert {
#================
    my($self, $sec, $min, $hour, $day, $mon, $year, $wday, $rfc) = @_;
    return undef unless ref($self);

    if(!defined($rfc)) {
        return InternetTimeToSystemTime($sec);
    } else {
        return InternetTimeFromSystemTime($sec, $min, $hour, 
                                          $day, $mon, $year, 
                                          $wday, $rfc);
    }
}


#=======================
sub QueryDataAvailable {
#=======================
    my($self) = @_;
    return undef unless ref($self);
  
    return InternetQueryDataAvailable($self->{'handle'});
}


#=============
sub ReadFile {
#=============
    my($self, $buffersize) = @_;
    return undef unless ref($self);

    my $howmuch = InternetQueryDataAvailable($self->{'handle'});
    $buffersize = $howmuch unless defined($buffersize);
    return InternetReadFile($self->{'handle'}, ($howmuch<$buffersize) ? $howmuch 
                                                                      : $buffersize);
}


#===================
sub ReadEntireFile {
#===================
    my($handle) = @_;
    my $content    = "";
    my $buffersize = 16000;
    my $howmuch    = 0;
    my $buffer     = "";

    $handle = $handle->{'handle'} if defined($handle) and ref($handle);

    $howmuch = InternetQueryDataAvailable($handle);
    # print "\nReadEntireFile: $howmuch bytes to read...\n";
  
    while($howmuch>0) {
        $buffer = InternetReadFile($handle, ($howmuch<$buffersize) ? $howmuch 
                                                                   : $buffersize);
        # print "\nReadEntireFile: ", length($buffer), " bytes read...\n";
    
        if(!defined($buffer)) {
            return undef;
        } else {
            $content .= $buffer;
        }
        $howmuch = InternetQueryDataAvailable($handle);
        # print "\nReadEntireFile: still $howmuch bytes to read...\n";
    
    }
    return $content;
}


#=============
sub FetchURL {
#=============
    # (OpenURL+Read+Close)...
    my($self, $URL) = @_;
    return undef unless ref($self);

    my $newhandle = InternetOpenUrl($self->{'handle'}, $URL, "", 0, 0, 0);
    if(!$newhandle) {
        $self->{'Error'} = "Cannot open URL.";
        return undef;
    } else {
        my $content = ReadEntireFile($newhandle);
        InternetCloseHandle($newhandle);
        return $content;
    }
}


#================
sub Connections {
#================
    my($self) = @_;
    return undef unless ref($self);

    return $self->{'connections'} if $self->{'Type'} eq "Internet";
    return undef;
}


#================
sub GetResponse {
#================
    my($num, $text) = InternetGetLastResponseInfo();
    return $text;
}

#===========
sub Option {
#===========
    my($self, $option, $value) = @_;
    return undef unless ref($self);

    my $retval = 0;

    $option = constant("INTERNET_OPTION_USER_AGENT", 0) unless defined($option);
  
    if(!defined($value)) {
        $retval = InternetQueryOption($self->{'handle'}, $option);
    } else {
        $retval = InternetSetOption($self->{'handle'}, $option, $value);
    }
    return $retval;
}


#==============
sub UserAgent {
#==============
    my($self, $value) = @_;
    return undef unless ref($self);

    return Option($self, constant("INTERNET_OPTION_USER_AGENT", 0), $value);
}


#=============
sub Username {
#=============
    my($self, $value) = @_;
    return undef unless ref($self);
  
    if($self->{'Type'} ne "HTTP" and $self->{'Type'} ne "FTP") {
        $self->{'Error'} = "Username() only on FTP or HTTP sessions.";
        return undef;
    }

    return Option($self, constant("INTERNET_OPTION_USERNAME", 0), $value);
}


#=============
sub Password {
#=============
    my($self, $value)=@_;
    return undef unless ref($self);

    if($self->{'Type'} ne "HTTP" and $self->{'Type'} ne "FTP") {
        $self->{'Error'} = "Password() only on FTP or HTTP sessions.";
        return undef;
    }

    return Option($self, constant("INTERNET_OPTION_PASSWORD", 0), $value);
}


#===================
sub ConnectTimeout {
#===================
    my($self, $value) = @_;
    return undef unless ref($self);

    return Option($self, constant("INTERNET_OPTION_CONNECT_TIMEOUT", 0), $value);
}


#===================
sub ConnectRetries {
#===================
    my($self, $value) = @_;
    return undef unless ref($self);

    return Option($self, constant("INTERNET_OPTION_CONNECT_RETRIES", 0), $value);
}


#===================
sub ConnectBackoff {
#===================
    my($self,$value)=@_;
    return undef unless ref($self);

    return Option($self, constant("INTERNET_OPTION_CONNECT_BACKOFF", 0), $value);
}


#====================
sub DataSendTimeout {
#====================
    my($self,$value) = @_;
    return undef unless ref($self);

    return Option($self, constant("INTERNET_OPTION_DATA_SEND_TIMEOUT", 0), $value);
}


#=======================
sub DataReceiveTimeout {
#=======================
    my($self, $value) = @_;
    return undef unless ref($self);

    return Option($self, constant("INTERNET_OPTION_DATA_RECEIVE_TIMEOUT", 0), $value);
}


#==========================
sub ControlReceiveTimeout {
#==========================
    my($self, $value) = @_;
    return undef unless ref($self);

    return Option($self, constant("INTERNET_OPTION_CONTROL_RECEIVE_TIMEOUT", 0), $value);
}


#=======================