able/windows-nt
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity
windows-nt/Source/XPSP1/NT/enduser/speech/lib/perl/win32/internet.pm

1380 lines
37 KiB
Perl
Raw Normal View History

Add source files
2020-09-26 03:20:57 -05:00
#######################################################################
#
# 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);
}
#=======================
sub ControlSendTimeout {
#=======================
my($self, $value) = @_;
return undef unless ref($self);
return Option($self, constant("INTERNET_OPTION_CONTROL_SEND_TIMEOUT", 0), $value);
}
#================
sub QueryOption {
#================
my($self, $option) = @_;
return undef unless ref($self);
return InternetQueryOption($self->{'handle'}, $option);
}
#==============
sub SetOption {
#==============
my($self, $option, $value) = @_;
return undef unless ref($self);
return InternetSetOption($self->{'handle'}, $option, $value);
}
#=============
sub CrackURL {
#=============
my($self, $URL, $flags) = @_;
return undef unless ref($self);
$flags = constant("ICU_ESCAPE", 0) unless defined($flags);
my @newurl = InternetCrackUrl($URL, $flags);
if(!defined($newurl[0])) {
$self->{'Error'} = "Cannot crack URL.";
return undef;
} else {
return @newurl;
}
}
#==============
sub CreateURL {
#==============
my($self, $scheme, $hostname, $port,
$username, $password,
$path, $extrainfo, $flags) = @_;
return undef unless ref($self);
if(ref($scheme) and ref($scheme) eq "HASH") {
$flags = $hostname;
$hostname = $scheme->{'hostname'};
$port = $scheme->{'port'};
$username = $scheme->{'username'};
$password = $scheme->{'password'};
$path = $scheme->{'path'};
$extrainfo = $scheme->{'extrainfo'};
my $myscheme = $scheme->{'scheme'};
undef $scheme;
$scheme = $myscheme;
}
$hostname = "" unless defined($hostname);
$port = 0 unless defined($port);
$username = "" unless defined($username);
$password = "" unless defined($password);
$path = "" unless defined($path);
$extrainfo = "" unless defined($extrainfo);
$flags = constant("ICU_ESCAPE", 0) unless defined($flags);
my $newurl = InternetCreateUrl($scheme, $hostname, $port,
$username, $password,
$path, $extrainfo, $flags);
if(!defined($newurl)) {
$self->{'Error'} = "Cannot create URL.";
return undef;
} else {
return $newurl;
}
}
#====================
sub CanonicalizeURL {
#====================
my($self, $URL, $flags) = @_;
return undef unless ref($self);
my $newurl = InternetCanonicalizeUrl($URL, $flags);
if(!defined($newurl)) {
$self->{'Error'} = "Cannot canonicalize URL.";
return undef;
} else {
return $newurl;
}
}
#===============
sub CombineURL {
#===============
my($self, $baseURL, $relativeURL, $flags) = @_;
return undef unless ref($self);
my $newurl = InternetCombineUrl($baseURL, $relativeURL, $flags);
if(!defined($newurl)) {
$self->{'Error'} = "Cannot combine URL(s).";
return undef;
} else {
return $newurl;
}
}
#======================
sub SetStatusCallback {
#======================
my($self) = @_;
return undef unless ref($self);
my $callback = InternetSetStatusCallback($self->{'handle'});
print "callback=$callback, constant=",constant("INTERNET_INVALID_STATUS_CALLBACK", 0), "\n";
if($callback == constant("INTERNET_INVALID_STATUS_CALLBACK", 0)) {
return undef;
} else {
return $callback;
}
}
#======================
sub GetStatusCallback {
#======================
my($self, $context) = @_;
$context = $self if not defined $context;
return($callback_code{$context}, $callback_info{$context});
}
#==========
sub Error {
#==========
my($self) = @_;
return undef unless ref($self);
my $errtext = "";
my $tmp = "";
my $errnum = Win32::GetLastError();
if($errnum < 12000) {
$errtext = Win32::FormatMessage($errnum);
$errtext =~ s/[\r\n]//g;
} elsif($errnum == 12003) {
($tmp, $errtext) = InternetGetLastResponseInfo();
chomp $errtext;
1 while($errtext =~ s/(.*)\n//); # the last line should be significative...
# otherwise call GetResponse() to get it whole
} elsif($errnum >= 12000) {
$errtext = FormatMessage($errnum);
$errtext =~ s/[\r\n]//g;
} else {
$errtext="Error";
}
if($errnum == 0 and defined($self->{'Error'})) {
if($self->{'Error'} == -2) {
$errnum = -2;
$errtext = "Asynchronous operations not available.";
} else {
$errnum = -1;
$errtext = $self->{'Error'};
}
}
return (wantarray)? ($errnum, $errtext) : "\[".$errnum."\] ".$errtext;
}
#============
sub Version {
#============
my $dll = InternetDllVersion();
$dll =~ s/\0//g;
return (wantarray)? ($Win32::Internet::VERSION, $dll)
: $Win32::Internet::VERSION."/".$dll;
}
#==========
sub Close {
#==========
my($self, $handle) = @_;
if(!defined($handle)) {
return undef unless ref($self);
$handle = $self->{'handle'};
}
InternetCloseHandle($handle);
}
#######################################################################
# FTP CLASS METHODS
#
#======== ### FTP CONSTRUCTOR
sub FTP {
#========
my($self, $new, $server, $username, $password, $port, $pasv, $context) = @_;
return undef unless ref($self);
if(ref($server) and ref($server) eq "HASH") {
$port = $server->{'port'};
$username = $server->{'username'};
$password = $password->{'host'};
my $myserver = $server->{'server'};
$pasv = $server->{'pasv'};
$context = $server->{'context'};
undef $server;
$server = $myserver;
}
$server = "" unless defined($server);
$username = "anonymous" unless defined($username);
$password = "" unless defined($password);
$port = 21 unless defined($port);
$context = 0 unless defined($context);
if(defined($pasv)) {
$pasv=constant("INTERNET_CONNECT_FLAG_PASSIVE",0) if $pasv ne 0;
} else {
$pasv=$self->{'pasv'};
}
my $newhandle = InternetConnect($self->{'handle'}, $server, $port,
$username, $password,
constant("INTERNET_SERVICE_FTP", 0),
$pasv, $context);
if($newhandle) {
$self->{'connections'}++;
$_[1] = _new($newhandle);
$_[1]->{'Type'} = "FTP";
$_[1]->{'Mode'} = "bin";
$_[1]->{'pasv'} = $pasv;
$_[1]->{'username'} = $username;
$_[1]->{'password'} = $password;
$_[1]->{'server'} = $server;
return $newhandle;
} else {
return undef;
}
}
#========
sub Pwd {
#========
my($self) = @_;
return undef unless ref($self);
if($self->{'Type'} ne "FTP" or !defined($self->{'handle'})) {
$self->{'Error'} = "Pwd() only on FTP sessions.";
return undef;
}
return FtpGetCurrentDirectory($self->{'handle'});
}
#=======
sub Cd {
#=======
my($self, $path) = @_;
return undef unless ref($self);
if($self->{'Type'} ne "FTP" || !defined($self->{'handle'})) {
$self->{'Error'} = "Cd() only on FTP sessions.";
return undef;
}
my $retval = FtpSetCurrentDirectory($self->{'handle'}, $path);
if(!defined($retval)) {
return undef;
} else {
return $path;
}
}
#====================
sub Cwd { Cd(@_); }
sub Chdir { Cd(@_); }
#====================
#==========
sub Mkdir {
#==========
my($self, $path) = @_;
return undef unless ref($self);
if($self->{'Type'} ne "FTP" or !defined($self->{'handle'})) {
$self->{'Error'} = "Mkdir() only on FTP sessions.";
return undef;
}
my $retval = FtpCreateDirectory($self->{'handle'}, $path);
$self->{'Error'} = "Can't create directory." unless defined($retval);
return $retval;
}
#====================
sub Md { Mkdir(@_); }
#====================
#=========
sub Mode {
#=========
my($self, $value) = @_;
return undef unless ref($self);
if($self->{'Type'} ne "FTP" or !defined($self->{'handle'})) {
$self->{'Error'} = "Mode() only on FTP sessions.";
return undef;
}
if(!defined($value)) {
return $self->{'Mode'};
} else {
my $modesub = ($value =~ /^a/i) ? "Ascii" : "Binary";
$self->$modesub($_[0]);
}
return $self->{'Mode'};
}
#==========
sub Rmdir {
#==========
my($self, $path) = @_;
return undef unless ref($self);
if($self->{'Type'} ne "FTP" or !defined($self->{'handle'})) {
$self->{'Error'} = "Rmdir() only on FTP sessions.";
return undef;
}
my $retval = FtpRemoveDirectory($self->{'handle'}, $path);
$self->{'Error'} = "Can't remove directory." unless defined($retval);
return $retval;
}
#====================
sub Rd { Rmdir(@_); }
#====================
#=========
sub Pasv {
#=========
my($self, $value) = @_;
return undef unless ref($self);
if(defined($value) and $self->{'Type'} eq "Internet") {
if($value == 0) {
$self->{'pasv'} = 0;
} else {
$self->{'pasv'} = 1;
}
}
return $self->{'pasv'};
}
#=========
sub List {
#=========
my($self, $pattern, $retmode) = @_;
return undef unless ref($self);
my $retval = "";
my $size = "";
my $attr = "";
my $ctime = "";
my $atime = "";
my $mtime = "";
my $csec = 0; my $cmin = 0; my $chou = 0; my $cday = 0; my $cmon = 0; my $cyea = 0;
my $asec = 0; my $amin = 0; my $ahou = 0; my $aday = 0; my $amon = 0; my $ayea = 0;
my $msec = 0; my $mmin = 0; my $mhou = 0; my $mday = 0; my $mmon = 0; my $myea = 0;
my $newhandle = 0;
my $nextfile = 1;
my @results = ();
my ($filename, $altname, $file);
if($self->{'Type'} ne "FTP") {
$self->{'Error'} = "List() only on FTP sessions.";
return undef;
}
$pattern = "" unless defined($pattern);
$retmode = 1 unless defined($retmode);
if($retmode == 2) {
( $newhandle,$filename, $altname, $size, $attr,
$csec, $cmin, $chou, $cday, $cmon, $cyea,
$asec, $amin, $ahou, $aday, $amon, $ayea,
$msec, $mmin, $mhou, $mday, $mmon, $myea
) = FtpFindFirstFile($self->{'handle'}, $pattern, 0, 0);
if(!$newhandle) {
$self->{'Error'} = "Can't read FTP directory.";
return undef;
} else {
while($nextfile) {
$ctime = join(",", ($csec, $cmin, $chou, $cday, $cmon, $cyea));
$atime = join(",", ($asec, $amin, $ahou, $aday, $amon, $ayea));
$mtime = join(",", ($msec, $mmin, $mhou, $mday, $mmon, $myea));
push(@results, $filename, $altname, $size, $attr, $ctime, $atime, $mtime);
( $nextfile, $filename, $altname, $size, $attr,
$csec, $cmin, $chou, $cday, $cmon, $cyea,
$asec, $amin, $ahou, $aday, $amon, $ayea,
$msec, $mmin, $mhou, $mday, $mmon, $myea
) = InternetFindNextFile($newhandle);
}
InternetCloseHandle($newhandle);
return @results;
}
} elsif($retmode == 3) {
( $newhandle,$filename, $altname, $size, $attr,
$csec, $cmin, $chou, $cday, $cmon, $cyea,
$asec, $amin, $ahou, $aday, $amon, $ayea,
$msec, $mmin, $mhou, $mday, $mmon, $myea
) = FtpFindFirstFile($self->{'handle'}, $pattern, 0, 0);
if(!$newhandle) {
$self->{'Error'} = "Can't read FTP directory.";
return undef;
} else {
while($nextfile) {
$ctime = join(",", ($csec, $cmin, $chou, $cday, $cmon, $cyea));
$atime = join(",", ($asec, $amin, $ahou, $aday, $amon, $ayea));
$mtime = join(",", ($msec, $mmin, $mhou, $mday, $mmon, $myea));
$file = { "name" => $filename,
"altname" => $altname,
"size" => $size,
"attr" => $attr,
"ctime" => $ctime,
"atime" => $atime,
"mtime" => $mtime,
};
push(@results, $file);
( $nextfile, $filename, $altname, $size, $attr,
$csec, $cmin, $chou, $cday, $cmon, $cyea,
$asec, $amin, $ahou, $aday, $amon, $ayea,
$msec, $mmin, $mhou, $mday, $mmon, $myea
) = InternetFindNextFile($newhandle);
}
InternetCloseHandle($newhandle);
return @results;
}
} else {
($newhandle, $filename) = FtpFindFirstFile($self->{'handle'}, $pattern, 0, 0);
if(!$newhandle) {
$self->{'Error'} = "Can't read FTP directory.";
return undef;
} else {
while($nextfile) {
push(@results, $filename);
($nextfile, $filename) = InternetFindNextFile($newhandle);
# print "List.no more files\n" if !$nextfile;
}
InternetCloseHandle($newhandle);
return @results;
}
}
}
#====================
sub Ls { List(@_); }
sub Dir { List(@_); }
#====================
#=================
sub FileAttrInfo {
#=================
my($self,$attr) = @_;
my @attrinfo = ();
push(@attrinfo, "READONLY") if $attr & 1;
push(@attrinfo, "HIDDEN") if $attr & 2;
push(@attrinfo, "SYSTEM") if $attr & 4;
push(@attrinfo, "DIRECTORY") if $attr & 16;
push(@attrinfo, "ARCHIVE") if $attr & 32;
push(@attrinfo, "NORMAL") if $attr & 128;
push(@attrinfo, "TEMPORARY") if $attr & 256;
push(@attrinfo, "COMPRESSED") if $attr & 2048;
return (wantarray)? @attrinfo : join(" ", @attrinfo);
}
#===========
sub Binary {
#===========
my($self) = @_;
return undef unless ref($self);
if($self->{'Type'} ne "FTP") {
$self->{'Error'} = "Binary() only on FTP sessions.";
return undef;
}
$self->{'Mode'} = "bin";
return undef;
}
#======================
sub Bin { Binary(@_); }
#======================
#==========
sub Ascii {
#==========
my($self) = @_;
return undef unless ref($self);
if($self->{'Type'} ne "FTP") {
$self->{'Error'} = "Ascii() only on FTP sessions.";
return undef;
}
$self->{'Mode'} = "asc";
return undef;
}
#=====================
sub Asc { Ascii(@_); }
#=====================
#========
sub Get {
#========
my($self, $remote, $local, $overwrite, $flags, $context) = @_;
return undef unless ref($self);
if($self->{'Type'} ne "FTP") {
$self->{'Error'} = "Get() only on FTP sessions.";
return undef;
}
my $mode = ($self->{'Mode'} eq "asc" ? 1 : 2);
$remote = "" unless defined($remote);
$local = $remote unless defined($local);
$overwrite = 0 unless defined($overwrite);
$flags = 0 unless defined($flags);
$context = 0 unless defined($context);
my $retval = FtpGetFile($self->{'handle'},
$remote,
$local,
$overwrite,
$flags,
$mode,
$context);
$self->{'Error'} = "Can't get file." unless defined($retval);
return $retval;
}
#===========
sub Rename {
#===========
my($self, $oldname, $newname) = @_;
return undef unless ref($self);
if($self->{'Type'} ne "FTP") {
$self->{'Error'} = "Rename() only on FTP sessions.";
return undef;
}
my $retval = FtpRenameFile($self->{'handle'}, $oldname, $newname);
$self->{'Error'} = "Can't rename file." unless defined($retval);
return $retval;
}
#======================
sub Ren { Rename(@_); }
#======================
#===========
sub Delete {
#===========
my($self, $filename) = @_;
return undef unless ref($self);
if($self->{'Type'} ne "FTP") {
$self->{'Error'} = "Delete() only on FTP sessions.";
return undef;
}
my $retval = FtpDeleteFile($self->{'handle'}, $filename);
$self->{'Error'} = "Can't delete file." unless defined($retval);
return $retval;
}
#======================
sub Del { Delete(@_); }
#======================
#========
sub Put {
#========
my($self, $local, $remote, $context) = @_;
return undef unless ref($self);
if($self->{'Type'} ne "FTP") {
$self->{'Error'} = "Put() only on FTP sessions.";
return undef;
}
my $mode = ($self->{'Mode'} eq "asc" ? 1 : 2);
$context = 0 unless defined($context);
my $retval = FtpPutFile($self->{'handle'}, $local, $remote, $mode, $context);
$self->{'Error'} = "Can't put file." unless defined($retval);
return $retval;
}
#######################################################################
# HTTP CLASS METHODS
#
#========= ### HTTP CONSTRUCTOR
sub HTTP {
#=========
my($self, $new, $server, $username, $password, $port, $flags, $context) = @_;
return undef unless ref($self);
if(ref($server) and ref($server) eq "HASH") {
my $myserver = $server->{'server'};
$username = $server->{'username'};
$password = $password->{'host'};
$port = $server->{'port'};
$flags = $server->{'flags'};
$context = $server->{'context'};
undef $server;
$server = $myserver;
}
$server = "" unless defined($server);
$username = "anonymous" unless defined($username);
$password = "" unless defined($username);
$port = 80 unless defined($port);
$flags = 0 unless defined($flags);
$context = 0 unless defined($context);
my $newhandle = InternetConnect($self->{'handle'}, $server, $port,
$username, $password,
constant("INTERNET_SERVICE_HTTP", 0),
$flags, $context);
if($newhandle) {
$self->{'connections'}++;
$_[1] = _new($newhandle);
$_[1]->{'Type'} = "HTTP";
$_[1]->{'username'} = $username;
$_[1]->{'password'} = $password;
$_[1]->{'server'} = $server;
$_[1]->{'accept'} = "text/*\0image/gif\0image/jpeg";
return $newhandle;
} else {
return undef;
}
}
#================
sub OpenRequest {
#================
# alternatively to Request:
# it creates a new HTTP_Request object
# you can act upon it with AddHeader, SendRequest, ReadFile, QueryInfo, Close, ...
my($self, $new, $path, $method, $version, $referer, $accept, $flags, $context) = @_;
return undef unless ref($self);
if($self->{'Type'} ne "HTTP") {
$self->{'Error'} = "OpenRequest() only on HTTP sessions.";
return undef;
}
if(ref($path) and ref($path) eq "HASH") {
$method = $path->{'method'};
$version = $path->{'version'};
$referer = $path->{'referer'};
$accept = $path->{'accept'};
$flags = $path->{'flags'};
$context = $path->{'context'};
my $mypath = $path->{'path'};
undef $path;
$path = $mypath;
}
$method = "GET" unless defined($method);
$path = "/" unless defined($path);
$version = "HTTP/1.0" unless defined($version);
$referer = "" unless defined($referer);
$accept = $self->{'accept'} unless defined($accept);
$flags = 0 unless defined($flags);
$context = 0 unless defined($context);
$path = "/".$path if substr($path,0,1) ne "/";
my $newhandle = HttpOpenRequest($self->{'handle'},
$method,
$path,
$version,
$referer,
$accept,
$flags,
$context);
if($newhandle) {
$_[1] = _new($newhandle);
$_[1]->{'Type'} = "HTTP_Request";
$_[1]->{'method'} = $method;
$_[1]->{'request'} = $path;
$_[1]->{'accept'} = $accept;
return $newhandle;
} else {
return undef;
}
}
#================
sub SendRequest {
#================
my($self, $postdata) = @_;
return undef unless ref($self);
if($self->{'Type'} ne "HTTP_Request") {
$self->{'Error'} = "SendRequest() only on HTTP requests.";
return undef;
}
$postdata = "" unless defined($postdata);
return HttpSendRequest($self->{'handle'}, "", $postdata);
}
#==============
sub AddHeader {
#==============
my($self, $header, $flags) = @_;
return undef unless ref($self);
if($self->{'Type'} ne "HTTP_Request") {
$self->{'Error'} = "AddHeader() only on HTTP requests.";
return undef;
}
$flags = constant("HTTP_ADDREQ_FLAG_ADD", 0) if (!defined($flags) or $flags == 0);
return HttpAddRequestHeaders($self->{'handle'}, $header, $flags);
}
#==============
sub QueryInfo {
#==============
my($self, $header, $flags) = @_;
return undef unless ref($self);
if($self->{'Type'} ne "HTTP_Request") {
$self->{'Error'}="QueryInfo() only on HTTP requests.";
return undef;
}
$flags = constant("HTTP_QUERY_CUSTOM", 0) if (!defined($flags) and defined($header));
my @queryresult = HttpQueryInfo($self->{'handle'}, $flags, $header);
return (wantarray)? @queryresult : join(" ", @queryresult);
}
#============
sub Request {
#============
# HttpOpenRequest+HttpAddHeaders+HttpSendRequest+InternetReadFile+HttpQueryInfo
my($self, $path, $method, $version, $referer, $accept, $flags, $postdata) = @_;
return undef unless ref($self);
if($self->{'Type'} ne "HTTP") {
$self->{'Error'} = "Request() only on HTTP sessions.";
return undef;
}
if(ref($path) and ref($path) eq "HASH") {
$method = $path->{'method'};
$version = $path->{'version'};
$referer = $path->{'referer'};
$accept = $path->{'accept'};
$flags = $path->{'flags'};
$postdata = $path->{'postdata'};
my $mypath = $path->{'path'};
undef $path;
$path = $mypath;
}
my $content = "";
my $result = "";
my @queryresult = ();
my $statuscode = "";
my $headers = "";
$path = "/" unless defined($path);
$method = "GET" unless defined($method);
$version = "HTTP/1.0" unless defined($version);
$referer = "" unless defined($referer);
$accept = $self->{'accept'} unless defined($accept);
$flags = 0 unless defined($flags);
$postdata = "" unless defined($postdata);
$path = "/".$path if substr($path,0,1) ne "/";
my $newhandle = HttpOpenRequest($self->{'handle'},
$method,
$path,
$version,
$referer,
$accept,
0,
$flags);
if($newhandle) {
$result = HttpSendRequest($newhandle, "", $postdata);
if(defined($result)) {
$statuscode = HttpQueryInfo($newhandle,
constant("HTTP_QUERY_STATUS_CODE", 0), "");
$headers = HttpQueryInfo($newhandle,
constant("HTTP_QUERY_RAW_HEADERS_CRLF", 0), "");
$content = ReadEntireFile($newhandle);
InternetCloseHandle($newhandle);
return($statuscode, $headers, $content);
} else {
return undef;
}
} else {
return undef;
}
}
#######################################################################
# END OF THE PUBLIC METHODS
#
#========= ### SUB-CLASSES CONSTRUCTOR
sub _new {
#=========
my $self = {};
if ($_[0]) {
$self->{'handle'} = $_[0];
bless $self;
} else {
undef($self);
}
$self;
}
#============ ### CLASS DESTRUCTOR
sub DESTROY {
#============
my($self) = @_;
# print "Closing handle $self->{'handle'}...\n";
InternetCloseHandle($self->{'handle'});
# [dada] rest in peace
}
#=============
sub callback {
#=============
my($name, $status, $info) = @_;
$callback_code{$name} = $status;
$callback_info{$name} = $info;
}
#######################################################################
# dynamically load in the Internet.pll module.
#
bootstrap Win32::Internet;
# Preloaded methods go here.
#Currently Autoloading is not implemented in Perl for win32
# Autoload methods go after __END__, and are processed by the autosplit program.
1;
__END__
Reference in a new issue Copy permalink