WFTP_FILE_START: www_ftp/wftpSession.pm
package wftpSession;
use strict;
use vars qw(@ISA @EXPORT);

use Exporter;
@ISA = ('Exporter');
@EXPORT = qw(&create_cipher &crypt_it &decrypt_it);

my @fields = qw(site user password);

sub new {
	my ($c, %args) = @_;
	my $class = ref($c) || $c;
	$args{SID} = $args{id};
	bless \%args, $class;
	}

sub start {
	my $cl = shift;
	$cl->{lifetime} = 600 unless exists($cl->{lifetime});
	$cl->check_sessions();
	if ((!exists($cl->{SID})) || ((length($cl->{SID}) == 0))){
		$cl->id($cl->new_id());

		unless (-e $cl->{path}){
			unless(mkdir($cl->{path}, 0777)){
				$cl->error("<P ALIGN=center>Cannot make session directory: $!.<BR>It makes seesion support impossible.");
				}
			}
		open(FILE,'>'.$cl->getfile()) or $cl->error("Cannot open file: $!");
		close(FILE) or $cl->error("Cannot close file: $!");

		my $key = getkey($cl->{SID});
		$cl->{'.cipher'} = Crypt::Blowfish_PP->new($key);
		return 1;
		}
	else {
		return 0 unless (-e $cl->getfile());
		utime(time(), time(), $cl->getfile());
		my $key = getkey($cl->{SID});
		$cl->{'.cipher'} = Crypt::Blowfish_PP->new($key);
		return 1;
		}
	}

sub check_sessions {
	my $cl = shift;
	opendir(SD, $cl->{path});
	my @files = readdir(SD);
	shift @files; shift @files;
	foreach my $f(@files){
		my @st = stat($cl->{path}.$f);
		if ( ($st[8] + $cl->{lifetime}) < time() ){ 
			unlink($cl->{path}.$f) or $cl->error("Cannot delete session file: $!"); 
			}
		}
	closedir(SD);
	}

sub destroy {
	my $cl = shift;
	return -1 unless ($cl->have_id());
	unlink($cl->getfile()) if (-e $cl->getfile());
	undef $cl->{SID};
	undef $cl->{id} if (defined($cl->{id}));
	return 1;
	}

sub exists {
	my ($cl, $id) = @_;
	return 0 unless defined($id);
	return 1 if (-e $cl->{path}.$cl->{$id});
	return 0;
	}

sub have_id {
	my $cl = shift;
	if(exists($cl->{SID})){
		return 1;
		}
	else {
		return 0;
		}
	}

sub id {
	my ($cl, $newid) = @_;
	if (!$cl->have_id()) { return -1; }
	if (defined($newid)) { $cl->{SID} = $newid; }
	return $cl->{SID};
	}

sub getfile {
	my $cl = shift;
#	my $file_name = $cl->{path}.$cl->{SID};
	my $file_name = $cl->{path}.filename($cl->{SID});
	return $file_name;
	}

sub get_data {
	my ($cl) = @_;
	my $info = {};
	my $cipher = $cl->{'.cipher'};

	open(FILE, $cl->getfile) or $cl->error("Cannot open file: $!");
	binmode(FILE);
	local $/ = undef;
	my $file_content = <FILE>;
	close(FILE) or $cl->error("Cannot close file: $!");

	$file_content =~ s/(.{1,8})/$cipher->decrypt($1)/egs;

	eval "$file_content";
	$cl->error("Cannot load session data: $@") if ($@);
	return $info;
	}

sub save_data {
	my ($cl, $info) = @_;
#	my $data = Data::Dumper->Dump([$info], ["info"]);
	my $data = hash_dump($info, 'info');
	my $cipher = $cl->{'.cipher'};

	$data =~ s/(.{1,8})/$cipher->encrypt($1)/egs;

	open(FILE, '>'.$cl->getfile()) or $cl->error("Cannot open file: $!");
	binmode(FILE);
	print FILE $data;
	close(FILE) or $cl->error("Cannot close file: $!");
	}

sub crypt_it {
	my($data, $cipher) = @_;
	my $string = hash_dump($data, 'data');
	$string =~ s/(.{1,8})/$cipher->encrypt($1)/egs;
	return $string;	
	}

sub decrypt_it {
	my($string, $cipher) = @_;
	$string =~ s/(.{1,8})/$cipher->decrypt($1)/egs;
	return $string;		
	}

sub create_cipher {
	my $key = shift;
	$key = pack("AAAAAAAA", split('', $key));
	my $cipher = Crypt::Blowfish_PP->new($key);
	return $cipher;
	}

sub error {
	my ($cl, $msg) = @_;
	print "Content-type: text/html\n\n";
	print "$msg";
	exit;
	}

sub new_id {
	my $cl = shift;
	my ($new_id, $new_file_name);
	my @chars = ('a' .. 'z', 0 ..9);
	#getting temp name
	for(;;){
		$new_id = join('', @chars[ map { rand @chars}(1 .. 8)]);
		$new_file_name = filename($new_id);

		(! -e $cl->{path}.$new_file_name) && last;
		}
	$cl->{SID} = $new_id;
	$cl->{SID};
	}

sub filename {
	my $id = shift;
	my $left = substr($id, 0, 4);
	my $remote_addr = $ENV{'REMOTE_ADDR'}; 
	my $remote_addr = '127.0.0.1';

	my $remoteip = pack("CCCC", split (/\./, $remote_addr));
	$_ = crypt($left.$remoteip, 'bb');
	tr|+/|_-|;
	my $filename = $_;
	return $filename;
	}

sub getkey {
	my $id = shift;
	my $right = substr($id, 4);
	my $remote_addr = $ENV{'REMOTE_ADDR'};
	my $remote_addr = '127.0.0.1';
	
	my $remoteip = pack("CCCC", split (/\./, $remote_addr));
	my $key = pack("H*",$id).substr(crypt($right.$remoteip, 'aa'), 2);
	return $key;
	}

sub hash_dump {
	my($data, $name) = @_;
	my $out = "\$$name = {\n";
	foreach (keys %$data){
		if( ref($data->{$_}) eq 'HASH'){
			$out .= "\t'$_' => {\n";
			$out .= hash_list($data->{$_});
			$out .= "\t\t},\n";
			}
		else {
			$out .= "\t'$_' => '" . $data->{$_} . "',\n";
			}
		}
	$out .= "\t};\n";	
	return $out;
	}

sub hash_list {
	my ($hash) = @_;
	my $out = '';
	foreach (keys %$hash){
		$out .= "\t\t'$_' => '" . $hash->{$_} . "',\n";
		}
	return $out;
	}

sub hash_dump_old {
	my($data, $name) = @_;
	my $out = "\$$name = {\n";
	foreach (keys %$data){
		$out .= "\t'$_' => '" . $data->{$_} . "',\n";
		}
	$out .= "\t};\n";	
	return $out;
	}

1;

#############################
# This is Crypt/Blowfish_PP.pm which is an implementation of Bruce Schneier's blowfish
#   cryptographic algorithm. I will write some proper docs when I get time....
#   code is (c) copyright Matthew Byng-Maddick <matthew@codix.net> 2000, and some
#   bits are copyright Bruce Schneier. For more information see his website at
#   http://www.counterpane.com/

package Crypt::Blowfish_PP;
use strict;
use vars qw($VERSION);

$VERSION="1.11";

sub new
	{
	my $pack=shift;
	my $key=shift;
	return undef if(!defined($key));
	my %h=(
		p_boxes	=>
			[
			0x243f6a88, 0x85a308d3, 0x13198a2e, 0x03707344,
			0xa4093822, 0x299f31d0, 0x082efa98, 0xec4e6c89,
			0x452821e6, 0x38d01377, 0xbe5466cf, 0x34e90c6c,
			0xc0ac29b7, 0xc97c50dd, 0x3f84d5b5, 0xb5470917,
			0x9216d5d9, 0x8979fb1b
			],
		s_boxes =>
			[
				[
				0xd1310ba6, 0x98dfb5ac, 0x2ffd72db, 0xd01adfb7,
				0xb8e1afed, 0x6a267e96, 0xba7c9045, 0xf12c7f99,
				0x24a19947, 0xb3916cf7, 0x0801f2e2, 0x858efc16,
				0x636920d8, 0x71574e69, 0xa458fea3, 0xf4933d7e,
				0x0d95748f, 0x728eb658, 0x718bcd58, 0x82154aee,
				0x7b54a41d, 0xc25a59b5, 0x9c30d539, 0x2af26013,
				0xc5d1b023, 0x286085f0, 0xca417918, 0xb8db38ef,
				0x8e79dcb0, 0x603a180e, 0x6c9e0e8b, 0xb01e8a3e,
				0xd71577c1, 0xbd314b27, 0x78af2fda, 0x55605c60,
				0xe65525f3, 0xaa55ab94, 0x57489862, 0x63e81440,
				0x55ca396a, 0x2aab10b6, 0xb4cc5c34, 0x1141e8ce,
				0xa15486af, 0x7c72e993, 0xb3ee1411, 0x636fbc2a,
				0x2ba9c55d, 0x741831f6, 0xce5c3e16, 0x9b87931e,
				0xafd6ba33, 0x6c24cf5c, 0x7a325381, 0x28958677,
				0x3b8f4898, 0x6b4bb9af, 0xc4bfe81b, 0x66282193,
				0x61d809cc, 0xfb21a991, 0x487cac60, 0x5dec8032,
				0xef845d5d, 0xe98575b1, 0xdc262302, 0xeb651b88,
				0x23893e81, 0xd396acc5, 0x0f6d6ff3, 0x83f44239,
				0x2e0b4482, 0xa4842004, 0x69c8f04a, 0x9e1f9b5e,
				0x21c66842, 0xf6e96c9a, 0x670c9c61, 0xabd388f0,
				0x6a51a0d2, 0xd8542f68, 0x960fa728, 0xab5133a3,
				0x6eef0b6c, 0x137a3be4, 0xba3bf050, 0x7efb2a98,
				0xa1f1651d, 0x39af0176, 0x66ca593e, 0x82430e88,
				0x8cee8619, 0x456f9fb4, 0x7d84a5c3, 0x3b8b5ebe,
				0xe06f75d8, 0x85c12073, 0x401a449f, 0x56c16aa6,
				0x4ed3aa62, 0x363f7706, 0x1bfedf72, 0x429b023d,
				0x37d0d724, 0xd00a1248, 0xdb0fead3, 0x49f1c09b,
				0x075372c9, 0x80991b7b, 0x25d479d8, 0xf6e8def7,
				0xe3fe501a, 0xb6794c3b, 0x976ce0bd, 0x04c006ba,
				0xc1a94fb6, 0x409f60c4, 0x5e5c9ec2, 0x196a2463,
				0x68fb6faf, 0x3e6c53b5, 0x1339b2eb, 0x3b52ec6f,
				0x6dfc511f, 0x9b30952c, 0xcc814544, 0xaf5ebd09,
				0xbee3d004, 0xde334afd, 0x660f2807, 0x192e4bb3,
				0xc0cba857, 0x45c8740f, 0xd20b5f39, 0xb9d3fbdb,
				0x5579c0bd, 0x1a60320a, 0xd6a100c6, 0x402c7279,
				0x679f25fe, 0xfb1fa3cc, 0x8ea5e9f8, 0xdb3222f8,
				0x3c7516df, 0xfd616b15, 0x2f501ec8, 0xad0552ab,
				0x323db5fa, 0xfd238760, 0x53317b48, 0x3e00df82,
				0x9e5c57bb, 0xca6f8ca0, 0x1a87562e, 0xdf1769db,
				0xd542a8f6, 0x287effc3, 0xac6732c6, 0x8c4f5573,
				0x695b27b0, 0xbbca58c8, 0xe1ffa35d, 0xb8f011a0,
				0x10fa3d98, 0xfd2183b8, 0x4afcb56c, 0x2dd1d35b,
				0x9a53e479, 0xb6f84565, 0xd28e49bc, 0x4bfb9790,
				0xe1ddf2da, 0xa4cb7e33, 0x62fb1341, 0xcee4c6e8,
				0xef20cada, 0x36774c01, 0xd07e9efe, 0x2bf11fb4,
				0x95dbda4d, 0xae909198, 0xeaad8e71, 0x6b93d5a0,
				0xd08ed1d0, 0xafc725e0, 0x8e3c5b2f, 0x8e7594b7,
				0x8ff6e2fb, 0xf2122b64, 0x8888b812, 0x900df01c,
				0x4fad5ea0, 0x688fc31c, 0xd1cff191, 0xb3a8c1ad,
				0x2f2f2218, 0xbe0e1777, 0xea752dfe, 0x8b021fa1,
				0xe5a0cc0f, 0xb56f74e8, 0x18acf3d6, 0xce89e299,
				0xb4a84fe0, 0xfd13e0b7, 0x7cc43b81, 0xd2ada8d9,
				0x165fa266, 0x80957705, 0x93cc7314, 0x211a1477,
				0xe6ad2065, 0x77b5fa86, 0xc75442f5, 0xfb9d35cf,
				0xebcdaf0c, 0x7b3e89a0, 0xd6411bd3, 0xae1e7e49,
				0x00250e2d, 0x2071b35e, 0x226800bb, 0x57b8e0af,
				0x2464369b, 0xf009b91e, 0x5563911d, 0x59dfa6aa,
				0x78c14389, 0xd95a537f, 0x207d5ba2, 0x02e5b9c5,
				0x83260376, 0x6295cfa9, 0x11c81968, 0x4e734a41,
				0xb3472dca, 0x7b14a94a, 0x1b510052, 0x9a532915,
				0xd60f573f, 0xbc9bc6e4, 0x2b60a476, 0x81e67400,
				0x08ba6fb5, 0x571be91f, 0xf296ec6b, 0x2a0dd915,
				0xb6636521, 0xe7b9f9b6, 0xff34052e, 0xc5855664,
				0x53b02d5d, 0xa99f8fa1, 0x08ba4799, 0x6e85076a
				],
				[
				0x4b7a70e9, 0xb5b32944, 0xdb75092e, 0xc4192623,
				0xad6ea6b0, 0x49a7df7d, 0x9cee60b8, 0x8fedb266,
				0xecaa8c71, 0x699a17ff, 0x5664526c, 0xc2b19ee1,
				0x193602a5, 0x75094c29, 0xa0591340, 0xe4183a3e,
				0x3f54989a, 0x5b429d65, 0x6b8fe4d6, 0x99f73fd6,
				0xa1d29c07, 0xefe830f5, 0x4d2d38e6, 0xf0255dc1,
				0x4cdd2086, 0x8470eb26, 0x6382e9c6, 0x021ecc5e,
				0x09686b3f, 0x3ebaefc9, 0x3c971814, 0x6b6a70a1,
				0x687f3584, 0x52a0e286, 0xb79c5305, 0xaa500737,
				0x3e07841c, 0x7fdeae5c, 0x8e7d44ec, 0x5716f2b8,
				0xb03ada37, 0xf0500c0d, 0xf01c1f04, 0x0200b3ff,
				0xae0cf51a, 0x3cb574b2, 0x25837a58, 0xdc0921bd,
				0xd19113f9, 0x7ca92ff6, 0x94324773, 0x22f54701,
				0x3ae5e581, 0x37c2dadc, 0xc8b57634, 0x9af3dda7,
				0xa9446146, 0x0fd0030e, 0xecc8c73e, 0xa4751e41,
				0xe238cd99, 0x3bea0e2f, 0x3280bba1, 0x183eb331,
				0x4e548b38, 0x4f6db908, 0x6f420d03, 0xf60a04bf,
				0x2cb81290, 0x24977c79, 0x5679b072, 0xbcaf89af,
				0xde9a771f, 0xd9930810, 0xb38bae12, 0xdccf3f2e,
				0x5512721f, 0x2e6b7124, 0x501adde6, 0x9f84cd87,
				0x7a584718, 0x7408da17, 0xbc9f9abc, 0xe94b7d8c,
				0xec7aec3a, 0xdb851dfa, 0x63094366, 0xc464c3d2,
				0xef1c1847, 0x3215d908, 0xdd433b37, 0x24c2ba16,
				0x12a14d43, 0x2a65c451, 0x50940002, 0x133ae4dd,
				0x71dff89e, 0x10314e55, 0x81ac77d6, 0x5f11199b,
				0x043556f1, 0xd7a3c76b, 0x3c11183b, 0x5924a509,
				0xf28fe6ed, 0x97f1fbfa, 0x9ebabf2c, 0x1e153c6e,
				0x86e34570, 0xeae96fb1, 0x860e5e0a, 0x5a3e2ab3,
				0x771fe71c, 0x4e3d06fa, 0x2965dcb9, 0x99e71d0f,
				0x803e89d6, 0x5266c825, 0x2e4cc978, 0x9c10b36a,
				0xc6150eba, 0x94e2ea78, 0xa5fc3c53, 0x1e0a2df4,
				0xf2f74ea7, 0x361d2b3d, 0x1939260f, 0x19c27960,
				0x5223a708, 0xf71312b6, 0xebadfe6e, 0xeac31f66,
				0xe3bc4595, 0xa67bc883, 0xb17f37d1, 0x018cff28,
				0xc332ddef, 0xbe6c5aa5, 0x65582185, 0x68ab9802,
				0xeecea50f, 0xdb2f953b, 0x2aef7dad, 0x5b6e2f84,
				0x1521b628, 0x29076170, 0xecdd4775, 0x619f1510,
				0x13cca830, 0xeb61bd96, 0x0334fe1e, 0xaa0363cf,
				0xb5735c90, 0x4c70a239, 0xd59e9e0b, 0xcbaade14,
				0xeecc86bc, 0x60622ca7, 0x9cab5cab, 0xb2f3846e,
				0x648b1eaf, 0x19bdf0ca, 0xa02369b9, 0x655abb50,
				0x40685a32, 0x3c2ab4b3, 0x319ee9d5, 0xc021b8f7,
				0x9b540b19, 0x875fa099, 0x95f7997e, 0x623d7da8,
				0xf837889a, 0x97e32d77, 0x11ed935f, 0x16681281,
				0x0e358829, 0xc7e61fd6, 0x96dedfa1, 0x7858ba99,
				0x57f584a5, 0x1b227263, 0x9b83c3ff, 0x1ac24696,
				0xcdb30aeb, 0x532e3054, 0x8fd948e4, 0x6dbc3128,
				0x58ebf2ef, 0x34c6ffea, 0xfe28ed61, 0xee7c3c73,
				0x5d4a14d9, 0xe864b7e3, 0x42105d14, 0x203e13e0,
				0x45eee2b6, 0xa3aaabea, 0xdb6c4f15, 0xfacb4fd0,
				0xc742f442, 0xef6abbb5, 0x654f3b1d, 0x41cd2105,
				0xd81e799e, 0x86854dc7, 0xe44b476a, 0x3d816250,
				0xcf62a1f2, 0x5b8d2646, 0xfc8883a0, 0xc1c7b6a3,
				0x7f1524c3, 0x69cb7492, 0x47848a0b, 0x5692b285,
				0x095bbf00, 0xad19489d, 0x1462b174, 0x23820e00,
				0x58428d2a, 0x0c55f5ea, 0x1dadf43e, 0x233f7061,
				0x3372f092, 0x8d937e41, 0xd65fecf1, 0x6c223bdb,
				0x7cde3759, 0xcbee7460, 0x4085f2a7, 0xce77326e,
				0xa6078084, 0x19f8509e, 0xe8efd855, 0x61d99735,
				0xa969a7aa, 0xc50c06c2, 0x5a04abfc, 0x800bcadc,
				0x9e447a2e, 0xc3453484, 0xfdd56705, 0x0e1e9ec9,
				0xdb73dbd3, 0x105588cd, 0x675fda79, 0xe3674340,
				0xc5c43465, 0x713e38d8, 0x3d28f89e, 0xf16dff20,
				0x153e21e7, 0x8fb03d4a, 0xe6e39f2b, 0xdb83adf7
				],
				[
				0xe93d5a68, 0x948140f7, 0xf64c261c, 0x94692934,
				0x411520f7, 0x7602d4f7, 0xbcf46b2e, 0xd4a20068,
				0xd4082471, 0x3320f46a, 0x43b7d4b7, 0x500061af,
				0x1e39f62e, 0x97244546, 0x14214f74, 0xbf8b8840,
				0x4d95fc1d, 0x96b591af, 0x70f4ddd3, 0x66a02f45,
				0xbfbc09ec, 0x03bd9785, 0x7fac6dd0, 0x31cb8504,
				0x96eb27b3, 0x55fd3941, 0xda2547e6, 0xabca0a9a,
				0x28507825, 0x530429f4, 0x0a2c86da, 0xe9b66dfb,
				0x68dc1462, 0xd7486900, 0x680ec0a4, 0x27a18dee,
				0x4f3ffea2, 0xe887ad8c, 0xb58ce006, 0x7af4d6b6,
				0xaace1e7c, 0xd3375fec, 0xce78a399, 0x406b2a42,
				0x20fe9e35, 0xd9f385b9, 0xee39d7ab, 0x3b124e8b,
				0x1dc9faf7, 0x4b6d1856, 0x26a36631, 0xeae397b2,
				0x3a6efa74, 0xdd5b4332, 0x6841e7f7, 0xca7820fb,
				0xfb0af54e, 0xd8feb397, 0x454056ac, 0xba489527,
				0x55533a3a, 0x20838d87, 0xfe6ba9b7, 0xd096954b,
				0x55a867bc, 0xa1159a58, 0xcca92963, 0x99e1db33,
				0xa62a4a56, 0x3f3125f9, 0x5ef47e1c, 0x9029317c,
				0xfdf8e802, 0x04272f70, 0x80bb155c, 0x05282ce3,
				0x95c11548, 0xe4c66d22, 0x48c1133f, 0xc70f86dc,
				0x07f9c9ee, 0x41041f0f, 0x404779a4, 0x5d886e17,
				0x325f51eb, 0xd59bc0d1, 0xf2bcc18f, 0x41113564,
				0x257b7834, 0x602a9c60, 0xdff8e8a3, 0x1f636c1b,
				0x0e12b4c2, 0x02e1329e, 0xaf664fd1, 0xcad18115,
				0x6b2395e0, 0x333e92e1, 0x3b240b62, 0xeebeb922,
				0x85b2a20e, 0xe6ba0d99, 0xde720c8c, 0x2da2f728,
				0xd0127845, 0x95b794fd, 0x647d0862, 0xe7ccf5f0,
				0x5449a36f, 0x877d48fa, 0xc39dfd27, 0xf33e8d1e,
				0x0a476341, 0x992eff74, 0x3a6f6eab, 0xf4f8fd37,
				0xa812dc60, 0xa1ebddf8, 0x991be14c, 0xdb6e6b0d,
				0xc67b5510, 0x6d672c37, 0x2765d43b, 0xdcd0e804,
				0xf1290dc7, 0xcc00ffa3, 0xb5390f92, 0x690fed0b,
				0x667b9ffb, 0xcedb7d9c, 0xa091cf0b, 0xd9155ea3,
				0xbb132f88, 0x515bad24, 0x7b9479bf, 0x763bd6eb,
				0x37392eb3, 0xcc115979, 0x8026e297, 0xf42e312d,
				0x6842ada7, 0xc66a2b3b, 0x12754ccc, 0x782ef11c,
				0x6a124237, 0xb79251e7, 0x06a1bbe6, 0x4bfb6350,
				0x1a6b1018, 0x11caedfa, 0x3d25bdd8, 0xe2e1c3c9,
				0x44421659, 0x0a121386, 0xd90cec6e, 0xd5abea2a,
				0x64af674e, 0xda86a85f, 0xbebfe988, 0x64e4c3fe,
				0x9dbc8057, 0xf0f7c086, 0x60787bf8, 0x6003604d,
				0xd1fd8346, 0xf6381fb0, 0x7745ae04, 0xd736fccc,
				0x83426b33, 0xf01eab71, 0xb0804187, 0x3c005e5f,
				0x77a057be, 0xbde8ae24, 0x55464299, 0xbf582e61,
				0x4e58f48f, 0xf2ddfda2, 0xf474ef38, 0x8789bdc2,
				0x5366f9c3, 0xc8b38e74, 0xb475f255, 0x46fcd9b9,
				0x7aeb2661, 0x8b1ddf84, 0x846a0e79, 0x915f95e2,
				0x466e598e, 0x20b45770, 0x8cd55591, 0xc902de4c,
				0xb90bace1, 0xbb8205d0, 0x11a86248, 0x7574a99e,
				0xb77f19b6, 0xe0a9dc09, 0x662d09a1, 0xc4324633,
				0xe85a1f02, 0x09f0be8c, 0x4a99a025, 0x1d6efe10,
				0x1ab93d1d, 0x0ba5a4df, 0xa186f20f, 0x2868f169,
				0xdcb7da83, 0x573906fe, 0xa1e2ce9b, 0x4fcd7f52,
				0x50115e01, 0xa70683fa, 0xa002b5c4, 0x0de6d027,
				0x9af88c27, 0x773f8641, 0xc3604c06, 0x61a806b5,
				0xf0177a28, 0xc0f586e0, 0x006058aa, 0x30dc7d62,
				0x11e69ed7, 0x2338ea63, 0x53c2dd94, 0xc2c21634,
				0xbbcbee56, 0x90bcb6de, 0xebfc7da1, 0xce591d76,
				0x6f05e409, 0x4b7c0188, 0x39720a3d, 0x7c927c24,
				0x86e3725f, 0x724d9db9, 0x1ac15bb4, 0xd39eb8fc,
				0xed545578, 0x08fca5b5, 0xd83d7cd3, 0x4dad0fc4,
				0x1e50ef5e, 0xb161e6f8, 0xa28514d9, 0x6c51133c,
				0x6fd5c7e7, 0x56e14ec4, 0x362abfce, 0xddc6c837,
				0xd79a3234, 0x92638212, 0x670efa8e, 0x406000e0
				],
				[
				0x3a39ce37, 0xd3faf5cf, 0xabc27737, 0x5ac52d1b,
				0x5cb0679e, 0x4fa33742, 0xd3822740, 0x99bc9bbe,
				0xd5118e9d, 0xbf0f7315, 0xd62d1c7e, 0xc700c47b,
				0xb78c1b6b, 0x21a19045, 0xb26eb1be, 0x6a366eb4,
				0x5748ab2f, 0xbc946e79, 0xc6a376d2, 0x6549c2c8,
				0x530ff8ee, 0x468dde7d, 0xd5730a1d, 0x4cd04dc6,
				0x2939bbdb, 0xa9ba4650, 0xac9526e8, 0xbe5ee304,
				0xa1fad5f0, 0x6a2d519a, 0x63ef8ce2, 0x9a86ee22,
				0xc089c2b8, 0x43242ef6, 0xa51e03aa, 0x9cf2d0a4,
				0x83c061ba, 0x9be96a4d, 0x8fe51550, 0xba645bd6,
				0x2826a2f9, 0xa73a3ae1, 0x4ba99586, 0xef5562e9,
				0xc72fefd3, 0xf752f7da, 0x3f046f69, 0x77fa0a59,
				0x80e4a915, 0x87b08601, 0x9b09e6ad, 0x3b3ee593,
				0xe990fd5a, 0x9e34d797, 0x2cf0b7d9, 0x022b8b51,
				0x96d5ac3a, 0x017da67d, 0xd1cf3ed6, 0x7c7d2d28,
				0x1f9f25cf, 0xadf2b89b, 0x5ad6b472, 0x5a88f54c,
				0xe029ac71, 0xe019a5e6, 0x47b0acfd, 0xed93fa9b,
				0xe8d3c48d, 0x283b57cc, 0xf8d56629, 0x79132e28,
				0x785f0191, 0xed756055, 0xf7960e44, 0xe3d35e8c,
				0x15056dd4, 0x88f46dba, 0x03a16125, 0x0564f0bd,
				0xc3eb9e15, 0x3c9057a2, 0x97271aec, 0xa93a072a,
				0x1b3f6d9b, 0x1e6321f5, 0xf59c66fb, 0x26dcf319,
				0x7533d928, 0xb155fdf5, 0x03563482, 0x8aba3cbb,
				0x28517711, 0xc20ad9f8, 0xabcc5167, 0xccad925f,
				0x4de81751, 0x3830dc8e, 0x379d5862, 0x9320f991,
				0xea7a90c2, 0xfb3e7bce, 0x5121ce64, 0x774fbe32,
				0xa8b6e37e, 0xc3293d46, 0x48de5369, 0x6413e680,
				0xa2ae0810, 0xdd6db224, 0x69852dfd, 0x09072166,
				0xb39a460a, 0x6445c0dd, 0x586cdecf, 0x1c20c8ae,
				0x5bbef7dd, 0x1b588d40, 0xccd2017f, 0x6bb4e3bb,
				0xdda26a7e, 0x3a59ff45, 0x3e350a44, 0xbcb4cdd5,
				0x72eacea8, 0xfa6484bb, 0x8d6612ae, 0xbf3c6f47,
				0xd29be463, 0x542f5d9e, 0xaec2771b, 0xf64e6370,
				0x740e0d8d, 0xe75b1357, 0xf8721671, 0xaf537d5d,
				0x4040cb08, 0x4eb4e2cc, 0x34d2466a, 0x0115af84,
				0xe1b00428, 0x95983a1d, 0x06b89fb4, 0xce6ea048,
				0x6f3f3b82, 0x3520ab82, 0x011a1d4b, 0x277227f8,
				0x611560b1, 0xe7933fdc, 0xbb3a792b, 0x344525bd,
				0xa08839e1, 0x51ce794b, 0x2f32c9b7, 0xa01fbac9,
				0xe01cc87e, 0xbcc7d1f6, 0xcf0111c3, 0xa1e8aac7,
				0x1a908749, 0xd44fbd9a, 0xd0dadecb, 0xd50ada38,
				0x0339c32a, 0xc6913667, 0x8df9317c, 0xe0b12b4f,
				0xf79e59b7, 0x43f5bb3a, 0xf2d519ff, 0x27d9459c,
				0xbf97222c, 0x15e6fc2a, 0x0f91fc71, 0x9b941525,
				0xfae59361, 0xceb69ceb, 0xc2a86459, 0x12baa8d1,
				0xb6c1075e, 0xe3056a0c, 0x10d25065, 0xcb03a442,
				0xe0ec6e0e, 0x1698db3b, 0x4c98a0be, 0x3278e964,
				0x9f1f9532, 0xe0d392df, 0xd3a0342b, 0x8971f21e,
				0x1b0a7441, 0x4ba3348c, 0xc5be7120, 0xc37632d8,
				0xdf359f8d, 0x9b992f2e, 0xe60b6f47, 0x0fe3f11d,
				0xe54cda54, 0x1edad891, 0xce6279cf, 0xcd3e7e6f,
				0x1618b166, 0xfd2c1d05, 0x848fd2c5, 0xf6fb2299,
				0xf523f357, 0xa6327623, 0x93a83531, 0x56cccd02,
				0xacf08162, 0x5a75ebb5, 0x6e163697, 0x88d273cc,
				0xde966292, 0x81b949d0, 0x4c50901b, 0x71c65614,
				0xe6c6c7bd, 0x327a140a, 0x45e1d006, 0xc3f27b9a,
				0xc9aa53fd, 0x62a80f00, 0xbb25bfe2, 0x35bdd2f6,
				0x71126905, 0xb2040222, 0xb6cbcf7c, 0xcd769c2b,
				0x53113ec0, 0x1640e3d3, 0x38abbd60, 0x2547adf0,
				0xba38209c, 0xf746ce76, 0x77afa1c5, 0x20756060,
				0x85cbfe4e, 0x8ae88dd8, 0x7aaaf9b0, 0x4cf9aa7e,
				0x1948c25c, 0x02fb8a8c, 0x01c36ae4, 0xd6ebe1f9,
				0x90d4f869, 0xa65cdea0, 0x3f09252d, 0xc208e69f,
				0xb74e6132, 0xce77e25b, 0x578fdfe3, 0x3ac372e6
				]
			]
		);
	my $keylen=length($key);
	return undef if(($keylen < 8) || ($keylen > 56));
	my @keybytes=split//,$key;
	for my $b (@keybytes)
		{
		$b=unpack("C",$b);
		}
	my $j=0;
	my $i=0;
	my($l,$r)=(0,0);

	# BEGIN PROCESS OF SETTING UP S & P-BOXES FOR THE KEY
	for ($i=0;$i<18;$i++)
		{
		my $temp=	($keybytes[$j]<<24) +
				($keybytes[($j+1)%($keylen)]<<16) +
				($keybytes[($j+2)%($keylen)]<<8) +
				($keybytes[($j+3)%($keylen)]) ;
		$h{"p_boxes"}->[$i]^=$temp;
		$j=($j+4)%($keylen);
		}
	for ($i=0;$i<18;$i+=2)
		{
		($l,$r)=crypt_block(\%h,$l,$r,0);
		$h{"p_boxes"}->[$i]=$l;
		$h{"p_boxes"}->[$i+1]=$r;
		}
	for $i (0..3)
		{
		for($j=0;$j<256;$j+=2)
			{
			($l,$r)=crypt_block(\%h,$l,$r,0);
			$h{"s_boxes"}->[$i]->[$j]=$l;
			$h{"s_boxes"}->[$i]->[$j+1]=$r;
			}
		}
	# S-BOXES AND P-BOXES NOW SET UP, NEED NO LONGER CARE
	# ABOUT ACTUAL KEY
	return bless \%h, $pack;
	}

sub F
	{
	my $S0=$_[0]->{"s_boxes"}->[0]->[($_[1]&0xFF000000)>>24];
	my $S1=$_[0]->{"s_boxes"}->[1]->[($_[1]&0x00FF0000)>>16];
	my $S2=$_[0]->{"s_boxes"}->[2]->[($_[1]&0x0000FF00)>>8];
	my $S3=$_[0]->{"s_boxes"}->[3]->[($_[1]&0x000000FF)];
	# this is horrid, but otherwise Perl overflows. :(
	if($S0>$S1)
		{
		$S0=$S0-4294967296 if($S0>2147483647);
		}
	else
		{
		$S1=$S1-4294967296 if($S1>2147483647);
		}
	my $F=($S0+$S1);
	$F+=4294967296 if($F<0);
	$F^=$S2;
	if($F>$S3)
		{
		$F=$F-4294967296 if($F>2147483647);
		}
	else
		{
		$S3=$S3-4294967296 if($S3>2147483647);
		}
	$F+=$S3;
	$F&=0xFFFFFFFF;
	return $F;
	}

sub ROUND
	{
	return($_[1],($_[2]^($_[0]->{"p_boxes"}->[$_[3]]))^F($_[0],$_[1]));
	}

sub crypt_block
	{
	my $self=shift;
	my $l=shift;
	my $r=shift;
	my $d=shift;
	if(!$d)
		{
		$l^=$self->{"p_boxes"}->[0];
		for my $i (1..16)
			{
			($r,$l)=ROUND($self,$l,$r,$i);
			}
		$r^=$self->{"p_boxes"}->[17];
		}
	else
		{
		$l^=$self->{"p_boxes"}->[17];
		for my $i (1..16)
			{
			($r,$l)=ROUND($self,$l,$r,17-$i);
			}
		$r^=$self->{"p_boxes"}->[0];
		}
	return($r,$l);
	}

sub encrypt
	{
	my($self)=shift;
	my($block)=shift;
	my(@block)=split//,$block;
	map{$_=unpack("C",$_)}@block;
	# I'm not sure what endianness these are.... so hey.
	my($l)=$block[3]|($block[2]<<8)|($block[1]<<16)|($block[0]<<24);
	my($r)=$block[7]|($block[6]<<8)|($block[5]<<16)|($block[4]<<24);
	
	($l,$r)=crypt_block($self,$l,$r,0);

	@block=(
		$l>>24,($l>>16)&0xFF,($l>>8)&0xFF,$l&0xFF,
		$r>>24,($r>>16)&0xFF,($r>>8)&0xFF,$r&0xFF
		);
	map{$_=pack("C",$_)}@block;
	return join"",@block;
	}

sub decrypt
	{
	my($self)=shift;
	my($block)=shift;
	my(@block)=split//,$block;
	map{$_=unpack("C",$_)}@block;
	my($l)=$block[3]|($block[2]<<8)|($block[1]<<16)|($block[0]<<24);
	my($r)=$block[7]|($block[6]<<8)|($block[5]<<16)|($block[4]<<24);
	
	($l,$r)=crypt_block($self,$l,$r,1);

	@block=(
		$l>>24,($l>>16)&0xFF,($l>>8)&0xFF,$l&0xFF,
		$r>>24,($r>>16)&0xFF,($r>>8)&0xFF,$r&0xFF
		);
	map{$_=pack("C",$_)}@block;
	return join"",@block;
	}

sub blocksize
	{
	return 8;
	}

sub keysize
	{
	return 56;
	}
WFTP_FILE_END: www_ftp/wftpSession.pm
WFTP_FILE_START: www_ftp/wftp_common.pl
###########################################################
# WWW FTP Client Pro common library file
###########################################################
sub start_html {
	my ($q) = @_;
	print $q->header();
	print <<"EOT";
<HTML><HEAD>
<TITLE>WWW FTP Client</TITLE>
<SCRIPT LANGUAGE="JavaScript">
function sf(dir, sortby, order){
	if(dir){
		document.my_form.dir.value = dir;
		}
	if(sortby){
		document.my_form.sortby.value = sortby;
		}
	if(order){
		document.my_form.order.value = order;
		}
	document.my_form.submit();
	}

function go_sm(){
	document.my_form.action = "$parent_name";
	document.my_form.submit();
	}

function demo_version() {
	alert("This feature is available only in the Pro version. Please go to\\nhttp://www.hitcode.com/products/wftp/pro.php for details.");
	return false;
	}

function act(command, tocheck){
	if(tocheck && document.my_form.num_sel.value > 0){
		document.my_form.ftp_action.value = command;
		document.my_form.submit();
		}
	else if (tocheck){
		alert("$msg[123]");
		}
	else {
		document.my_form.ftp_action.value = command;
		document.my_form.submit();
		}
	}

function highlight_all() {
	var mf = document.my_form;
	var len = mf.elements.length;
	for (var i = 0; i < len; i++) {
		var e = mf.elements[i];
		if ( (e.type == "checkbox") && (e.name != "switcher") ) {
			if(e.checked != mf.switcher.checked){
				e.checked = mf.switcher.checked;
				highlight(e);
				}
			}
		}
	}

function highlight(e){
	var table = null;
	if (e.parentNode.parentNode.parentNode.parentNode){
		table = e.parentNode.parentNode.parentNode.parentNode;
		}
	else if (e.parentElement.parentElement.parentElement){
		table = e.parentElement.parentElement.parentElement;
		}
	if (table){
		if(e.checked){
			table.className = "listing_high";
			document.my_form.num_sel.value++;
			}
		else {
			table.className = "listing";
			document.my_form.num_sel.value--;
			}
		}
	}

function online_demo() {
	alert("Sorry, upload is not available in this online demo. Please install the script on your server.");
	return false;
	}
</SCRIPT>
<STYLE TYPE=text/css>
BODY {
	FONT-FAMILY: Arial, Helvetica;
	FONT-SIZE: 10pt;
	FONT-WEIGHT: normal;
	}
TABLE {
	BORDER: 0;
	MARGIN: 0;
	TEXT-ALIGN: center;
	}
TABLE.listing {
	BACKGROUND-COLOR: #EEEEEE;
	BORDER-BOTTOM: #FFFFFF 1px solid;
	}
TABLE.listing_high {
	BACKGROUND-COLOR: #CCCCCC;
	BORDER-BOTTOM: #BBBBBB 1px solid;
	}
TD {
	FONT-SIZE: 10pt;
	PADDING: 0;
	}
H4 {
	COLOR: #BB0000;
	PADDING: 0;
	MARGIN: 0;
	}
TR.header1 {
	BACKGROUND-COLOR: #FF8000;
	}
TR.header2 {
	BACKGROUND-COLOR: #7DA7D9;
	}
TR.header3 {
	BACKGROUND-COLOR: #BFD2E7;
	}
INPUT {
	BORDER-RIGHT: #555555 1px solid;
	BORDER-LEFT: #555555 1px solid;
	BORDER-TOP: #555555 1px solid;
	BORDER-BOTTOM: #555555 1px solid;
	CURSOR: auto;
	FONT-FAMILY: Tahoma, Verdana, Arial, Helvetica;
	FONT-WEIGHT: bold;
	FONT-SIZE: 8pt;
	}
.movebutton {
	BACKGROUND-COLOR: #FFC000;
	}
.submitbutton {
	BACKGROUND-COLOR: #FF8000;
	}
.deletebutton {
	BACKGROUND-COLOR: #EE0000;
	}
.newbutton {
	BACKGROUND-COLOR: #80FF80;
	}
</STYLE>
</HEAD>
<BODY BGCOLOR="#BFD2E7"><CENTER>
EOT
	$conf->{'header_sent'} = 1;
	}

sub end_html {
	my $sm = shift;
	print qq(</FORM>) unless ($sm);
	print qq(<P><B>WWW FTP Client</B> Version $conf->{'ver'} running on $^O.<BR>);
	print qq(<A HREF="http://www.hitcode.com/products/wftp/pro.php">Upgrade to the Pro version!</A><BR>);
	print qq(Copyright &copy 2000-2003 <A HREF="http://www.hitcode.com/"><B><FONT COLOR="#000080">hit</FONT><FONT COLOR="#FF8000">code</FONT></B></A>);
	print qq(</CENTER></BODY></HTML>);
	exit;
	}

sub error_here {
	my($reason, @param) = @_;
	start_html($q) unless $conf->{'header_sent'};
	if ($reason eq "bad_login"){
		print "$msg[45]";
		clear_info();
		start_form();
		print qq(<BR><INPUT TYPE="button" onClick="go_sm()" VALUE="$msg[83]">);
		end_html();
		exit;
		}
	if ($reason eq "bad_site"){
		print "$msg[46]";
		exit;
		}
	if ($reason eq "not_renamed"){
		print "$msg[47] <B>$param[0]</B> => <B>$param[1].</B><BR>";
		}
	if ($reason eq "chmod_not_supported"){
		print "$msg[48]<BR>";
		}
	if ($reason eq "not_chmodded"){
		print "$msg[49] <B>$param[0]</B> => <B>$param[1]</B><BR>";
		}
	if ($reason eq "dir_not_deleted"){
		print "$msg[50] <B>$param[0]</B>.<BR>";
		}
	if ($reason eq "file_not_deleted"){
		print "$msg[51] <B>$param[0]</B>.<BR>";
		}
	if ($reason eq "not_deleted"){
		print "$msg[124] <B>$param[0]</B>.<BR>";
		}
	if ($reason eq "dir_not_created"){
		print "$msg[54] <B>$param[0]</B>.<BR>";
		}
	if ($reason eq 'bad_dir'){
		print "$msg[55] <B>$param[0]</B>.<BR>";
		}
	if ($reason eq 'bad_upload'){
		print "$msg[56] <B>$param[0]</B>.<BR>";
		}
	if ($reason eq "bad_name"){
		print "$msg[57] <B>$param[0]</B>. $msg[58]<BR>";
		}
	if ($reason eq "session_expired"){
		if($page eq 'selector'){
			print qq($msg[93]<BR><A TARGET="_parent" HREF="$parent_name" onClick="window.close()">Login</A><BR>);
			}
		else {
			print qq($msg[93]<BR><A HREF="$parent_name">Login</A><BR>);
			}
		end_html();
		}
	if ($reason eq "session_retrieve"){
		if($page eq 'selector'){
			print qq($msg[94]<BR><A TARGET="_parent" HREF="$parent_name" onClick="window.close()">Login</A><BR>);			
			}
		else {
			print qq($msg[94]<BR><A HREF="$parent_name">Login</A><BR>);
			}
		end_html();
		}
	if ($reason eq 'no_session_id'){
		print "No session id!<BR>";
		}
	if ($reason eq "generic"){
		print "$msg[59]: ", $param[0];
		}
	}

sub set_language {
@msg = ("", "Site", "Current Directory", "", "Logout", "New Dir", "New Text File",
"Upload Files", "Change Dir", "  Up  ", "Rename", "Chmod", "Edit File", "Delete File",
"Delete Dir", "Directories", "Files", "No directories", "No files", "Name", "Mode",
"Size", "Old name", "New name", "Cannot get file", "Edit", "Cannot open file",
"Cannot close file", "Cannot delete file", "Please select files to <B>upload</B>.",
"Please make sure you are not making a fatal mistake.<BR>Only checked files(directories) will be processed.",
"Host address", "User", "Password", "Start directory", "Login", "Clear", "has been renamed to",
"has been chmodded to", "Directory", "has been deleted", "File", "has been modifed",
"has been created", "has been uploaded", "Cannot login to host.<BR>Either the host is unreachable or you entered the wrong data.",
"Cannot connect to host.<BR>Host seems not to answer.", "Cannot rename</B>",
"<B>chmod</B> command not supported on this FTP server.", "Cannot chmod</B>.",
"Cannot delete directory", "Cannot delete file", "Cannot modify file",
"Cannot get file from FTP server", "Cannot create directory", "Cannot move to",
"Cannot upload file", "Illegal new name for", "Please use only alphanumerics, '.' and '+'.",
"FTP error occured", "", "Host Address", "", "", "Edit", "Delete", "", "", "", "", "", "",
"", "", "", "", "", "Confirm Rename", "Confirm Chmod", "Confirm Delete File",
"Confirm Delete Dir", "", "Confirm Upload", "Cancel", "", "", "Cannot open directory",
"Cannot close directory", "", "Download", "File has not been modifed",
"Cannot save temporary file on local server", "File has not been uploaded",
"Your session has expired, you have to login again.",
"Cannot retrieve session data. Try to login again.", "Uploading to", "Select All",
"Clear All", "Save and Exit", "Confirm Move", "Move", "", "Select Dir", "", "", "", "", 
"", "", "File name", "", "", "Actions", "Owner", "Group", "Type", "Confirm Delete",
"Please enter the new directory name", "", "", "Date", "Please enter the file name!",
"Selected", "Please select files or directories.", "Cannot delete",);
	}

# Don't forget to return a true value
1;
WFTP_FILE_END: www_ftp/wftp_common.pl
WFTP_FILE_START: www_ftp/wftp_conf.pl
###########################################################
# WWW FTP Client Pro configuration file
###########################################################

# GENERAL CONFIGURATION

#number of upload fields
$conf->{upload_files} = 1;

#session lifetime in seconds
$conf->{session_lifetime} = 1000;

#directory for data. By default, it is the current one, but I recommend to set it
#up somewhere outside of the web path, no ending slash
$conf->{data_dir} = 'www_ftp';

#directory for temp sessions files, it will be in data dir
$conf->{session_dir} = 'sessions';

# HEADER COMPOSITION AND ACTIONS PERMISSIONS
# The following options are available:
# 'new_dir','new_text_file','upload','rename','chmod','move','edit','download','delete'
# and 'sep' for a separator. This defines the position of the action buttons and at the
# same time permissions to perform these actions.

# Set up buttons for the first row
$conf->{'header'}->[1] = ['new_dir','sep','new_text_file','sep','upload'];

# and for the second one
$conf->{'header'}->[2] = ['rename','chmod','move','sep','edit','download','sep','delete'];

# finally the version of the product
$conf->{'ver'} = '3.0.2';

# Don't forget to return a true value
1;
WFTP_FILE_END: www_ftp/wftp_conf.pl
WFTP_FILE_START: www_ftp/Net/Cmd.pm
# Net::Cmd.pm
#
# Copyright (c) 1995-1997 Graham Barr <gbarr@pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.

package Net::Cmd;

require 5.001;
require Exporter;

use strict;
use vars qw(@ISA @EXPORT $VERSION);
use Carp;

$VERSION = "2.18";
@ISA     = qw(Exporter);
@EXPORT  = qw(CMD_INFO CMD_OK CMD_MORE CMD_REJECT CMD_ERROR CMD_PENDING);

sub CMD_INFO	{ 1 }
sub CMD_OK	{ 2 }
sub CMD_MORE	{ 3 }
sub CMD_REJECT	{ 4 }
sub CMD_ERROR	{ 5 }
sub CMD_PENDING { 0 }

my %debug = ();

sub _print_isa
{
 no strict qw(refs);

 my $pkg = shift;
 my $cmd = $pkg;

 $debug{$pkg} ||= 0;

 my %done = ();
 my @do   = ($pkg);
 my %spc = ( $pkg , "");

 print STDERR "\n";
 while ($pkg = shift @do)
  {
   next if defined $done{$pkg};

   $done{$pkg} = 1;

   my $v = defined ${"${pkg}::VERSION"}
                ? "(" . ${"${pkg}::VERSION"} . ")"
                : "";

   my $spc = $spc{$pkg};
   print STDERR "$cmd: ${spc}${pkg}${v}\n";

   if(@{"${pkg}::ISA"})
    {
     @spc{@{"${pkg}::ISA"}} = ("  " . $spc{$pkg}) x @{"${pkg}::ISA"};
     unshift(@do, @{"${pkg}::ISA"});
    }
  }

 print STDERR "\n";
}

sub debug
{
 @_ == 1 or @_ == 2 or croak 'usage: $obj->debug([LEVEL])';

 my($cmd,$level) = @_;
 my $pkg = ref($cmd) || $cmd;
 my $oldval = 0;

 if(ref($cmd))
  {
   $oldval = ${*$cmd}{'net_cmd_debug'} || 0;
  }
 else
  {
   $oldval = $debug{$pkg} || 0;
  }

 return $oldval
    unless @_ == 2;

 $level = $debug{$pkg} || 0
    unless defined $level;

 _print_isa($pkg)
    if($level && !exists $debug{$pkg});

 if(ref($cmd))
  {
   ${*$cmd}{'net_cmd_debug'} = $level;
  }
 else
  {
   $debug{$pkg} = $level;
  }

 $oldval;
}

sub message
{
 @_ == 1 or croak 'usage: $obj->message()';

 my $cmd = shift;

 wantarray ? @{${*$cmd}{'net_cmd_resp'}}
    	   : join("", @{${*$cmd}{'net_cmd_resp'}});
}

sub debug_text { $_[2] }

sub debug_print
{
 my($cmd,$out,$text) = @_;
 print STDERR $cmd,($out ? '>>> ' : '<<< '), $cmd->debug_text($out,$text);
}

sub code
{
 @_ == 1 or croak 'usage: $obj->code()';

 my $cmd = shift;

 ${*$cmd}{'net_cmd_code'} = "000"
	unless exists ${*$cmd}{'net_cmd_code'};

 ${*$cmd}{'net_cmd_code'};
}

sub status
{
 @_ == 1 or croak 'usage: $obj->status()';

 my $cmd = shift;

 substr(${*$cmd}{'net_cmd_code'},0,1);
}

sub set_status
{
 @_ == 3 or croak 'usage: $obj->set_status(CODE, MESSAGE)';

 my $cmd = shift;
 my($code,$resp) = @_;

 $resp = [ $resp ]
	unless ref($resp);

 (${*$cmd}{'net_cmd_code'},${*$cmd}{'net_cmd_resp'}) = ($code, $resp);

 1;
}

sub command
{
 my $cmd = shift;

 return $cmd unless defined fileno($cmd);
 
 $cmd->dataend()
    if(exists ${*$cmd}{'net_cmd_lastch'});

 if (scalar(@_))
  {
   local $SIG{PIPE} = 'IGNORE';

   my $str =  join(" ", map { /\n/ ? do { my $n = $_; $n =~ tr/\n/ /; $n } : $_; } @_) . "\015\012";
   my $len = length $str;
   my $swlen;
   
   $cmd->close
	unless (defined($swlen = syswrite($cmd,$str,$len)) && $swlen == $len);

   $cmd->debug_print(1,$str)
	if($cmd->debug);

   ${*$cmd}{'net_cmd_resp'} = [];      # the response
   ${*$cmd}{'net_cmd_code'} = "000";	# Made this one up :-)
  }

 $cmd;
}

sub ok
{
 @_ == 1 or croak 'usage: $obj->ok()';

 my $code = $_[0]->code;
 0 < $code && $code < 400;
}

sub unsupported
{
 my $cmd = shift;

 ${*$cmd}{'net_cmd_resp'} = [ 'Unsupported command' ];
 ${*$cmd}{'net_cmd_code'} = 580;
 0;
}

sub getline
{
 my $cmd = shift;

 ${*$cmd}{'net_cmd_lines'} ||= [];

 return shift @{${*$cmd}{'net_cmd_lines'}}
    if scalar(@{${*$cmd}{'net_cmd_lines'}});

 my $partial = defined(${*$cmd}{'net_cmd_partial'})
		? ${*$cmd}{'net_cmd_partial'} : "";
 my $fd = fileno($cmd);
 
 return undef
	unless defined $fd;

 my $rin = "";
 vec($rin,$fd,1) = 1;

 my $buf;

 until(scalar(@{${*$cmd}{'net_cmd_lines'}}))
  {
   my $timeout = $cmd->timeout || undef;
   my $rout;
   if (select($rout=$rin, undef, undef, $timeout))
    {
     unless (sysread($cmd, $buf="", 1024))
      {
       carp(ref($cmd) . ": Unexpected EOF on command channel")
		if $cmd->debug;
       $cmd->close;
       return undef;
      } 

     substr($buf,0,0) = $partial;	## prepend from last sysread

     my @buf = split(/\015?\012/, $buf, -1);	## break into lines

     $partial = pop @buf;

     push(@{${*$cmd}{'net_cmd_lines'}}, map { "$_\n" } @buf);

    }
   else
    {
     carp("$cmd: Timeout") if($cmd->debug);
     return undef;
    }
  }

 ${*$cmd}{'net_cmd_partial'} = $partial;

 shift @{${*$cmd}{'net_cmd_lines'}};
}

sub ungetline
{
 my($cmd,$str) = @_;

 ${*$cmd}{'net_cmd_lines'} ||= [];
 unshift(@{${*$cmd}{'net_cmd_lines'}}, $str);
}

sub parse_response
{
 return ()
    unless $_[1] =~ s/^(\d\d\d)(.?)//o;
 ($1, $2 eq "-");
}

sub response
{
 my $cmd = shift;
 my($code,$more) = (undef) x 2;

 ${*$cmd}{'net_cmd_resp'} ||= [];

 while(1)
  {
   my $str = $cmd->getline();

   return CMD_ERROR
	unless defined($str);

   $cmd->debug_print(0,$str)
     if ($cmd->debug);

   ($code,$more) = $cmd->parse_response($str);
   unless(defined $code)
    {
     $cmd->ungetline($str);
     last;
    }

   ${*$cmd}{'net_cmd_code'} = $code;

   push(@{${*$cmd}{'net_cmd_resp'}},$str);

   last unless($more);
  } 

 substr($code,0,1);
}

sub read_until_dot
{
 my $cmd = shift;
 my $fh  = shift;
 my $arr = [];

 while(1)
  {
   my $str = $cmd->getline() or return undef;

   $cmd->debug_print(0,$str)
     if ($cmd->debug & 4);

   last if($str =~ /^\.\r?\n/o);

   $str =~ s/^\.\././o;

   if (defined $fh)
    {
     print $fh $str;
    }
   else
    {
     push(@$arr,$str);
    }
  }

 $arr;
}

sub datasend
{
 my $cmd = shift;
 my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_;
 my $line = join("" ,@$arr);

 return 0 unless defined(fileno($cmd));

 return 1
    unless length($line);

 if($cmd->debug)
  {
   my $b = "$cmd>>> ";
   print STDERR $b,join("\n$b",split(/\n/,$line)),"\n";
  }

 $line =~ s/\n/\015\012/sgo;

 ${*$cmd}{'net_cmd_lastch'} ||= " ";
 $line = ${*$cmd}{'net_cmd_lastch'} . $line;

 $line =~ s/(\012\.)/$1./sog;

 ${*$cmd}{'net_cmd_lastch'} = substr($line,-1,1);

 my $len = length($line) - 1;
 my $offset = 1;
 my $win = "";
 vec($win,fileno($cmd),1) = 1;
 my $timeout = $cmd->timeout || undef;

 while($len)
  {
   my $wout;
   if (select(undef,$wout=$win, undef, $timeout) > 0)
    {
     my $w = syswrite($cmd, $line, $len, $offset);
     unless (defined($w))
      {
       carp("$cmd: $!") if $cmd->debug;
       return undef;
      }
     $len -= $w;
     $offset += $w;
    }
   else
    {
     carp("$cmd: Timeout") if($cmd->debug);
     return undef;
    }
  }

 1;
}

sub dataend
{
 my $cmd = shift;

 return 0 unless defined(fileno($cmd));

 return 1
    unless(exists ${*$cmd}{'net_cmd_lastch'});

 if(${*$cmd}{'net_cmd_lastch'} eq "\015")
  {
   syswrite($cmd,"\012",1);
   print STDERR "\n"
    if($cmd->debug);
  }
 elsif(${*$cmd}{'net_cmd_lastch'} ne "\012")
  {
   syswrite($cmd,"\015\012",2);
   print STDERR "\n"
    if($cmd->debug);
  }

 print STDERR "$cmd>>> .\n"
    if($cmd->debug);

 syswrite($cmd,".\015\012",3);

 delete ${*$cmd}{'net_cmd_lastch'};

 $cmd->response() == CMD_OK;
}

1;

__END__


=head1 NAME

Net::Cmd - Network Command class (as used by FTP, SMTP etc)

=head1 SYNOPSIS

    use Net::Cmd;
    
    @ISA = qw(Net::Cmd);

=head1 DESCRIPTION

C<Net::Cmd> is a collection of methods that can be inherited by a sub class
of C<IO::Handle>. These methods implement the functionality required for a
command based protocol, for example FTP and SMTP.

=head1 USER METHODS

These methods provide a user interface to the C<Net::Cmd> object.

=over 4

=item debug ( VALUE )

Set the level of debug information for this object. If C<VALUE> is not given
then the current state is returned. Otherwise the state is changed to 
C<VALUE> and the previous state returned. 

Set the level of debug information for this object. If no argument is
given then the current state is returned. Otherwise the state is
changed to C<$value>and the previous state returned.  Different packages
may implement different levels of debug but, a  non-zero value result in
copies of all commands and responses also being sent to STDERR.

If C<VALUE> is C<undef> then the debug level will be set to the default
debug level for the class.

This method can also be called as a I<static> method to set/get the default
debug level for a given class.

=item message ()

Returns the text message returned from the last command

=item code ()

Returns the 3-digit code from the last command. If a command is pending
then the value 0 is returned

=item ok ()

Returns non-zero if the last code value was greater than zero and
less than 400. This holds true for most command servers. Servers
where this does not hold may override this method.

=item status ()

Returns the most significant digit of the current status code. If a command
is pending then C<CMD_PENDING> is returned.

=item datasend ( DATA )

Send data to the remote server, converting LF to CRLF. Any line starting
with a '.' will be prefixed with another '.'.
C<DATA> may be an array or a reference to an array.

=item dataend ()

End the sending of data to the remote server. This is done by ensuring that
the data already sent ends with CRLF then sending '.CRLF' to end the
transmission. Once this data has been sent C<dataend> calls C<response> and
returns true if C<response> returns CMD_OK.

=back

=head1 CLASS METHODS

These methods are not intended to be called by the user, but used or 
over-ridden by a sub-class of C<Net::Cmd>

=over 4

=item debug_print ( DIR, TEXT )

Print debugging information. C<DIR> denotes the direction I<true> being
data being sent to the server. Calls C<debug_text> before printing to
STDERR.

=item debug_text ( TEXT )

This method is called to print debugging information. TEXT is
the text being sent. The method should return the text to be printed

This is primarily meant for the use of modules such as FTP where passwords
are sent, but we do not want to display them in the debugging information.

=item command ( CMD [, ARGS, ... ])

Send a command to the command server. All arguments a first joined with
a space character and CRLF is appended, this string is then sent to the
command server.

Returns undef upon failure

=item unsupported ()

Sets the status code to 580 and the response text to 'Unsupported command'.
Returns zero.

=item response ()

Obtain a response from the server. Upon success the most significant digit
of the status code is returned. Upon failure, timeout etc., I<undef> is
returned.

=item parse_response ( TEXT )

This method is called by C<response> as a method with one argument. It should
return an array of 2 values, the 3-digit status code and a flag which is true
when this is part of a multi-line response and this line is not the list.

=item getline ()

Retrieve one line, delimited by CRLF, from the remote server. Returns I<undef>
upon failure.

B<NOTE>: If you do use this method for any reason, please remember to add
some C<debug_print> calls into your method.

=item ungetline ( TEXT )

Unget a line of text from the server.

=item read_until_dot ()

Read data from the remote server until a line consisting of a single '.'.
Any lines starting with '..' will have one of the '.'s removed.

Returns a reference to a list containing the lines, or I<undef> upon failure.

=back

=head1 EXPORTS

C<Net::Cmd> exports six subroutines, five of these, C<CMD_INFO>, C<CMD_OK>,
C<CMD_MORE>, C<CMD_REJECT> and C<CMD_ERROR> ,correspond to possible results
of C<response> and C<status>. The sixth is C<CMD_PENDING>.

=head1 AUTHOR

Graham Barr <gbarr@pobox.com>

=head1 COPYRIGHT

Copyright (c) 1995-1997 Graham Barr. All rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut
WFTP_FILE_END: www_ftp/Net/Cmd.pm
WFTP_FILE_START: www_ftp/Net/Config.pm

package Net::Config;
# $Id: //depot/libnet/Net/Config.pm#6 $

require Exporter;
use vars qw(@ISA @EXPORT %NetConfig $VERSION $CONFIGURE $LIBNET_CFG);
use Socket qw(inet_aton inet_ntoa);
use strict;

@EXPORT  = qw(%NetConfig);
@ISA     = qw(Net::LocalCfg Exporter);
$VERSION = "1.04";

eval { local $SIG{__DIE__}; require Net::LocalCfg };

%NetConfig = (
    nntp_hosts => [],
    snpp_hosts => [],
    pop3_hosts => [],
    smtp_hosts => [],
    ph_hosts => [],
    daytime_hosts => [],
    time_hosts => [],
    inet_domain => undef,
    ftp_firewall => undef,
    ftp_ext_passive => 0,
    ftp_int_passive => 0,
    test_hosts => 1,
    test_exist => 1,
);

my $file = __FILE__;
my $ref;
$file =~ s/Config.pm/libnet.cfg/;
if ( -f $file ) {
    $ref = eval { do $file };
    if (ref($ref) eq 'HASH') {
	%NetConfig = (%NetConfig, %{ $ref });
	$LIBNET_CFG = $file;
    }
}
if ($< == $> and !$CONFIGURE)  {
    my $home = eval { (getpwuid($>))[7] } || $ENV{HOME};
    $file = $home . "/.libnetrc";
    $ref = eval { do $file } if -f $file;
    %NetConfig = (%NetConfig, %{ $ref })
	if ref($ref) eq 'HASH';	
}
my ($k,$v);
while(($k,$v) = each %NetConfig) {
    $v = [ $v ]
	if($k =~ /_hosts$/ && !ref($v));
}

# Take a hostname and determine if it is inside te firewall

sub requires_firewall {
    shift; # ignore package
    my $host = shift;

    return 0 unless defined $NetConfig{'ftp_firewall'};

    $host = inet_aton($host) or return -1;
    $host = inet_ntoa($host);

    if(exists $NetConfig{'local_netmask'}) {
	my $quad = unpack("N",pack("C*",split(/\./,$host)));
	my $list = $NetConfig{'local_netmask'};
	$list = [$list] unless ref($list);
	foreach (@$list) {
	    my($net,$bits) = (m#^(\d+\.\d+\.\d+\.\d+)/(\d+)$#) or next;
	    my $mask = ~0 << (32 - $bits);
	    my $addr = unpack("N",pack("C*",split(/\./,$net)));

	    return 0 if (($addr & $mask) == ($quad & $mask));
	}
	return 1;
    }

    return 0;
}

use vars qw(*is_external);
*is_external = \&requires_firewall;

1;

__END__

=head1 NAME

Net::Config - Local configuration data for libnet

=head1 SYNOPSYS

    use Net::Config qw(%NetConfig);

=head1 DESCRIPTION

C<Net::Config> holds configuration data for the modules in the libnet
distribuion. During installation you will be asked for these values.

The configuration data is held globally in a file in the perl installation
tree, but a user may override any of these values by providing thier own. This
can be done by having a C<.libnetrc> file in thier home directory. This file
should return a reference to a HASH containing the keys described below.
For example

    # .libnetrc
    {
        nntp_hosts => [ "my_prefered_host" ],
	ph_hosts   => [ "my_ph_server" ],
    }
    __END__

=head1 METHODS

C<Net::Config> defines the following methods. They are methods as they are
invoked as class methods. This is because C<Net::Config> inherits from
C<Net::LocalCfg> so you can override these methods if you want.

=over 4

=item requires_firewall HOST

Attempts to determine if a given host is outside your firewall. Possible
return values are.

  -1  Cannot lookup hostname
   0  Host is inside firewall (or there is no ftp_firewall entry)
   1  Host is outside the firewall

This is done by using hostname lookup and the C<local_netmask> entry in
the configuration data.

=back

=head1 NetConfig VALUES

=over 4

=item nntp_hosts

=item snpp_hosts

=item pop3_hosts

=item smtp_hosts

=item ph_hosts

=item daytime_hosts

=item time_hosts

Each is a reference to an array of hostnames (in order of preference),
which should be used for the given protocol

=item inet_domain

Your internet domain name

=item ftp_firewall

If you have an FTP proxy firewall (B<NOT> a HTTP or SOCKS firewall)
then this value should be set to the firewall hostname. If your firewall
does not listen to port 21, then this value should be set to
C<"hostname:port"> (eg C<"hostname:99">)

=item ftp_ext_passive

=item ftp_int_pasive

FTP servers normally work on a non-passive mode. That is when you want to
transfer data you have to tell the server the address and port to
connect to.

With some firewalls this does not work as te server cannot
connect to your machine (because you are beind a firewall) and the firewall
does not re-write te command. In this case you should set C<ftp_ext_passive>
to a I<true> value.

Some servers are configured to only work in passive mode. If you have
one of these you can force C<Net::FTP> to always transfer in passive
mode, when not going via a firewall, by cetting C<ftp_int_passive> to
a I<true> value.

=item local_netmask

A reference to a list of netmask strings in the form C<"134.99.4.0/24">.
These are used by the C<requires_firewall> function to determine if a given
host is inside or outside your firewall.

=back

The following entries are used during installation & testing on the
libnet package

=over 4

=item test_hosts

If true them C<make test> may attempt to connect to hosts given in the
configuration.

=item test_exists

If true the C<Configure> will check each hostname given that it exists

=back

=cut
WFTP_FILE_END: www_ftp/Net/Config.pm
WFTP_FILE_START: www_ftp/Net/Domain.pm
# Net::Domain.pm
#
# Copyright (c) 1995-1998 Graham Barr <gbarr@pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.

package Net::Domain;

require Exporter;

use Carp;
use strict;
use vars qw($VERSION @ISA @EXPORT_OK);
use Net::Config;

@ISA = qw(Exporter);
@EXPORT_OK = qw(hostname hostdomain hostfqdn domainname);

$VERSION = "2.13"; # $Id: //depot/libnet/Net/Domain.pm#10 $

my($host,$domain,$fqdn) = (undef,undef,undef);

# Try every conceivable way to get hostname.

sub _hostname {

    # we already know it
    return $host
    	if(defined $host);

    if ($^O eq 'MSWin32') {
        require Socket;
        my ($name,$alias,$type,$len,@addr) =  gethostbyname($ENV{'COMPUTERNAME'}||'localhost');
        while (@addr)
         {
          my $a = shift(@addr);
          $host = gethostbyaddr($a,Socket::AF_INET());
          last if defined $host;
         } 
        if (index($host,'.') > 0) {
           $fqdn = $host;
           ($host,$domain) = $fqdn =~ /^([^\.]+)\.(.*)$/;
         }
        return $host;
    }
    elsif ($^O eq 'MacOS') {
	chomp ($host = `hostname`);
    }
    elsif ($^O eq 'VMS') {   ## multiple varieties of net s/w makes this hard
        $host = $ENV{'UCX$INET_HOST'} if defined($ENV{'UCX$INET_HOST'});
        $host = $ENV{'MULTINET_HOST_NAME'} if defined($ENV{'MULTINET_HOST_NAME'});
        if (index($host,'.') > 0) {
           $fqdn = $host;
           ($host,$domain) = $fqdn =~ /^([^\.]+)\.(.*)$/;
        }
        return $host;
    }
    else {
	local $SIG{'__DIE__'};

	# syscall is preferred since it avoids tainting problems
	eval {
    	    my $tmp = "\0" x 256; ## preload scalar
    	    eval {
    		package main;
     		require "syscall.ph";
		defined(&main::SYS_gethostname);
    	    }
    	    || eval {
    		package main;
     		require "sys/syscall.ph";
		defined(&main::SYS_gethostname);
    	    }
            and $host = (syscall(&main::SYS_gethostname, $tmp, 256) == 0)
		    ? $tmp
		    : undef;
	}

	# POSIX
	|| eval {
	    require POSIX;
	    $host = (POSIX::uname())[1];
	}

	# trusty old hostname command
	|| eval {
    	    chop($host = `(hostname) 2>/dev/null`); # BSD'ish
	}

	# sysV/POSIX uname command (may truncate)
	|| eval {
    	    chop($host = `uname -n 2>/dev/null`); ## SYSV'ish && POSIX'ish
	}

	# Apollo pre-SR10
	|| eval {
    	    $host = (split(/[:\. ]/,`/com/host`,6))[0];
	}

	|| eval {
    	    $host = "";
	};
    }
 
    # remove garbage 
    $host =~ s/[\0\r\n]+//go;
    $host =~ s/(\A\.+|\.+\Z)//go;
    $host =~ s/\.\.+/\./go;

    $host;
}

sub _hostdomain {

    # we already know it
    return $domain
    	if(defined $domain);

    local $SIG{'__DIE__'};

    return $domain = $NetConfig{'inet_domain'}
	if defined $NetConfig{'inet_domain'};

    # try looking in /etc/resolv.conf
    # putting this here and assuming that it is correct, eliminates
    # calls to gethostbyname, and therefore DNS lookups. This helps
    # those on dialup systems.

    local *RES;

    if(open(RES,"/etc/resolv.conf")) {
    	while(<RES>) {
    	    $domain = $1
    	    	if(/\A\s*(?:domain|search)\s+(\S+)/);
    	}
    	close(RES);

    	return $domain
    	    if(defined $domain);
    }

    # just try hostname and system calls

    my $host = _hostname();
    my(@hosts);
    local($_);

    @hosts = ($host,"localhost");

    unless($host =~ /\./) {
	my $dom = undef;
        eval {
    	    my $tmp = "\0" x 256; ## preload scalar
    	    eval {
    	        package main;
     	        require "syscall.ph";
    	    }
    	    || eval {
    	        package main;
     	        require "sys/syscall.ph";
    	    }
            and $dom = (syscall(&main::SYS_getdomainname, $tmp, 256) == 0)
		    ? $tmp
		    : undef;
        };

	chop($dom = `domainname 2>/dev/null`)
		unless(defined $dom);

	if(defined $dom) {
	    my @h = ();
	    while(length($dom)) {
		push(@h, "$host.$dom");
		$dom =~ s/^[^.]+.//;
	    }
	    unshift(@hosts,@h);
    	}
    }

    # Attempt to locate FQDN

    foreach (@hosts) {
    	my @info = gethostbyname($_);

    	next unless @info;

    	# look at real name & aliases
    	my $site;
    	foreach $site ($info[0], split(/ /,$info[1])) { 
    	    if(rindex($site,".") > 0) {

    	    	# Extract domain from FQDN

     	    	($domain = $site) =~ s/\A[^\.]+\.//; 
     	        return $domain;
    	    }
    	}
    }

    # Look for environment variable

    $domain ||= $ENV{LOCALDOMAIN} ||= $ENV{DOMAIN} || undef;

    if(defined $domain) {
    	$domain =~ s/[\r\n\0]+//g;
    	$domain =~ s/(\A\.+|\.+\Z)//g;
    	$domain =~ s/\.\.+/\./g;
    }

    $domain;
}

sub domainname {

    return $fqdn
    	if(defined $fqdn);

    _hostname();
    _hostdomain();

    # Assumption: If the host name does not contain a period
    # and the domain name does, then assume that they are correct
    # this helps to eliminate calls to gethostbyname, and therefore
    # eleminate DNS lookups

    return $fqdn = $host . "." . $domain
	if($host !~ /\./ && $domain =~ /\./);

    # For hosts that have no name, just an IP address
    return $fqdn = $host if $host =~ /^\d+(\.\d+){3}$/;

    my @host   = split(/\./, $host);
    my @domain = split(/\./, $domain);
    my @fqdn   = ();

    # Determine from @host & @domain the FQDN

    my @d = @domain;
 
LOOP:
    while(1) {
    	my @h = @host;
    	while(@h) {
    	    my $tmp = join(".",@h,@d);
    	    if((gethostbyname($tmp))[0]) {
     	        @fqdn = (@h,@d);
     	        $fqdn = $tmp;
     	      last LOOP;
    	    }
    	    pop @h;
    	}
    	last unless shift @d;
    }

    if(@fqdn) {
    	$host = shift @fqdn;
    	until((gethostbyname($host))[0]) {
    	    $host .= "." . shift @fqdn;
    	}
    	$domain = join(".", @fqdn);
    }
    else {
    	undef $host;
    	undef $domain;
    	undef $fqdn;
    }

    $fqdn;
}

sub hostfqdn { domainname() }

sub hostname {
    domainname()
    	unless(defined $host);
    return $host;
}

sub hostdomain {
    domainname()
    	unless(defined $domain);
    return $domain;
}

1; # Keep require happy

__END__

=head1 NAME

Net::Domain - Attempt to evaluate the current host's internet name and domain

=head1 SYNOPSIS

    use Net::Domain qw(hostname hostfqdn hostdomain);

=head1 DESCRIPTION

Using various methods B<attempt> to find the Fully Qualified Domain Name (FQDN)
of the current host. From this determine the host-name and the host-domain.

Each of the functions will return I<undef> if the FQDN cannot be determined.

=over 4

=item hostfqdn ()

Identify and return the FQDN of the current host.

=item hostname ()

Returns the smallest part of the FQDN which can be used to identify the host.

=item hostdomain ()

Returns the remainder of the FQDN after the I<hostname> has been removed.

=back

=head1 AUTHOR

Graham Barr <gbarr@pobox.com>.
Adapted from Sys::Hostname by David Sundstrom <sunds@asictest.sc.ti.com>

=head1 COPYRIGHT

Copyright (c) 1995-1998 Graham Barr. All rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut
WFTP_FILE_END: www_ftp/Net/Domain.pm
WFTP_FILE_START: www_ftp/Net/DummyInetd.pm
# Net::DummyInetd.pm
#
# Copyright (c) 1995-1997 Graham Barr <gbarr@pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.

package Net::DummyInetd;

require 5.002;

use IO::Handle;
use IO::Socket;
use strict;
use vars qw($VERSION);
use Carp;

$VERSION = do { my @r=(q$Revision: 1.6 $=~/\d+/g); sprintf "%d."."%02d"x$#r,@r};


sub _process
{
 my $listen = shift;
 my @cmd = @_;
 my $vec = '';
 my $r;

 vec($vec,fileno($listen),1) = 1;

 while(select($r=$vec,undef,undef,undef))
  {
   my $sock = $listen->accept;
   my $pid;

   if($pid = fork())
    {
     sleep 1;
     close($sock);
    }
   elsif(defined $pid)
    {
     my $x =  IO::Handle->new_from_fd($sock,"r");
     open(STDIN,"<&=".fileno($x)) || die "$! $@";
     close($x);

     my $y = IO::Handle->new_from_fd($sock,"w");
     open(STDOUT,">&=".fileno($y)) || die "$! $@";
     close($y);

     close($sock);
     exec(@cmd) || carp "$! $@";
    }
   else
    {
     close($sock);
     carp $!;
    }
  }
 exit -1; 
}

sub new
{
 my $self = shift;
 my $type = ref($self) || $self;

 my $listen = IO::Socket::INET->new(Listen => 5, Proto => 'tcp');
 my $pid;

 return bless [ $listen->sockport, $pid ]
	if($pid = fork());

 _process($listen,@_);
}

sub port
{
 my $self = shift;
 $self->[0];
}

sub DESTROY
{
 my $self = shift;
 kill 9, $self->[1];
}

1;

__END__

=head1 NAME

Net::DummyInetd - A dummy Inetd server

=head1 SYNOPSIS

    use Net::DummyInetd;
    use Net::SMTP;
    
    $inetd = new Net::DummyInetd qw(/usr/lib/sendmail -ba -bs);
    
    $smtp  = Net::SMTP->new('localhost', Port => $inetd->port);

=head1 DESCRIPTION

C<Net::DummyInetd> is just what it's name says, it is a dummy inetd server.
Creation of a C<Net::DummyInetd> will cause a child process to be spawned off
which will listen to a socket. When a connection arrives on this socket
the specified command is fork'd and exec'd with STDIN and STDOUT file
descriptors duplicated to the new socket.

This package was added as an example of how to use C<Net::SMTP> to connect
to a C<sendmail> process, which is not the default, via SIDIN and STDOUT.
A C<Net::Inetd> package will be available in the next release of C<libnet>

=head1 CONSTRUCTOR

=over 4

=item new ( CMD )

Creates a new object and spawns a child process which listens to a socket.
C<CMD> is a list, which will be passed to C<exec> when a new process needs
to be created.

=back

=head1 METHODS

=over 4

=item port

Returns the port number on which the I<DummyInetd> object is listening

=back

=head1 AUTHOR

Graham Barr <gbarr@pobox.com>

=head1 COPYRIGHT

Copyright (c) 1995-1997 Graham Barr. All rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut
WFTP_FILE_END: www_ftp/Net/DummyInetd.pm
WFTP_FILE_START: www_ftp/Net/FTP.pm
# Net::FTP.pm
#
# Copyright (c) 1995-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
#
# Documentation (at end) improved 1996 by Nathan Torkington <gnat@frii.com>.

package Net::FTP;

require 5.001;

use strict;
use vars qw(@ISA $VERSION);
use Carp;

use Socket 1.3;
use IO::Socket;
use Time::Local;
use Net::Cmd;
use Net::Config;
# use AutoLoader qw(AUTOLOAD);

$VERSION = "2.56"; # $Id:$
@ISA     = qw(Exporter Net::Cmd IO::Socket::INET);

# Someday I will "use constant", when I am not bothered to much about
# compatability with older releases of perl

use vars qw($TELNET_IAC $TELNET_IP $TELNET_DM);
($TELNET_IAC,$TELNET_IP,$TELNET_DM) = (255,244,242);

# Name is too long for AutoLoad, it clashes with pasv_xfer
sub pasv_xfer_unique {
    my($sftp,$sfile,$dftp,$dfile) = @_;
    $sftp->pasv_xfer($sfile,$dftp,$dfile,1);
}

1;
# Having problems with AutoLoader
#__END__

sub new
{
 my $pkg  = shift;
 my $peer = shift;
 my %arg  = @_; 

 my $host = $peer;
 my $fire = undef;

 if(exists($arg{Firewall}) || Net::Config->requires_firewall($peer))
  {
   $fire = $arg{Firewall}
	|| $ENV{FTP_FIREWALL}
	|| $NetConfig{ftp_firewall}
	|| undef;

   if(defined $fire)
    {
     $peer = $fire;
     delete $arg{Port};
    }
  }

 my $ftp = $pkg->SUPER::new(PeerAddr => $peer, 
			    PeerPort => $arg{Port} || 'ftp(21)',
			    Proto    => 'tcp',
			    Timeout  => defined $arg{Timeout}
						? $arg{Timeout}
						: 120
			   ) or return undef;

 ${*$ftp}{'net_ftp_host'}     = $host;		# Remote hostname
 ${*$ftp}{'net_ftp_type'}     = 'A';		# ASCII/binary/etc mode
 ${*$ftp}{'net_ftp_blksize'}  = abs($arg{'BlockSize'} || 10240);

 ${*$ftp}{'net_ftp_firewall'} = $fire
	if(defined $fire);

 ${*$ftp}{'net_ftp_passive'} = int
	exists $arg{Passive}
	    ? $arg{Passive}
	    : exists $ENV{FTP_PASSIVE}
		? $ENV{FTP_PASSIVE}
		: defined $fire
		    ? $NetConfig{ftp_ext_passive}
		    : $NetConfig{ftp_int_passive};	# Whew! :-)

 $ftp->hash(exists $arg{Hash} ? $arg{Hash} : 0, 1024);

 $ftp->autoflush(1);

 $ftp->debug(exists $arg{Debug} ? $arg{Debug} : undef);

 unless ($ftp->response() == CMD_OK)
  {
   $ftp->close();
   $@ = $ftp->message;
   undef $ftp;
  }

 $ftp;
}

##
## User interface methods
##

sub hash {
    my $ftp = shift;		# self
    my $prev = ${*$ftp}{'net_ftp_hash'} || [\*STDERR, 0];

    unless(@_) {
      return $prev;
    }
    my($h,$b) = @_;
    if(@_ == 1) {
      unless($h) {
        delete ${*$ftp}{'net_ftp_hash'};
        return $prev;
      }
      elsif(ref($h)) {
        $b = 1024;
      }
      else {
        ($h,$b) = (\*STDERR,$h);
      }
    }
    select((select($h), $|=1)[0]);
    $b = 512 if $b < 512;
    ${*$ftp}{'net_ftp_hash'} = [$h, $b];
    $prev;
}        

sub quit
{
 my $ftp = shift;

 $ftp->_QUIT;
 $ftp->close;
}

sub DESTROY
{
 my $ftp = shift;
 defined(fileno($ftp)) && $ftp->quit
}

sub ascii  { shift->type('A',@_); }
sub binary { shift->type('I',@_); }

sub ebcdic
{
 carp "TYPE E is unsupported, shall default to I";
 shift->type('E',@_);
}

sub byte
{
 carp "TYPE L is unsupported, shall default to I";
 shift->type('L',@_);
}

# Allow the user to send a command directly, BE CAREFUL !!

sub quot
{ 
 my $ftp = shift;
 my $cmd = shift;

 $ftp->command( uc $cmd, @_);
 $ftp->response();
}

sub site
{
 my $ftp = shift;

 $ftp->command("SITE", @_);
 $ftp->response();
}

sub mdtm
{
 my $ftp  = shift;
 my $file = shift;

 # Server Y2K bug workaround
 #
 # sigh; some idiotic FTP servers use ("19%d",tm.tm_year) instead of 
 # ("%d",tm.tm_year+1900).  This results in an extra digit in the
 # string returned. To account for this we allow an optional extra
 # digit in the year. Then if the first two digits are 19 we use the
 # remainder, otherwise we subtract 1900 from the whole year.

 $ftp->_MDTM($file) && $ftp->message =~ /((\d\d)(\d\d\d?))(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)/
    ? timegm($8,$7,$6,$5,$4-1,$2 eq '19' ? $3 : ($1-1900))
    : undef;
}

sub size {
  my $ftp  = shift;
  my $file = shift;
  my $io;
  if($ftp->supported("SIZE")) {
    return $ftp->_SIZE($file)
	? ($ftp->message =~ /(\d+)/)[0]
	: undef;
 }
 elsif($ftp->supported("STAT")) {
   my @msg;
   return undef
       unless $ftp->_STAT($file) && (@msg = $ftp->message) == 3;
   my $line;
   foreach $line (@msg) {
     return (split(/\s+/,$line))[4]
	 if $line =~ /^[-rw]{10}/
   }
 }
 else {
   my @files = $ftp->dir($file);
   if(@files) {
     return (split(/\s+/,$1))[4]
	 if $files[0] =~ /^([-rw]{10}.*)$/;
   }
 }
 undef;
}

sub login {
  my($ftp,$user,$pass,$acct) = @_;
  my($ok,$ruser,$fwtype);

  unless (defined $user) {
    require Net::Netrc;

    my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_host'});

    ($user,$pass,$acct) = $rc->lpa()
	 if ($rc);
   }

  $user ||= "anonymous";
  $ruser = $user;

  $fwtype = $NetConfig{'ftp_firewall_type'} || 0;

  if ($fwtype && defined ${*$ftp}{'net_ftp_firewall'}) {
    if ($fwtype == 1 || $fwtype == 7) {
      $user .= '@' . ${*$ftp}{'net_ftp_host'};
    }
    else {
      require Net::Netrc;

      my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'});

      my($fwuser,$fwpass,$fwacct) = $rc ? $rc->lpa() : ();

      if ($fwtype == 5) {
	$user = join('@',$user,$fwuser,${*$ftp}{'net_ftp_host'});
	$pass = $pass . '@' . $fwpass;
      }
      else {
	if ($fwtype == 2) {
	  $user .= '@' . ${*$ftp}{'net_ftp_host'};
	}
	elsif ($fwtype == 6) {
	  $fwuser .= '@' . ${*$ftp}{'net_ftp_host'};
	}

	$ok = $ftp->_USER($fwuser);

	return 0 unless $ok == CMD_OK || $ok == CMD_MORE;

	$ok = $ftp->_PASS($fwpass || "");

	return 0 unless $ok == CMD_OK || $ok == CMD_MORE;

	$ok = $ftp->_ACCT($fwacct)
	  if defined($fwacct);

	if ($fwtype == 3) {
          $ok = $ftp->command("SITE",${*$ftp}{'net_ftp_host'})->response;
	}
	elsif ($fwtype == 4) {
          $ok = $ftp->command("OPEN",${*$ftp}{'net_ftp_host'})->response;
	}

	return 0 unless $ok == CMD_OK || $ok == CMD_MORE;
      }
    }
  }

  $ok = $ftp->_USER($user);

  # Some dumb firewalls don't prefix the connection messages
  $ok = $ftp->response()
	 if ($ok == CMD_OK && $ftp->code == 220 && $user =~ /\@/);

  if ($ok == CMD_MORE) {
    unless(defined $pass) {
      require Net::Netrc;

      my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_host'}, $ruser);

      ($ruser,$pass,$acct) = $rc->lpa()
	 if ($rc);

      $pass = "-" . (eval { (getpwuid($>))[0] } || $ENV{NAME} ) . '@'
         if (!defined $pass && (!defined($ruser) || $ruser =~ /^anonymous/o));
    }

    $ok = $ftp->_PASS($pass || "");
  }

  $ok = $ftp->_ACCT($acct)
	 if (defined($acct) && ($ok == CMD_MORE || $ok == CMD_OK));

  if ($fwtype == 7 && $ok == CMD_OK && defined ${*$ftp}{'net_ftp_firewall'}) {
    my($f,$auth,$resp) = _auth_id($ftp);
    $ftp->authorize($auth,$resp) if defined($resp);
  }

  $ok == CMD_OK;
}

sub account
{
 @_ == 2 or croak 'usage: $ftp->account( ACCT )';
 my $ftp = shift;
 my $acct = shift;
 $ftp->_ACCT($acct) == CMD_OK;
}

sub _auth_id {
 my($ftp,$auth,$resp) = @_;

 unless(defined $resp)
  {
   require Net::Netrc;

   $auth ||= eval { (getpwuid($>))[0] } || $ENV{NAME};

   my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'}, $auth)
        || Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'});

   ($auth,$resp) = $rc->lpa()
     if ($rc);
  }
  ($ftp,$auth,$resp);
}

sub authorize
{
 @_ >= 1 || @_ <= 3 or croak 'usage: $ftp->authorize( [AUTH [, RESP]])';

 my($ftp,$auth,$resp) = &_auth_id;

 my $ok = $ftp->_AUTH($auth || "");

 $ok = $ftp->_RESP($resp || "")
	if ($ok == CMD_MORE);

 $ok == CMD_OK;
}

sub rename
{
 @_ == 3 or croak 'usage: $ftp->rename(FROM, TO)';

 my($ftp,$from,$to) = @_;

 $ftp->_RNFR($from)
    && $ftp->_RNTO($to);
}

sub type
{
 my $ftp = shift;
 my $type = shift;
 my $oldval = ${*$ftp}{'net_ftp_type'};

 return $oldval
	unless (defined $type);

 return undef
	unless ($ftp->_TYPE($type,@_));

 ${*$ftp}{'net_ftp_type'} = join(" ",$type,@_);

 $oldval;
}

sub abort
{
 my $ftp = shift;

 send($ftp,pack("CCC", $TELNET_IAC, $TELNET_IP, $TELNET_IAC),MSG_OOB);

 $ftp->command(pack("C",$TELNET_DM) . "ABOR");
 
 ${*$ftp}{'net_ftp_dataconn'}->close()
    if defined ${*$ftp}{'net_ftp_dataconn'};

 $ftp->response();

 $ftp->status == CMD_OK;
}

sub get
{
 my($ftp,$remote,$local,$where) = @_;

 my($loc,$len,$buf,$resp,$localfd,$data);
 local *FD;

 $localfd = ref($local) || ref(\$local) eq "GLOB"
             ? fileno($local)
	     : undef;

 ($local = $remote) =~ s#^.*/##
	unless(defined $local);

 croak("Bad remote filename '$remote'\n")
	if $remote =~ /[\r\n]/s;

 ${*$ftp}{'net_ftp_rest'} = $where
	if ($where);

 delete ${*$ftp}{'net_ftp_port'};
 delete ${*$ftp}{'net_ftp_pasv'};

 $data = $ftp->retr($remote) or
	return undef;

 if(defined $localfd)
  {
   $loc = $local;
  }
 else
  {
   $loc = \*FD;

   unless(($where) ? open($loc,">>$local") : open($loc,">$local"))
    {
     carp "Cannot open Local file $local: $!\n";
     $data->abort;
     return undef;
    }
  }

 if($ftp->type eq 'I' && !binmode($loc))
  {
   carp "Cannot binmode Local file $local: $!\n";
   $data->abort;
   close($loc) unless $localfd;
   return undef;
  }

 $buf = '';
 my($count,$hashh,$hashb,$ref) = (0);

 ($hashh,$hashb) = @$ref
   if($ref = ${*$ftp}{'net_ftp_hash'});

 my $blksize = ${*$ftp}{'net_ftp_blksize'};

 while(1)
  {
   last unless $len = $data->read($buf,$blksize);
   if($hashh) {
    $count += $len;
    print $hashh "#" x (int($count / $hashb));
    $count %= $hashb;
   }
   my $written = syswrite($loc,$buf,$len);
   unless(defined($written) && $written == $len)
    {
     carp "Cannot write to Local file $local: $!\n";
     $data->abort;
     close($loc)
        unless defined $localfd;
     return undef;
    }
  }

 print $hashh "\n" if $hashh;

 close($loc)
	unless defined $localfd;
 
 $data->close(); # implied $ftp->response

 return $local;
}

sub cwd
{
 @_ == 1 || @_ == 2 or croak 'usage: $ftp->cwd( [ DIR ] )';

 my($ftp,$dir) = @_;

 $dir = "/" unless defined($dir) && $dir =~ /\S/;

 $dir eq ".."
    ? $ftp->_CDUP()
    : $ftp->_CWD($dir);
}

sub cdup
{
 @_ == 1 or croak 'usage: $ftp->cdup()';
 $_[0]->_CDUP;
}

sub pwd
{
 @_ == 1 || croak 'usage: $ftp->pwd()';
 my $ftp = shift;

 $ftp->_PWD();
 $ftp->_extract_path;
}

# rmdir( $ftp, $dir, [ $recurse ] )
#
# Removes $dir on remote host via FTP.
# $ftp is handle for remote host
#
# If $recurse is TRUE, the directory and deleted recursively.
# This means all of its contents and subdirectories.
#
# Initial version contributed by Dinkum Software
#
sub rmdir
{
    @_ == 2 || @_ == 3 or croak('usage: $ftp->rmdir( DIR [, RECURSE ] )');

    # Pick off the args
    my ($ftp, $dir, $recurse) = @_ ;
    my $ok;

    return $ok
	if $ftp->_RMD( $dir ) || !$recurse;

    # Try to delete the contents
    # Get a list of all the files in the directory
    my $filelist = $ftp->ls($dir);

    return undef
	unless $filelist && @$filelist; # failed, it is probably not a directory

    # Go thru and delete each file or the directory
    my $file;
    foreach $file (map { m,/, ? $_ : "$dir/$_" } @$filelist)
    {
	next  # successfully deleted the file
	    if $ftp->delete($file);

	# Failed to delete it, assume its a directory
	# Recurse and ignore errors, the final rmdir() will
	# fail on any errors here
	return $ok
	    unless $ok = $ftp->rmdir($file, 1) ;
    }

    # Directory should be empty
    # Try to remove the directory again
    # Pass results directly to caller
    # If any of the prior deletes failed, this
    # rmdir() will fail because directory is not empty
    return $ftp->_RMD($dir) ;
}

sub mkdir
{
 @_ == 2 || @_ == 3 or croak 'usage: $ftp->mkdir( DIR [, RECURSE ] )';

 my($ftp,$dir,$recurse) = @_;

 $ftp->_MKD($dir) || $recurse or
    return undef;

 my $path = $dir;

 unless($ftp->ok)
  {
   my @path = split(m#(?=/+)#, $dir);

   $path = "";

   while(@path)
    {
     $path .= shift @path;

     $ftp->_MKD($path);

     $path = $ftp->_extract_path($path);
    }

   # If the creation of the last element was not sucessful, see if we
   # can cd to it, if so then return path

   unless($ftp->ok)
    {
     my($status,$message) = ($ftp->status,$ftp->message);
     my $pwd = $ftp->pwd;
     
     if($pwd && $ftp->cwd($dir))
      {
       $path = $dir;
       $ftp->cwd($pwd);
      }
     else
      {
       undef $path;
      }
     $ftp->set_status($status,$message);
    }
  }

 $path;
}

sub delete
{
 @_ == 2 || croak 'usage: $ftp->delete( FILENAME )';

 $_[0]->_DELE($_[1]);
}

sub put        { shift->_store_cmd("stor",@_) }
sub put_unique { shift->_store_cmd("stou",@_) }
sub append     { shift->_store_cmd("appe",@_) }

sub nlst { shift->_data_cmd("NLST",@_) }
sub list { shift->_data_cmd("LIST",@_) }
sub retr { shift->_data_cmd("RETR",@_) }
sub stor { shift->_data_cmd("STOR",@_) }
sub stou { shift->_data_cmd("STOU",@_) }
sub appe { shift->_data_cmd("APPE",@_) }

sub _store_cmd 
{
 my($ftp,$cmd,$local,$remote) = @_;
 my($loc,$sock,$len,$buf,$localfd);
 local *FD;

 $localfd = ref($local) || ref(\$local) eq "GLOB"
             ? fileno($local)
	     : undef;

 unless(defined $remote)
  {
   croak 'Must specify remote filename with stream input'
	if defined $localfd;

   require File::Basename;
   $remote = File::Basename::basename($local);
  }

 croak("Bad remote filename '$remote'\n")
	if $remote =~ /[\r\n]/s;

 if(defined $localfd)
  {
   $loc = $local;
  }
 else
  {
   $loc = \*FD;

   unless(open($loc,"<$local"))
    {
     carp "Cannot open Local file $local: $!\n";
     return undef;
    }
  }

 if($ftp->type eq 'I' && !binmode($loc))
  {
   carp "Cannot binmode Local file $local: $!\n";
   return undef;
  }

 delete ${*$ftp}{'net_ftp_port'};
 delete ${*$ftp}{'net_ftp_pasv'};

 $sock = $ftp->_data_cmd($cmd, $remote) or 
	return undef;

 my $blksize = ${*$ftp}{'net_ftp_blksize'};

 my($count,$hashh,$hashb,$ref) = (0);

 ($hashh,$hashb) = @$ref
   if($ref = ${*$ftp}{'net_ftp_hash'});

 while(1)
  {
   last unless $len = sysread($loc,$buf="",$blksize);

   if($hashh) {
    $count += $len;
    print $hashh "#" x (int($count / $hashb));
    $count %= $hashb;
   }

   my $wlen;
   unless(defined($wlen = $sock->write($buf,$len)) && $wlen == $len)
    {
     $sock->abort;
     close($loc)
	unless defined $localfd;
     print $hashh "\n" if $hashh;
     return undef;
    }
  }

 print $hashh "\n" if $hashh;

 close($loc)
	unless defined $localfd;

 $sock->close() or
	return undef;

 ($remote) = $ftp->message =~ /unique file name:\s*(\S*)\s*\)/
	if ('STOU' eq uc $cmd);

 return $remote;
}

sub port
{
 @_ == 1 || @_ == 2 or croak 'usage: $ftp->port([PORT])';

 my($ftp,$port) = @_;
 my $ok;

 delete ${*$ftp}{'net_ftp_intern_port'};

 unless(defined $port)
  {
   # create a Listen socket at same address as the command socket

   ${*$ftp}{'net_ftp_listen'} ||= IO::Socket::INET->new(Listen    => 5,
				    	    	        Proto     => 'tcp',
				    	    	       );
  
   my $listen = ${*$ftp}{'net_ftp_listen'};

   my($myport, @myaddr) = ($listen->sockport, split(/\./,$ftp->sockhost));

   $port = join(',', @myaddr, $myport >> 8, $myport & 0xff);

   ${*$ftp}{'net_ftp_intern_port'} = 1;
  }

 $ok = $ftp->_PORT($port);

 ${*$ftp}{'net_ftp_port'} = $port;

 $ok;
}

sub ls  { shift->_list_cmd("NLST",@_); }
sub dir { shift->_list_cmd("LIST",@_); }

sub pasv
{
 @_ == 1 or croak 'usage: $ftp->pasv()';

 my $ftp = shift;

 delete ${*$ftp}{'net_ftp_intern_port'};

 $ftp->_PASV && $ftp->message =~ /(\d+(,\d+)+)/
    ? ${*$ftp}{'net_ftp_pasv'} = $1
    : undef;    
}

sub unique_name
{
 my $ftp = shift;
 ${*$ftp}{'net_ftp_unique'} || undef;
}

sub supported {
    @_ == 2 or croak 'usage: $ftp->supported( CMD )';
    my $ftp = shift;
    my $cmd = uc shift;
    my $hash = ${*$ftp}{'net_ftp_supported'} ||= {};

    return $hash->{$cmd}
        if exists $hash->{$cmd};

    return $hash->{$cmd} = 0
	unless $ftp->_HELP($cmd);

    my $text = $ftp->message;
    if($text =~ /following\s+commands/i) {
	$text =~ s/^.*\n//;
	$text =~ s/\n/ /sog;
	while($text =~ /(\w+)([* ])/g) {
	    $hash->{"\U$1"} = $2 eq " " ? 1 : 0;
	}
    }
    else {
	$hash->{$cmd} = $text !~ /unimplemented/i;
    }

    $hash->{$cmd} ||= 0;
}

##
## Deprecated methods
##

sub lsl
{
 carp "Use of Net::FTP::lsl deprecated, use 'dir'"
    if $^W;
 goto &dir;
}

sub authorise
{
 carp "Use of Net::FTP::authorise deprecated, use 'authorize'"
    if $^W;
 goto &authorize;
}


##
## Private methods
##

sub _extract_path
{
 my($ftp, $path) = @_;

 # This tries to work both with and without the quote doubling
 # convention (RFC 959 requires it, but the first 3 servers I checked
 # didn't implement it).  It will fail on a server which uses a quote in
 # the message which isn't a part of or surrounding the path.
 $ftp->ok &&
    $ftp->message =~ /(?:^|\s)\"(.*)\"(?:$|\s)/ &&
    ($path = $1) =~ s/\"\"/\"/g;

 $path;
}

##
## Communication methods
##

sub _dataconn
{
 my $ftp = shift;
 my $data = undef;
 my $pkg = "Net::FTP::" . $ftp->type;

 eval "require " . $pkg;

 $pkg =~ s/ /_/g;

 delete ${*$ftp}{'net_ftp_dataconn'};

 if(defined ${*$ftp}{'net_ftp_pasv'})
  {
   my @port = split(/,/,${*$ftp}{'net_ftp_pasv'});

   $data = $pkg->new(PeerAddr => join(".",@port[0..3]),
    	    	     PeerPort => $port[4] * 256 + $port[5],
    	    	     Proto    => 'tcp'
    	    	    );
  }
 elsif(defined ${*$ftp}{'net_ftp_listen'})
  {
   $data = ${*$ftp}{'net_ftp_listen'}->accept($pkg);
   close(delete ${*$ftp}{'net_ftp_listen'});
  }

 if($data)
  {
   ${*$data} = "";
   $data->timeout($ftp->timeout);
   ${*$ftp}{'net_ftp_dataconn'} = $data;
   ${*$data}{'net_ftp_cmd'} = $ftp;
   ${*$data}{'net_ftp_blksize'} = ${*$ftp}{'net_ftp_blksize'};
  }

 $data;
}

sub _list_cmd
{
 my $ftp = shift;
 my $cmd = uc shift;

 delete ${*$ftp}{'net_ftp_port'};
 delete ${*$ftp}{'net_ftp_pasv'};

 my $data = $ftp->_data_cmd($cmd,@_);

 return
	unless(defined $data);

 require Net::FTP::A;
 bless $data, "Net::FTP::A"; # Force ASCII mode

 my $databuf = '';
 my $buf = '';
 my $blksize = ${*$ftp}{'net_ftp_blksize'};

 while($data->read($databuf,$blksize)) {
   $buf .= $databuf;
 }

 my $list = [ split(/\n/,$buf) ];

 $data->close();

 wantarray ? @{$list}
           : $list;
}

sub _data_cmd
{
 my $ftp = shift;
 my $cmd = uc shift;
 my $ok = 1;
 my $where = delete ${*$ftp}{'net_ftp_rest'} || 0;
 my $arg;

 for $arg (@_) {
   croak("Bad argument '$arg'\n")
	if $arg =~ /[\r\n]/s;
 }

 if(${*$ftp}{'net_ftp_passive'} &&
     !defined ${*$ftp}{'net_ftp_pasv'} &&
     !defined ${*$ftp}{'net_ftp_port'})
  {
   my $data = undef;

   $ok = defined $ftp->pasv;
   $ok = $ftp->_REST($where)
	if $ok && $where;

   if($ok)
    {
     $ftp->command($cmd,@_);
     $data = $ftp->_dataconn();
     $ok = CMD_INFO == $ftp->response();
     if($ok) 
      {
       $data->reading
         if $data && $cmd =~ /RETR|LIST|NLST/;
       return $data
      }
     $data->_close
	if $data;
    }
   return undef;
  }

 $ok = $ftp->port
    unless (defined ${*$ftp}{'net_ftp_port'} ||
            defined ${*$ftp}{'net_ftp_pasv'});

 $ok = $ftp->_REST($where)
    if $ok && $where;

 return undef
    unless $ok;

 $ftp->command($cmd,@_);

 return 1
    if(defined ${*$ftp}{'net_ftp_pasv'});

 $ok = CMD_INFO == $ftp->response();

 return $ok 
    unless exists ${*$ftp}{'net_ftp_intern_port'};

 if($ok) {
   my $data = $ftp->_dataconn();

   $data->reading
         if $data && $cmd =~ /RETR|LIST|NLST/;

   return $data;
 }

 
 close(delete ${*$ftp}{'net_ftp_listen'});
 
 return undef;
}

##
## Over-ride methods (Net::Cmd)
##

sub debug_text { $_[2] =~ /^(pass|resp|acct)/i ? "$1 ....\n" : $_[2]; }

sub command
{
 my $ftp = shift;

 delete ${*$ftp}{'net_ftp_port'};
 $ftp->SUPER::command(@_);
}

sub response
{
 my $ftp = shift;
 my $code = $ftp->SUPER::response();

 delete ${*$ftp}{'net_ftp_pasv'}
    if ($code != CMD_MORE && $code != CMD_INFO);

 $code;
}

sub parse_response
{
 return ($1, $2 eq "-")
    if $_[1] =~ s/^(\d\d\d)(.?)//o;

 my $ftp = shift;

 # Darn MS FTP server is a load of CRAP !!!!
 return ()
	unless ${*$ftp}{'net_cmd_code'} + 0;

 (${*$ftp}{'net_cmd_code'},1);
}

##
## Allow 2 servers to talk directly
##

sub pasv_xfer {
    my($sftp,$sfile,$dftp,$dfile,$unique) = @_;

    ($dfile = $sfile) =~ s#.*/##
	unless(defined $dfile);

    my $port = $sftp->pasv or
	return undef;

    $dftp->port($port) or
	return undef;

    return undef
	unless($unique ? $dftp->stou($dfile) : $dftp->stor($dfile));

    unless($sftp->retr($sfile) && $sftp->response == CMD_INFO) {
	$sftp->retr($sfile);
	$dftp->abort;
	$dftp->response();
	return undef;
    }

    $dftp->pasv_wait($sftp);
}

sub pasv_wait
{
 @_ == 2 or croak 'usage: $ftp->pasv_wait(NON_PASV_FTP)';

 my($ftp, $non_pasv) = @_;
 my($file,$rin,$rout);

 vec($rin='',fileno($ftp),1) = 1;
 select($rout=$rin, undef, undef, undef);

 $ftp->response();
 $non_pasv->response();

 return undef
	unless $ftp->ok() && $non_pasv->ok();

 return $1
	if $ftp->message =~ /unique file name:\s*(\S*)\s*\)/;

 return $1
	if $non_pasv->message =~ /unique file name:\s*(\S*)\s*\)/;

 return 1;
}

sub cmd { shift->command(@_)->response() }

########################################
#
# RFC959 commands
#

sub _ABOR { shift->command("ABOR")->response()	 == CMD_OK }
sub _CDUP { shift->command("CDUP")->response()	 == CMD_OK }
sub _NOOP { shift->command("NOOP")->response()	 == CMD_OK }
sub _PASV { shift->command("PASV")->response()	 == CMD_OK }
sub _QUIT { shift->command("QUIT")->response()	 == CMD_OK }
sub _DELE { shift->command("DELE",@_)->response() == CMD_OK }
sub _CWD  { shift->command("CWD", @_)->response() == CMD_OK }
sub _PORT { shift->command("PORT",@_)->response() == CMD_OK }
sub _RMD  { shift->command("RMD", @_)->response() == CMD_OK }
sub _MKD  { shift->command("MKD", @_)->response() == CMD_OK }
sub _PWD  { shift->command("PWD", @_)->response() == CMD_OK }
sub _TYPE { shift->command("TYPE",@_)->response() == CMD_OK }
sub _RNTO { shift->command("RNTO",@_)->response() == CMD_OK }
sub _RESP { shift->command("RESP",@_)->response() == CMD_OK }
sub _MDTM { shift->command("MDTM",@_)->response() == CMD_OK }
sub _SIZE { shift->command("SIZE",@_)->response() == CMD_OK }
sub _HELP { shift->command("HELP",@_)->response() == CMD_OK }
sub _STAT { shift->command("STAT",@_)->response() == CMD_OK }
sub _APPE { shift->command("APPE",@_)->response() == CMD_INFO }
sub _LIST { shift->command("LIST",@_)->response() == CMD_INFO }
sub _NLST { shift->command("NLST",@_)->response() == CMD_INFO }
sub _RETR { shift->command("RETR",@_)->response() == CMD_INFO }
sub _STOR { shift->command("STOR",@_)->response() == CMD_INFO }
sub _STOU { shift->command("STOU",@_)->response() == CMD_INFO }
sub _RNFR { shift->command("RNFR",@_)->response() == CMD_MORE }
sub _REST { shift->command("REST",@_)->response() == CMD_MORE }
sub _USER { shift->command("user",@_)->response() } # A certain brain dead firewall :-)
sub _PASS { shift->command("PASS",@_)->response() }
sub _ACCT { shift->command("ACCT",@_)->response() }
sub _AUTH { shift->command("AUTH",@_)->response() }

sub _ALLO { shift->unsupported(@_) }
sub _SMNT { shift->unsupported(@_) }
sub _MODE { shift->unsupported(@_) }
sub _SYST { shift->unsupported(@_) }
sub _STRU { shift->unsupported(@_) }
sub _REIN { shift->unsupported(@_) }

1;

__END__

=head1 NAME

Net::FTP - FTP Client class

=head1 SYNOPSIS

    use Net::FTP;
    
    $ftp = Net::FTP->new("some.host.name", Debug => 0);
    $ftp->login("anonymous",'me@here.there');
    $ftp->cwd("/pub");
    $ftp->get("that.file");
    $ftp->quit;

=head1 DESCRIPTION

C<Net::FTP> is a class implementing a simple FTP client in Perl as
described in RFC959.  It provides wrappers for a subset of the RFC959
commands.

=head1 OVERVIEW

FTP stands for File Transfer Protocol.  It is a way of transferring
files between networked machines.  The protocol defines a client
(whose commands are provided by this module) and a server (not
implemented in this module).  Communication is always initiated by the
client, and the server responds with a message and a status code (and
sometimes with data).

The FTP protocol allows files to be sent to or fetched from the
server.  Each transfer involves a B<local file> (on the client) and a
B<remote file> (on the server).  In this module, the same file name
will be used for both local and remote if only one is specified.  This
means that transferring remote file C</path/to/file> will try to put
that file in C</path/to/file> locally, unless you specify a local file
name.

The protocol also defines several standard B<translations> which the
file can undergo during transfer.  These are ASCII, EBCDIC, binary,
and byte.  ASCII is the default type, and indicates that the sender of
files will translate the ends of lines to a standard representation
which the receiver will then translate back into their local
representation.  EBCDIC indicates the file being transferred is in
EBCDIC format.  Binary (also known as image) format sends the data as
a contiguous bit stream.  Byte format transfers the data as bytes, the
values of which remain the same regardless of differences in byte size
between the two machines (in theory - in practice you should only use
this if you really know what you're doing).

=head1 CONSTRUCTOR

=over 4

=item new (HOST [,OPTIONS])

This is the constructor for a new Net::FTP object. C<HOST> is the
name of the remote host to which a FTP connection is required.

C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
Possible options are:

B<Firewall> - The name of a machine which acts as a FTP firewall. This can be
overridden by an environment variable C<FTP_FIREWALL>. If specified, and the
given host cannot be directly connected to, then the
connection is made to the firewall machine and the string C<@hostname> is
appended to the login identifier. This kind of setup is also refered to
as a ftp proxy.

B<BlockSize> - This is the block size that Net::FTP will use when doing
transfers. (defaults to 10240)

B<Port> - The port number to connect to on the remote machine for the
FTP connection

B<Timeout> - Set a timeout value (defaults to 120)

B<Debug> - debug level (see the debug method in L<Net::Cmd>)

B<Passive> - If set to a non-zero value then all data transfers will be done
using passive mode. This is not usually required except for some I<dumb>
servers, and some firewall configurations. This can also be set by the
environment variable C<FTP_PASSIVE>.

B<Hash> - If TRUE, print hash marks (#) on STDERR every 1024 bytes.  This
simply invokes the C<hash()> method for you, so that hash marks are displayed
for all transfers.  You can, of course, call C<hash()> explicitly whenever
you'd like.

If the constructor fails undef will be returned and an error message will
be in $@

=back

=head1 METHODS

Unless otherwise stated all methods return either a I<true> or I<false>
value, with I<true> meaning that the operation was a success. When a method
states that it returns a value, failure will be returned as I<undef> or an
empty list.

=over 4

=item login ([LOGIN [,PASSWORD [, ACCOUNT] ] ])

Log into the remote FTP server with the given login information. If
no arguments are given then the C<Net::FTP> uses the C<Net::Netrc>
package to lookup the login information for the connected host.
If no information is found then a login of I<anonymous> is used.
If no password is given and the login is I<anonymous> then the users
Email address will be used for a password.

If the connection is via a firewall then the C<authorize> method will
be called with no arguments.

=item authorize ( [AUTH [, RESP]])

This is a protocol used by some firewall ftp proxies. It is used
to authorise the user to send data out.  If both arguments are not specified
then C<authorize> uses C<Net::Netrc> to do a lookup.

=item site (ARGS)

Send a SITE command to the remote server and wait for a response.

Returns most significant digit of the response code.

=item type (TYPE [, ARGS])

This method will send the TYPE command to the remote FTP server
to change the type of data transfer. The return value is the previous
value.

=item ascii ([ARGS]) binary([ARGS]) ebcdic([ARGS]) byte([ARGS])

Synonyms for C<type> with the first arguments set correctly

B<NOTE> ebcdic and byte are not fully supported.

=item rename ( OLDNAME, NEWNAME )

Rename a file on the remote FTP server from C<OLDNAME> to C<NEWNAME>. This
is done by sending the RNFR and RNTO commands.

=item delete ( FILENAME )

Send a request to the server to delete C<FILENAME>.

=item cwd ( [ DIR ] )

Attempt to change directory to the directory given in C<$dir>.  If
C<$dir> is C<"..">, the FTP C<CDUP> command is used to attempt to
move up one directory. If no directory is given then an attempt is made
to change the directory to the root directory.

=item cdup ()

Change directory to the parent of the current directory.

=item pwd ()

Returns the full pathname of the current directory.

=item rmdir ( DIR )

Remove the directory with the name C<DIR>.

=item mkdir ( DIR [, RECURSE ])

Create a new directory with the name C<DIR>. If C<RECURSE> is I<true> then
C<mkdir> will attempt to create all the directories in the given path.

Returns the full pathname to the new directory.

=item ls ( [ DIR ] )

Get a directory listing of C<DIR>, or the current directory.

In an array context, returns a list of lines returned from the server. In
a scalar context, returns a reference to a list.

=item dir ( [ DIR ] )

Get a directory listing of C<DIR>, or the current directory in long format.

In an array context, returns a list of lines returned from the server. In
a scalar context, returns a reference to a list.

=item get ( REMOTE_FILE [, LOCAL_FILE [, WHERE]] )

Get C<REMOTE_FILE> from the server and store locally. C<LOCAL_FILE> may be
a filename or a filehandle. If not specified the the file will be stored in
the current directory with the same leafname as the remote file.

If C<WHERE> is given then the first C<WHERE> bytes of the file will
not be transfered, and the remaining bytes will be appended to
the local file if it already exists.

Returns C<LOCAL_FILE>, or the generated local file name if C<LOCAL_FILE>
is not given.

=item put ( LOCAL_FILE [, REMOTE_FILE ] )

Put a file on the remote server. C<LOCAL_FILE> may be a name or a filehandle.
If C<LOCAL_FILE> is a filehandle then C<REMOTE_FILE> must be specified. If
C<REMOTE_FILE> is not specified then the file will be stored in the current
directory with the same leafname as C<LOCAL_FILE>.

Returns C<REMOTE_FILE>, or the generated remote filename if C<REMOTE_FILE>
is not given.

B<NOTE>: If for some reason the transfer does not complete and an error is
returned then the contents that had been transfered will not be remove
automatically.

=item put_unique ( LOCAL_FILE [, REMOTE_FILE ] )

Same as put but uses the C<STOU> command.

Returns the name of the file on the server.

=item append ( LOCAL_FILE [, REMOTE_FILE ] )

Same as put but appends to the file on the remote server.

Returns C<REMOTE_FILE>, or the generated remote filename if C<REMOTE_FILE>
is not given.

=item unique_name ()

Returns the name of the last file stored on the server using the
C<STOU> command.

=item mdtm ( FILE )

Returns the I<modification time> of the given file

=item size ( FILE )

Returns the size in bytes for the given file as stored on the remote server.

B<NOTE>: The size reported is the size of the stored file on the remote server.
If the file is subsequently transfered from the server in ASCII mode
and the remote server and local machine have different ideas about
"End Of Line" then the size of file on the local machine after transfer
may be different.

=item supported ( CMD )

Returns TRUE if the remote server supports the given command.

=item hash ( [FILEHANDLE_GLOB_REF],[ BYTES_PER_HASH_MARK] )

Called without parameters, or with the first argument false, hash marks
are suppressed.  If the first argument is true but not a reference to a 
file handle glob, then \*STDERR is used.  The second argument is the number
of bytes per hash mark printed, and defaults to 1024.  In all cases the
return value is a reference to an array of two:  the filehandle glob reference
and the bytes per hash mark.

=back

The following methods can return different results depending on
how they are called. If the user explicitly calls either
of the C<pasv> or C<port> methods then these methods will
return a I<true> or I<false> value. If the user does not
call either of these methods then the result will be a
reference to a C<Net::FTP::dataconn> based object.

=over 4

=item nlst ( [ DIR ] )

Send a C<NLST> command to the server, with an optional parameter.

=item list ( [ DIR ] )

Same as C<nlst> but using the C<LIST> command

=item retr ( FILE )

Begin the retrieval of a file called C<FILE> from the remote server.

=item stor ( FILE )

Tell the server that you wish to store a file. C<FILE> is the
name of the new file that should be created.

=item stou ( FILE )

Same as C<stor> but using the C<STOU> command. The name of the unique
file which was created on the server will be available via the C<unique_name>
method after the data connection has been closed.

=item appe ( FILE )

Tell the server that we want to append some data to the end of a file
called C<FILE>. If this file does not exist then create it.

=back

If for some reason you want to have complete control over the data connection,
this includes generating it and calling the C<response> method when required,
then the user can use these methods to do so.

However calling these methods only affects the use of the methods above that
can return a data connection. They have no effect on methods C<get>, C<put>,
C<put_unique> and those that do not require data connections.

=over 4

=item port ( [ PORT ] )

Send a C<PORT> command to the server. If C<PORT> is specified then it is sent
to the server. If not the a listen socket is created and the correct information
sent to the server.

=item pasv ()

Tell the server to go into passive mode. Returns the text that represents the
port on which the server is listening, this text is in a suitable form to
sent to another ftp server using the C<port> method.

=back

The following methods can be used to transfer files between two remote
servers, providing that these two servers can connect directly to each other.

=over 4

=item pasv_xfer ( SRC_FILE, DEST_SERVER [, DEST_FILE ] )

This method will do a file transfer between two remote ftp servers. If
C<DEST_FILE> is omitted then the leaf name of C<SRC_FILE> will be used.

=item pasv_xfer_unique ( SRC_FILE, DEST_SERVER [, DEST_FILE ] )

Like C<pasv_xfer> but the file is stored on the remote server using
the STOU command.

=item pasv_wait ( NON_PASV_SERVER )

This method can be used to wait for a transfer to complete between a passive
server and a non-passive server. The method should be called on the passive
server with the C<Net::FTP> object for the non-passive server passed as an
argument.

=item abort ()

Abort the current data transfer.

=item quit ()

Send the QUIT command to the remote FTP server and close the socket connection.

=back

=head2 Methods for the adventurous

C<Net::FTP> inherits from C<Net::Cmd> so methods defined in C<Net::Cmd> may
be used to send commands to the remote FTP server.

=over 4

=item quot (CMD [,ARGS])

Send a command, that Net::FTP does not directly support, to the remote
server and wait for a response.

Returns most significant digit of the response code.

B<WARNING> This call should only be used on commands that do not require
data connections. Misuse of this method can hang the connection.

=back

=head1 THE dataconn CLASS

Some of the methods defined in C<Net::FTP> return an object which will
be derived from this class.The dataconn class itself is derived from
the C<IO::Socket::INET> class, so any normal IO operations can be performed.
However the following methods are defined in the dataconn class and IO should
be performed using these.

=over 4

=item read ( BUFFER, SIZE [, TIMEOUT ] )

Read C<SIZE> bytes of data from the server and place it into C<BUFFER>, also
performing any <CRLF> translation necessary. C<TIMEOUT> is optional, if not
given the the timeout value from the command connection will be used.

Returns the number of bytes read before any <CRLF> translation.

=item write ( BUFFER, SIZE [, TIMEOUT ] )

Write C<SIZE> bytes of data from C<BUFFER> to the server, also
performing any <CRLF> translation necessary. C<TIMEOUT> is optional, if not
given the the timeout value from the command connection will be used.

Returns the number of bytes written before any <CRLF> translation.

=item abort ()

Abort the current data transfer.

=item close ()

Close the data connection and get a response from the FTP server. Returns
I<true> if the connection was closed successfully and the first digit of
the response from the server was a '2'.

=back

=head1 UNIMPLEMENTED

The following RFC959 commands have not been implemented:

=over 4

=item B<ALLO>

Allocates storage for the file to be transferred.

=item B<SMNT>

Mount a different file system structure without changing login or
accounting information.

=item B<HELP>

Ask the server for "helpful information" (that's what the RFC says) on
the commands it accepts.

=item B<MODE>

Specifies transfer mode (stream, block or compressed) for file to be
transferred.

=item B<SYST>

Request remote server system identification.

=item B<STAT>

Request remote server status.

=item B<STRU>

Specifies file structure for file to be transferred.

=item B<REIN>

Reinitialize the connection, flushing all I/O and account information.

=back

=head1 REPORTING BUGS

When reporting bugs/problems please include as much information as possible.
It may be difficult for me to reproduce the problem as almost every setup
is different.

A small script which yields the problem will probably be of help. It would
also be useful if this script was run with the extra options C<Debug => 1>
passed to the constructor, and the output sent with the bug report. If you
cannot include a small script then please include a Debug trace from a
run of your program which does yield the problem.

=head1 AUTHOR

Graham Barr <gbarr@pobox.com>

=head1 SEE ALSO

L<Net::Netrc>
L<Net::Cmd>

ftp(1), ftpd(8), RFC 959
http://www.cis.ohio-state.edu/htbin/rfc/rfc959.html

=head1 CREDITS

Henry Gabryjelski <henryg@WPI.EDU> - for the suggestion of creating directories
recursively.

Nathan Torkington <gnat@frii.com> - for some input on the documentation.

Roderick Schertler <roderick@gate.net> - for various inputs

=head1 COPYRIGHT

Copyright (c) 1995-1998 Graham Barr. All rights reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut
WFTP_FILE_END: www_ftp/Net/FTP.pm
WFTP_FILE_START: www_ftp/Net/Netrc.pm
# Net::Netrc.pm
#
# Copyright (c) 1995-1998 Graham Barr <gbarr@pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.

package Net::Netrc;

use Carp;
use strict;
use FileHandle;
use vars qw($VERSION);

$VERSION = "2.10"; # $Id: //depot/libnet/Net/Netrc.pm#4$

my %netrc = ();

sub _readrc
{
 my $host = shift;
 my($home,$file);
 
 if($^O eq "MacOS") {
   $home = $ENV{HOME} || `pwd`;
   chomp($home);
   $file = ($home =~ /:$/ ? $home . "netrc" : $home . ":netrc");
 } else {
   # Some OS's don't have `getpwuid', so we default to $ENV{HOME}
   $home = eval { (getpwuid($>))[7] } || $ENV{HOME};
   $file = $home . "/.netrc";
 }

 my($login,$pass,$acct) = (undef,undef,undef);
 my $fh;
 local $_;

 $netrc{default} = undef;

 # OS/2 and Win32 do not handle stat in a way compatable with this check :-(
 unless($^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'MacOS')
  { 
   my @stat = stat($file);

   if(@stat)
    {
     if($stat[2] & 077)
      {
       carp "Bad permissions: $file";
       return;
      }
     if($stat[4] != $<)
      {
       carp "Not owner: $file";
       return;
      }
    }
  }

 if($fh = FileHandle->new($file,"r"))
  {
   my($mach,$macdef,$tok,@tok) = (0,0);

   while(<$fh>)
    {
     undef $macdef if /\A\n\Z/;

     if($macdef)
      {
       push(@$macdef,$_);
       next;
      }

     s/^\s*//;
     chomp;
     push(@tok, $+)
       while(length && s/^("([^"]*)"|(\S+))\s*//);

TOKEN:
     while(@tok)
      {
       if($tok[0] eq "default")
        {
         shift(@tok);
         $mach = bless {};
   	 $netrc{default} = [$mach];

         next TOKEN;
        }

       last TOKEN
            unless @tok > 1;

       $tok = shift(@tok);

       if($tok eq "machine")
        {
         my $host = shift @tok;
         $mach = bless {machine => $host};

         $netrc{$host} = []
            unless exists($netrc{$host});
         push(@{$netrc{$host}}, $mach);
        }
       elsif($tok =~ /^(login|password|account)$/)
        {
         next TOKEN unless $mach;
         my $value = shift @tok;
         # Following line added by rmerrell to remove '/' escape char in .netrc
         $value =~ s/\/\\/\\/g;
         $mach->{$1} = $value;
        }
       elsif($tok eq "macdef")
        {
         next TOKEN unless $mach;
         my $value = shift @tok;
         $mach->{macdef} = {}
            unless exists $mach->{macdef};
         $macdef = $mach->{machdef}{$value} = [];
        }
      }
    }
   $fh->close();
  }
}

sub lookup
{
 my($pkg,$mach,$login) = @_;

 _readrc()
    unless exists $netrc{default};

 $mach ||= 'default';
 undef $login
    if $mach eq 'default';

 if(exists $netrc{$mach})
  {
   if(defined $login)
    {
     my $m;
     foreach $m (@{$netrc{$mach}})
      {
       return $m
            if(exists $m->{login} && $m->{login} eq $login);
      }
     return undef;
    }
   return $netrc{$mach}->[0]
  }

 return $netrc{default}->[0]
    if defined $netrc{default};

 return undef;
}

sub login
{
 my $me = shift;

 exists $me->{login}
    ? $me->{login}
    : undef;
}

sub account
{
 my $me = shift;

 exists $me->{account}
    ? $me->{account}
    : undef;
}

sub password
{
 my $me = shift;

 exists $me->{password}
    ? $me->{password}
    : undef;
}

sub lpa
{
 my $me = shift;
 ($me->login, $me->password, $me->account);
}

1;

__END__

=head1 NAME

Net::Netrc - OO interface to users netrc file

=head1 SYNOPSIS

    use Net::Netrc;
    
    $mach = Net::Netrc->lookup('some.machine');
    $login = $mach->login;
    ($login, $password, $account) = $mach->lpa;

=head1 DESCRIPTION

C<Net::Netrc> is a class implementing a simple interface to the .netrc file
used as by the ftp program.

C<Net::Netrc> also implements security checks just like the ftp program,
these checks are, first that the .netrc file must be owned by the user and 
second the ownership permissions should be such that only the owner has
read and write access. If these conditions are not met then a warning is
output and the .netrc file is not read.

=head1 THE .netrc FILE

The .netrc file contains login and initialization information used by the
auto-login process.  It resides in the user's home directory.  The following
tokens are recognized; they may be separated by spaces, tabs, or new-lines:

=over 4

=item machine name

Identify a remote machine name. The auto-login process searches
the .netrc file for a machine token that matches the remote machine
specified.  Once a match is made, the subsequent .netrc tokens
are processed, stopping when the end of file is reached or an-
other machine or a default token is encountered.

=item default

This is the same as machine name except that default matches
any name.  There can be only one default token, and it must be
after all machine tokens.  This is normally used as:

    default login anonymous password user@site

thereby giving the user automatic anonymous login to machines
not specified in .netrc.

=item login name

Identify a user on the remote machine.  If this token is present,
the auto-login process will initiate a login using the
specified name.

=item password string

Supply a password.  If this token is present, the auto-login
process will supply the specified string if the remote server
requires a password as part of the login process.

=item account string

Supply an additional account password.  If this token is present,
the auto-login process will supply the specified string
if the remote server requires an additional account password.

=item macdef name

Define a macro. C<Net::Netrc> only parses this field to be compatible
with I<ftp>.

=back

=head1 CONSTRUCTOR

The constructor for a C<Net::Netrc> object is not called new as it does not
really create a new object. But instead is called C<lookup> as this is
essentially what it does.

=over 4

=item lookup ( MACHINE [, LOGIN ])

Lookup and return a reference to the entry for C<MACHINE>. If C<LOGIN> is given
then the entry returned will have the given login. If C<LOGIN> is not given then
the first entry in the .netrc file for C<MACHINE> will be returned.

If a matching entry cannot be found, and a default entry exists, then a
reference to the default entry is returned.

=back

=head1 METHODS

=over 4

=item login ()

Return the login id for the netrc entry

=item password ()

Return the password for the netrc entry

=item account ()

Return the account information for the netrc entry

=item lpa ()

Return a list of login, password and account information fir the netrc entry

=back

=head1 AUTHOR

Graham Barr <gbarr@pobox.com>

=head1 SEE ALSO

L<Net::Netrc>
L<Net::Cmd>

=head1 COPYRIGHT

Copyright (c) 1995-1998 Graham Barr. All rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut
WFTP_FILE_END: www_ftp/Net/Netrc.pm
WFTP_FILE_START: www_ftp/Net/NNTP.pm
# Net::NNTP.pm
#
# Copyright (c) 1995-1997 Graham Barr <gbarr@pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.

package Net::NNTP;

use strict;
use vars qw(@ISA $VERSION $debug);
use IO::Socket;
use Net::Cmd;
use Carp;
use Time::Local;
use Net::Config;

$VERSION = "2.19"; # $Id: //depot/libnet/Net/NNTP.pm#8$
@ISA     = qw(Net::Cmd IO::Socket::INET);

sub new
{
 my $self = shift;
 my $type = ref($self) || $self;
 my $host = shift if @_ % 2;
 my %arg  = @_;
 my $obj;

 $host ||= $ENV{NNTPSERVER} || $ENV{NEWSHOST};

 my $hosts = defined $host ? [ $host ] : $NetConfig{nntp_hosts};

 @{$hosts} = qw(news)
	unless @{$hosts};

 my $h;
 foreach $h (@{$hosts})
  {
   $obj = $type->SUPER::new(PeerAddr => ($host = $h), 
			    PeerPort => $arg{Port} || 'nntp(119)',
			    Proto    => 'tcp',
			    Timeout  => defined $arg{Timeout}
						? $arg{Timeout}
						: 120
			   ) and last;
  }

 return undef
	unless defined $obj;

 ${*$obj}{'net_nntp_host'} = $host;

 $obj->autoflush(1);
 $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef);

 unless ($obj->response() == CMD_OK)
  {
   $obj->close;
   return undef;
  }

 my $c = $obj->code;
 my @m = $obj->message;
 
 unless(exists $arg{Reader} && $arg{Reader} == 0) {
   # if server is INN and we have transfer rights the we are currently
   # talking to innd not nnrpd
   if($obj->reader)
    {
     # If reader suceeds the we need to consider this code to determine postok
     $c = $obj->code;
    }
   else
    {
     # I want to ignore this failure, so restore the previous status.
     $obj->set_status($c,\@m);
    }
 }

 ${*$obj}{'net_nntp_post'} = $c == 200 ? 1 : 0;

 $obj;
}

sub debug_text
{
 my $nntp = shift;
 my $inout = shift;
 my $text = shift;

 if(($nntp->code == 350 && $text =~ /^(\S+)/)
    || ($text =~ /^(authinfo\s+pass)/io)) 
  {
   $text = "$1 ....\n"
  }

 $text;
}

sub postok
{
 @_ == 1 or croak 'usage: $nntp->postok()';
 my $nntp = shift;
 ${*$nntp}{'net_nntp_post'} || 0;
}

sub article
{
 @_ >= 1 && @_ <= 3 or croak 'usage: $nntp->article( [ MSGID ], [ FH ] )';
 my $nntp = shift;
 my @fh;

 @fh = (pop) if @_ == 2 || (@_ && ref($_[0]) || ref(\$_[0]) eq 'GLOB');

 $nntp->_ARTICLE(@_)
    ? $nntp->read_until_dot(@fh)
    : undef;
}

sub authinfo
{
 @_ == 3 or croak 'usage: $nntp->authinfo( USER, PASS )';
 my($nntp,$user,$pass) = @_;

 $nntp->_AUTHINFO("USER",$user) == CMD_MORE 
    && $nntp->_AUTHINFO("PASS",$pass) == CMD_OK;
}

sub authinfo_simple
{
 @_ == 3 or croak 'usage: $nntp->authinfo( USER, PASS )';
 my($nntp,$user,$pass) = @_;

 $nntp->_AUTHINFO('SIMPLE') == CMD_MORE 
    && $nntp->command($user,$pass)->response == CMD_OK;
}

sub body
{
 @_ >= 1 && @_ <= 3 or croak 'usage: $nntp->body( [ MSGID ], [ FH ] )';
 my $nntp = shift;
 my @fh;

 @fh = (pop) if @_ == 2 || (@_ && ref($_[0]) || ref(\$_[0]) eq 'GLOB');

 $nntp->_BODY(@_)
    ? $nntp->read_until_dot(@fh)
    : undef;
}

sub head
{
 @_ >= 1 && @_ <= 3 or croak 'usage: $nntp->head( [ MSGID ], [ FH ] )';
 my $nntp = shift;
 my @fh;

 @fh = (pop) if @_ == 2 || (@_ && ref($_[0]) || ref(\$_[0]) eq 'GLOB');

 $nntp->_HEAD(@_)
    ? $nntp->read_until_dot(@fh)
    : undef;
}

sub nntpstat
{
 @_ == 1 || @_ == 2 or croak 'usage: $nntp->nntpstat( [ MSGID ] )';
 my $nntp = shift;

 $nntp->_STAT(@_) && $nntp->message =~ /(<[^>]+>)/o
    ? $1
    : undef;
}


sub group
{
 @_ == 1 || @_ == 2 or croak 'usage: $nntp->group( [ GROUP ] )';
 my $nntp = shift;
 my $grp = ${*$nntp}{'net_nntp_group'} || undef;

 return $grp
    unless(@_ || wantarray);

 my $newgrp = shift;

 return wantarray ? () : undef
	unless $nntp->_GROUP($newgrp || $grp || "")
		&& $nntp->message =~ /(\d+)\s+(\d+)\s+(\d+)\s+(\S+)/;

 my($count,$first,$last,$group) = ($1,$2,$3,$4);

 # group may be replied as '(current group)'
 $group = ${*$nntp}{'net_nntp_group'}
    if $group =~ /\(/;

 ${*$nntp}{'net_nntp_group'} = $group;

 wantarray
    ? ($count,$first,$last,$group)
    : $group;
}

sub help
{
 @_ == 1 or croak 'usage: $nntp->help()';
 my $nntp = shift;

 $nntp->_HELP
    ? $nntp->read_until_dot
    : undef;
}

sub ihave
{
 @_ >= 2 or croak 'usage: $nntp->ihave( MESSAGE-ID [, MESSAGE ])';
 my $nntp = shift;
 my $mid = shift;

 $nntp->_IHAVE($mid) && $nntp->datasend(@_)
    ? @_ == 0 || $nntp->dataend
    : undef;
}

sub last
{
 @_ == 1 or croak 'usage: $nntp->last()';
 my $nntp = shift;

 $nntp->_LAST && $nntp->message =~ /(<[^>]+>)/o
    ? $1
    : undef;
}

sub list
{
 @_ == 1 or croak 'usage: $nntp->list()';
 my $nntp = shift;

 $nntp->_LIST
    ? $nntp->_grouplist
    : undef;
}

sub newgroups
{
 @_ >= 2 or croak 'usage: $nntp->newgroups( SINCE [, DISTRIBUTIONS ])';
 my $nntp = shift;
 my $time = _timestr(shift);
 my $dist = shift || "";

 $dist = join(",", @{$dist})
    if ref($dist);

 $nntp->_NEWGROUPS($time,$dist)
    ? $nntp->_grouplist
    : undef;
}

sub newnews
{
 @_ >= 2 && @_ <= 4 or
	croak 'usage: $nntp->newnews( SINCE [, GROUPS [, DISTRIBUTIONS ]])';
 my $nntp = shift;
 my $time = _timestr(shift);
 my $grp  = @_ ? shift : $nntp->group;
 my $dist = shift || "";

 $grp ||= "*";
 $grp = join(",", @{$grp})
    if ref($grp);

 $dist = join(",", @{$dist})
    if ref($dist);

 $nntp->_NEWNEWS($grp,$time,$dist)
    ? $nntp->_articlelist
    : undef;
}

sub next
{
 @_ == 1 or croak 'usage: $nntp->next()';
 my $nntp = shift;

 $nntp->_NEXT && $nntp->message =~ /(<[^>]+>)/o
    ? $1
    : undef;
}

sub post
{
 @_ >= 1 or croak 'usage: $nntp->post( [ MESSAGE ] )';
 my $nntp = shift;

 $nntp->_POST() && $nntp->datasend(@_)
    ? @_ == 0 || $nntp->dataend
    : undef;
}

sub quit
{
 @_ == 1 or croak 'usage: $nntp->quit()';
 my $nntp = shift;

 $nntp->_QUIT;
 $nntp->close;
}

sub slave
{
 @_ == 1 or croak 'usage: $nntp->slave()';
 my $nntp = shift;

 $nntp->_SLAVE;
}

##
## The following methods are not implemented by all servers
##

sub active
{
 @_ == 1 || @_ == 2 or croak 'usage: $nntp->active( [ PATTERN ] )';
 my $nntp = shift;

 $nntp->_LIST('ACTIVE',@_)
    ? $nntp->_grouplist
    : undef;
}

sub active_times
{
 @_ == 1 or croak 'usage: $nntp->active_times()';
 my $nntp = shift;

 $nntp->_LIST('ACTIVE.TIMES')
    ? $nntp->_grouplist
    : undef;
}

sub distributions
{
 @_ == 1 or croak 'usage: $nntp->distributions()';
 my $nntp = shift;

 $nntp->_LIST('DISTRIBUTIONS')
    ? $nntp->_description
    : undef;
}

sub distribution_patterns
{
 @_ == 1 or croak 'usage: $nntp->distributions()';
 my $nntp = shift;

 my $arr;
 local $_;

 $nntp->_LIST('DISTRIB.PATS') && ($arr = $nntp->read_until_dot)
    ? [grep { /^\d/ && (chomp, $_ = [ split /:/ ]) } @$arr]
    : undef;
}

sub newsgroups
{
 @_ == 1 || @_ == 2 or croak 'usage: $nntp->newsgroups( [ PATTERN ] )';
 my $nntp = shift;

 $nntp->_LIST('NEWSGROUPS',@_)
    ? $nntp->_description
    : undef;
}

sub overview_fmt
{
 @_ == 1 or croak 'usage: $nntp->overview_fmt()';
 my $nntp = shift;

 $nntp->_LIST('OVERVIEW.FMT')
     ? $nntp->_articlelist
     : undef;
}

sub subscriptions
{
 @_ == 1 or croak 'usage: $nntp->subscriptions()';
 my $nntp = shift;

 $nntp->_LIST('SUBSCRIPTIONS')
    ? $nntp->_articlelist
    : undef;
}

sub listgroup
{
 @_ == 1 || @_ == 2 or croak 'usage: $nntp->listgroup( [ GROUP ] )';
 my $nntp = shift;

 $nntp->_LISTGROUP(@_)
    ? $nntp->_articlelist
    : undef;
}

sub reader
{
 @_ == 1 or croak 'usage: $nntp->reader()';
 my $nntp = shift;

 $nntp->_MODE('READER');
}

sub xgtitle
{
 @_ == 1 || @_ == 2 or croak 'usage: $nntp->xgtitle( [ PATTERN ] )';
 my $nntp = shift;

 $nntp->_XGTITLE(@_)
    ? $nntp->_description
    : undef;
}

sub xhdr
{
 @_ >= 2 && @_ <= 4 or croak 'usage: $nntp->xhdr( HEADER, [ MESSAGE-SPEC ] )';
 my $nntp = shift;
 my $hdr = shift;
 my $arg = _msg_arg(@_);

 $nntp->_XHDR($hdr, $arg)
	? $nntp->_description
	: undef;
}

sub xover
{
 @_ == 2 || @_ == 3 or croak 'usage: $nntp->xover( MESSAGE-SPEC )';
 my $nntp = shift;
 my $arg = _msg_arg(@_);

 $nntp->_XOVER($arg)
	? $nntp->_fieldlist
	: undef;
}

sub xpat
{
 @_ == 4 || @_ == 5 or croak '$nntp->xpat( HEADER, PATTERN, MESSAGE-SPEC )';
 my $nntp = shift;
 my $hdr = shift;
 my $pat = shift;
 my $arg = _msg_arg(@_);

 $pat = join(" ", @$pat)
    if ref($pat);

 $nntp->_XPAT($hdr,$arg,$pat)
	? $nntp->_description
	: undef;
}

sub xpath
{
 @_ == 2 or croak 'usage: $nntp->xpath( MESSAGE-ID )';
 my($nntp,$mid) = @_;

 return undef
	unless $nntp->_XPATH($mid);

 my $m; ($m = $nntp->message) =~ s/^\d+\s+//o;
 my @p = split /\s+/, $m;

 wantarray ? @p : $p[0];
}

sub xrover
{
 @_ == 2 || @_ == 3 or croak 'usage: $nntp->xrover( MESSAGE-SPEC )';
 my $nntp = shift;
 my $arg = _msg_arg(@_);

 $nntp->_XROVER($arg)
	? $nntp->_description
	: undef;
}

sub date
{
 @_ == 1 or croak 'usage: $nntp->date()';
 my $nntp = shift;

 $nntp->_DATE && $nntp->message =~ /(\d{4})(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)/
    ? timegm($6,$5,$4,$3,$2-1,$1 - 1900)
    : undef;
}


##
## Private subroutines
##

sub _msg_arg
{
 my $spec = shift;
 my $arg = "";

 if(@_)
  {
   carp "Depriciated passing of two message numbers, "
      . "pass a reference"
	if $^W;
   $spec = [ $spec, $_[0] ];
  }

 if(defined $spec)
  {
   if(ref($spec))
    {
     $arg = $spec->[0] . "-";
     $arg .= $spec->[1]
	if defined $spec->[1] && $spec->[1] > $spec->[0];
    }
   else
    {
     $arg = $spec;
    }
  }

 $arg;
}

sub _timestr
{
 my $time = shift;
 my @g = reverse((gmtime($time))[0..5]);
 $g[1] += 1;
 $g[0] %= 100;
 sprintf "%02d%02d%02d %02d%02d%02d GMT", @g;
}

sub _grouplist
{
 my $nntp = shift;
 my $arr = $nntp->read_until_dot or
    return undef;

 my $hash = {};
 my $ln;

 foreach $ln (@$arr)
  {
   my @a = split(/[\s\n]+/,$ln);
   $hash->{$a[0]} = [ @a[1,2,3] ];
  }

 $hash;
}

sub _fieldlist
{
 my $nntp = shift;
 my $arr = $nntp->read_until_dot or
    return undef;

 my $hash = {};
 my $ln;

 foreach $ln (@$arr)
  {
   my @a = split(/[\t\n]/,$ln);
   my $m = shift @a;
   $hash->{$m} = [ @a ];
  }

 $hash;
}

sub _articlelist
{
 my $nntp = shift;
 my $arr = $nntp->read_until_dot;

 chomp(@$arr)
    if $arr;

 $arr;
}

sub _description
{
 my $nntp = shift;
 my $arr = $nntp->read_until_dot or
    return undef;

 my $hash = {};
 my $ln;

 foreach $ln (@$arr)
  {
   chomp($ln);

   $hash->{$1} = $ln
    if $ln =~ s/^\s*(\S+)\s*//o;
  }

 $hash;

}

##
## The commands
##

sub _ARTICLE   { shift->command('ARTICLE',@_)->response == CMD_OK }
sub _AUTHINFO  { shift->command('AUTHINFO',@_)->response }
sub _BODY      { shift->command('BODY',@_)->response == CMD_OK }
sub _DATE      { shift->command('DATE')->response == CMD_INFO }
sub _GROUP     { shift->command('GROUP',@_)->response == CMD_OK }
sub _HEAD      { shift->command('HEAD',@_)->response == CMD_OK }
sub _HELP      { shift->command('HELP',@_)->response == CMD_INFO }
sub _IHAVE     { shift->command('IHAVE',@_)->response == CMD_MORE }
sub _LAST      { shift->command('LAST')->response == CMD_OK }
sub _LIST      { shift->command('LIST',@_)->response == CMD_OK }
sub _LISTGROUP { shift->command('LISTGROUP',@_)->response == CMD_OK }
sub _NEWGROUPS { shift->command('NEWGROUPS',@_)->response == CMD_OK }
sub _NEWNEWS   { shift->command('NEWNEWS',@_)->response == CMD_OK }
sub _NEXT      { shift->command('NEXT')->response == CMD_OK }
sub _POST      { shift->command('POST',@_)->response == CMD_MORE }
sub _QUIT      { shift->command('QUIT',@_)->response == CMD_OK }
sub _SLAVE     { shift->command('SLAVE',@_)->response == CMD_OK }
sub _STAT      { shift->command('STAT',@_)->response == CMD_OK }
sub _MODE      { shift->command('MODE',@_)->response == CMD_OK }
sub _XGTITLE   { shift->command('XGTITLE',@_)->response == CMD_OK }
sub _XHDR      { shift->command('XHDR',@_)->response == CMD_OK }
sub _XPAT      { shift->command('XPAT',@_)->response == CMD_OK }
sub _XPATH     { shift->command('XPATH',@_)->response == CMD_OK }
sub _XOVER     { shift->command('XOVER',@_)->response == CMD_OK }
sub _XROVER    { shift->command('XROVER',@_)->response == CMD_OK }
sub _XTHREAD   { shift->unsupported }
sub _XSEARCH   { shift->unsupported }
sub _XINDEX    { shift->unsupported }

##
## IO/perl methods
##

sub DESTROY
{
 my $nntp = shift;
 defined(fileno($nntp)) && $nntp->quit
}


1;

__END__

=head1 NAME

Net::NNTP - NNTP Client class

=head1 SYNOPSIS

    use Net::NNTP;
    
    $nntp = Net::NNTP->new("some.host.name");
    $nntp->quit;

=head1 DESCRIPTION

C<Net::NNTP> is a class implementing a simple NNTP client in Perl as described
in RFC977. C<Net::NNTP> inherits its communication methods from C<Net::Cmd>

=head1 CONSTRUCTOR

=over 4

=item new ( [ HOST ] [, OPTIONS ])

This is the constructor for a new Net::NNTP object. C<HOST> is the
name of the remote host to which a NNTP connection is required. If not
given two environment variables are checked, first C<NNTPSERVER> then
C<NEWSHOST>, then C<Net::Config> is checked, and if a host is not found
then C<news> is used.

C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
Possible options are:

B<Timeout> - Maximum time, in seconds, to wait for a response from the
NNTP server, a value of zero will cause all IO operations to block.
(default: 120)

B<Debug> - Enable the printing of debugging information to STDERR

B<Reader> - If the remote server is INN then initially the connection
will be to nnrpd, by default C<Net::NNTP> will issue a C<MODE READER> command
so that the remote server becomes innd. If the C<Reader> option is given
with a value of zero, then this command will not be sent and the
connection will be left talking to nnrpd.

=back

=head1 METHODS

Unless otherwise stated all methods return either a I<true> or I<false>
value, with I<true> meaning that the operation was a success. When a method
states that it returns a value, failure will be returned as I<undef> or an
empty list.

=over 4

=item article ( [ MSGID|MSGNUM ], [FH] )

Retrieve the header, a blank line, then the body (text) of the
specified article. 

If C<FH> is specified then it is expected to be a valid filehandle
and the result will be printed to it, on sucess a true value will be
returned. If C<FH> is not specified then the return value, on sucess,
will be a reference to an array containg the article requested, each
entry in the array will contain one line of the article.

If no arguments are passed then the current article in the currently
selected newsgroup is fetched.

C<MSGNUM> is a numeric id of an article in the current newsgroup, and
will change the current article pointer.  C<MSGID> is the message id of
an article as shown in that article's header.  It is anticipated that the
client will obtain the C<MSGID> from a list provided by the C<newnews>
command, from references contained within another article, or from the
message-id provided in the response to some other commands.

If there is an error then C<undef> will be returned.

=item body ( [ MSGID|MSGNUM ], [FH] )

Like C<article> but only fetches the body of the article.

=item head ( [ MSGID|MSGNUM ], [FH] )

Like C<article> but only fetches the headers for the article.

=item nntpstat ( [ MSGID|MSGNUM ] )

The C<nntpstat> command is similar to the C<article> command except that no
text is returned.  When selecting by message number within a group,
the C<nntpstat> command serves to set the "current article pointer" without
sending text.

Using the C<nntpstat> command to
select by message-id is valid but of questionable value, since a
selection by message-id does B<not> alter the "current article pointer".

Returns the message-id of the "current article".

=item group ( [ GROUP ] )

Set and/or get the current group. If C<GROUP> is not given then information
is returned on the current group.

In a scalar context it returns the group name.

In an array context the return value is a list containing, the number
of articles in the group, the number of the first article, the number
of the last article and the group name.

=item ihave ( MSGID [, MESSAGE ])

The C<ihave> command informs the server that the client has an article
whose id is C<MSGID>.  If the server desires a copy of that
article, and C<MESSAGE> has been given the it will be sent.

Returns I<true> if the server desires the article and C<MESSAGE> was
successfully sent,if specified.

If C<MESSAGE> is not specified then the message must be sent using the
C<datasend> and C<dataend> methods from L<Net::Cmd>

C<MESSAGE> can be either an array of lines or a reference to an array.

=item last ()

Set the "current article pointer" to the previous article in the current
newsgroup.

Returns the message-id of the article.

=item date ()

Returns the date on the remote server. This date will be in a UNIX time
format (seconds since 1970)

=item postok ()

C<postok> will return I<true> if the servers initial response indicated
that it will allow posting.

=item authinfo ( USER, PASS )

=item list ()

Obtain information about all the active newsgroups. The results is a reference
to a hash where the key is a group name and each value is a reference to an
array. The elements in this array are:- the first article number in the group,
the last article number in the group and any information flags about the group.

=item newgroups ( SINCE [, DISTRIBUTIONS ])

C<SINCE> is a time value and C<DISTRIBUTIONS> is either a distribution
pattern or a reference to a list of distribution patterns.
The result is the same as C<list>, but the
groups return will be limited to those created after C<SINCE> and, if
specified, in one of the distribution areas in C<DISTRIBUTIONS>. 

=item newnews ( SINCE [, GROUPS [, DISTRIBUTIONS ]])

C<SINCE> is a time value. C<GROUPS> is either a group pattern or a reference
to a list of group patterns. C<DISTRIBUTIONS> is either a distribution
pattern or a reference to a list of distribution patterns.

Returns a reference to a list which contains the message-ids of all news posted
after C<SINCE>, that are in a groups which matched C<GROUPS> and a
distribution which matches C<DISTRIBUTIONS>.

=item next ()

Set the "current article pointer" to the next article in the current
newsgroup.

Returns the message-id of the article.

=item post ( [ MESSAGE ] )

Post a new article to the news server. If C<MESSAGE> is specified and posting
is allowed then the message will be sent.

If C<MESSAGE> is not specified then the message must be sent using the
C<datasend> and C<dataend> methods from L<Net::Cmd>

C<MESSAGE> can be either an array of lines or a reference to an array.

=item slave ()

Tell the remote server that I am not a user client, but probably another
news server.

=item quit ()

Quit the remote server and close the socket connection.

=back

=head2 Extension methods

These methods use commands that are not part of the RFC977 documentation. Some
servers may not support all of them.

=over 4

=item newsgroups ( [ PATTERN ] )

Returns a reference to a hash where the keys are all the group names which
match C<PATTERN>, or all of the groups if no pattern is specified, and
each value contains the description text for the group.

=item distributions ()

Returns a reference to a hash where the keys are all the possible
distribution names and the values are the distribution descriptions.

=item subscriptions ()

Returns a reference to a list which contains a list of groups which
are recommended for a new user to subscribe to.

=item overview_fmt ()

Returns a reference to an array which contain the names of the fields returned
by C<xover>.

=item active_times ()

Returns a reference to a hash where the keys are the group names and each
value is a reference to an array containing the time the groups was created
and an identifier, possibly an Email address, of the creator.

=item active ( [ PATTERN ] )

Similar to C<list> but only active groups that match the pattern are returned.
C<PATTERN> can be a group pattern.

=item xgtitle ( PATTERN )

Returns a reference to a hash where the keys are all the group names which
match C<PATTERN> and each value is the description text for the group.

=item xhdr ( HEADER, MESSAGE-SPEC )

Obtain the header field C<HEADER> for all the messages specified. 

The return value will be a reference
to a hash where the keys are the message numbers and each value contains
the text of the requested header for that message.

=item xover ( MESSAGE-SPEC )

The return value will be a reference
to a hash where the keys are the message numbers and each value contains
a reference to an array which contains the overview fields for that
message.

The names of the fields can be obtained by calling C<overview_fmt>.

=item xpath ( MESSAGE-ID )

Returns the path name to the file on the server which contains the specified
message.

=item xpat ( HEADER, PATTERN, MESSAGE-SPEC)

The result is the same as C<xhdr> except the is will be restricted to
headers where the text of the header matches C<PATTERN>

=item xrover

The XROVER command returns reference information for the article(s)
specified.

Returns a reference to a HASH where the keys are the message numbers and the
values are the References: lines from the articles

=item listgroup ( [ GROUP ] )

Returns a reference to a list of all the active messages in C<GROUP>, or
the current group if C<GROUP> is not specified.

=item reader

Tell the server that you are a reader and not another server.

This is required by some servers. For example if you are connecting to
an INN server and you have transfer permission your connection will
be connected to the transfer daemon, not the NNTP daemon. Issuing
this command will cause the transfer daemon to hand over control
to the NNTP daemon.

Some servers do not understand this command, but issuing it and ignoring
the response is harmless.

=back

=head1 UNSUPPORTED

The following NNTP command are unsupported by the package, and there are
no plans to do so.

    AUTHINFO GENERIC
    XTHREAD
    XSEARCH
    XINDEX

=head1 DEFINITIONS

=over 4

=item MESSAGE-SPEC

C<MESSAGE-SPEC> is either a single message-id, a single message number, or
a reference to a list of two message numbers.

If C<MESSAGE-SPEC> is a reference to a list of two message numbers and the
second number in a range is less than or equal to the first then the range
represents all messages in the group after the first message number.

B<NOTE> For compatibility reasons only with earlier versions of Net::NNTP
a message spec can be passed as a list of two numbers, this is deprecated
and a reference to the list should now be passed

=item PATTERN

The C<NNTP> protocol uses the C<WILDMAT> format for patterns.
The WILDMAT format was first developed by Rich Salz based on
the format used in the UNIX "find" command to articulate
file names. It was developed to provide a uniform mechanism
for matching patterns in the same manner that the UNIX shell
matches filenames.

Patterns are implicitly anchored at the
beginning and end of each string when testing for a match.

There are five pattern matching operations other than a strict
one-to-one match between the pattern and the source to be
checked for a match.

The first is an asterisk C<*> to match any sequence of zero or more
characters.

The second is a question mark C<?> to match any single character. The
third specifies a specific set of characters.

The set is specified as a list of characters, or as a range of characters
where the beginning and end of the range are separated by a minus (or dash)
character, or as any combination of lists and ranges. The dash can
also be included in the set as a character it if is the beginning
or end of the set. This set is enclosed in square brackets. The
close square bracket C<]> may be used in a set if it is the first
character in the set.

The fourth operation is the same as the
logical not of the third operation and is specified the same
way as the third with the addition of a caret character C<^> at
the beginning of the test string just inside the open square
bracket.

The final operation uses the backslash character to
invalidate the special meaning of the a open square bracket C<[>,
the asterisk, backslash or the question mark. Two backslashes in
sequence will result in the evaluation of the backslash as a
character with no special meaning.

=over 4

=item Examples

=item C<[^]-]>

matches any single character other than a close square
bracket or a minus sign/dash.

=item C<*bdc>

matches any string that ends with the string "bdc"
including the string "bdc" (without quotes).

=item C<[0-9a-zA-Z]>

matches any single printable alphanumeric ASCII character.

=item C<a??d>

matches any four character string which begins
with a and ends with d.

=back

=back

=head1 SEE ALSO

L<Net::Cmd>

=head1 AUTHOR

Graham Barr <gbarr@pobox.com>

=head1 COPYRIGHT

Copyright (c) 1995-1997 Graham Barr. All rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut
WFTP_FILE_END: www_ftp/Net/NNTP.pm
WFTP_FILE_START: www_ftp/Net/PH.pm
#
# Copyright (c) 1995-1997 Graham Barr <gbarr@pobox.com> and
# Alex Hristov <hristov@slb.com>. All rights reserved. This program is free
# software; you can redistribute it and/or modify it under the same terms
# as Perl itself.

package Net::PH;

require 5.001;

use strict;
use vars qw(@ISA $VERSION);
use Carp;

use Socket 1.3;
use IO::Socket;
use Net::Cmd;
use Net::Config;

$VERSION = "2.20"; # $Id: //depot/libnet/Net/PH.pm#7$
@ISA     = qw(Exporter Net::Cmd IO::Socket::INET);

sub new
{
 my $pkg  = shift;
 my $host = shift if @_ % 2;
 my %arg  = @_; 
 my $hosts = defined $host ? [ $host ] : $NetConfig{ph_hosts};
 my $ph;

 my $h;
 foreach $h (@{$hosts})
  {
   $ph = $pkg->SUPER::new(PeerAddr => ($host = $h), 
			  PeerPort => $arg{Port} || 'csnet-ns(105)',
			  Proto    => 'tcp',
			  Timeout  => defined $arg{Timeout}
					? $arg{Timeout}
					: 120
			 ) and last;
  }

 return undef
	unless defined $ph;

 ${*$ph}{'net_ph_host'} = $host;

 $ph->autoflush(1);

 $ph->debug(exists $arg{Debug} ? $arg{Debug} : undef);

 $ph;
}

sub status
{
 my $ph = shift;

 $ph->command('status')->response;
 $ph->code;
}

sub login
{
 my $ph = shift;
 my($user,$pass,$encrypted) = @_;
 my $resp;

 $resp = $ph->command("login",$user)->response;

 if(defined($pass) && $resp == CMD_MORE)
  {
   if($encrypted)
    {
     my $challenge_str = $ph->message;
     chomp($challenge_str);
     Net::PH::crypt::crypt_start($pass);
     my $cryptstr = Net::PH::crypt::encryptit($challenge_str);

     $ph->command("answer", $cryptstr);
    }
   else
    {
     $ph->command("clear", $pass);
    }
   $resp = $ph->response;
  }

 $resp == CMD_OK;
}

sub logout
{
 my $ph = shift;

 $ph->command("logout")->response == CMD_OK;
}

sub id
{
 my $ph = shift;
 my $id = @_ ? shift : $<;

 $ph->command("id",$id)->response == CMD_OK;
}

sub siteinfo
{
 my $ph = shift;

 $ph->command("siteinfo");

 my $ln;
 my %resp;
 my $cur_num = 0;

 while(defined($ln = $ph->getline))
  {
   $ph->debug_print(0,$ln)
     if ($ph->debug & 2);
   chomp($ln);
   my($code,$num,$tag,$data);

   if($ln =~ /^-(\d+):(\d+):(?:\s*([^:]+):)?\s*(.*)/o)
    {
     ($code,$num,$tag,$data) = ($1, $2, $3 || "",$4);
     $resp{$tag} = bless [$code, $num, $tag, $data], "Net::PH::Result";
    }
   else
    {
     $ph->set_status($ph->parse_response($ln));
     return \%resp;
    }
  }

 return undef;
}

sub query
{
 my $ph = shift;
 my $search = shift;

 my($k,$v);

 my @args = ('query', _arg_hash($search));

 push(@args,'return',_arg_list( shift ))
	if @_;

 unless($ph->command(@args)->response == CMD_INFO)
  {
   return $ph->code == 501
	? []
	: undef;
  }

 my $ln;
 my @resp;
 my $cur_num = 0;

 my($last_tag);

 while(defined($ln = $ph->getline))
  {
   $ph->debug_print(0,$ln)
     if ($ph->debug & 2);
   chomp($ln);
   my($code,$idx,$num,$tag,$data);

   if($ln =~ /^-(\d+):(\d+):\s*([^:]*):\s*(.*)/o)
    {
     ($code,$idx,$tag,$data) = ($1,$2,$3,$4);
     my $num = $idx - 1;

     $resp[$num] ||= {};

     $tag = $last_tag
	unless(length($tag));

     $last_tag = $tag;

     if(exists($resp[$num]->{$tag}))
      {
       $resp[$num]->{$tag}->[3] .= "\n" . $data;
      }
     else
      {
       $resp[$num]->{$tag} = bless [$code, $idx, $tag, $data], "Net::PH::Result";
      }
    }
   else
    {
     $ph->set_status($ph->parse_response($ln));
     return \@resp;
    }
  }

 return undef;
}

sub change
{
 my $ph = shift;
 my $search = shift;
 my $make = shift;

 $ph->command(
	"change", _arg_hash($search),
	"make",   _arg_hash($make)
 )->response == CMD_OK;
}

sub _arg_hash
{
 my $hash = shift;

 return $hash
	unless(ref($hash));

 my($k,$v);
 my @r;

 while(($k,$v) = each %$hash)
  {
   my $a = $v;
   $a =~ s/\n/\\n/sog;
   $a =~ s/\t/\\t/sog;
   $a = '"' . $a . '"'
	if $a =~ /\W/;
   $a = '""'
	unless length $a;

   push(@r, "$k=$a");   
  }
 join(" ", @r);
}

sub _arg_list
{
 my $arr = shift;

 return $arr
	unless(ref($arr));

 my $v;
 my @r;

 foreach $v (@$arr)
  {
   my $a = $v;
   $a =~ s/\n/\\n/sog;
   $a =~ s/\t/\\t/sog;
   $a = '"' . $a . '"'
	if $a =~ /\W/;
   push(@r, $a);   
  }

 join(" ",@r);
}

sub add
{
 my $ph = shift;
 my $arg = @_ > 1 ? { @_ } : shift;

 $ph->command('add', _arg_hash($arg))->response == CMD_OK;
}

sub delete
{
 my $ph = shift;
 my $arg = @_ > 1 ? { @_ } : shift;

 $ph->command('delete', _arg_hash($arg))->response == CMD_OK;
}

sub force
{
 my $ph = shift; 
 my $search = shift;
 my $force = shift;

 $ph->command(
	"change", _arg_hash($search),
	"force",  _arg_hash($force)
 )->response == CMD_OK;
}


sub fields
{
 my $ph = shift;

 $ph->command("fields", _arg_list(\@_));

 my $ln;
 my %resp;
 my $cur_num = 0;
 my @tags = ();
 
 while(defined($ln = $ph->getline))
  {
   $ph->debug_print(0,$ln)
     if ($ph->debug & 2);
   chomp($ln);

   my($code,$num,$tag,$data,$last_tag);

   if($ln =~ /^-(\d+):(\d+):\s*([^:]*):\s*(.*)/o)
    {
     ($code,$num,$tag,$data) = ($1,$2,$3,$4);

     $tag = $last_tag
	unless(length($tag));

     $last_tag = $tag;

     if(exists $resp{$tag})
      {
       $resp{$tag}->[3] .= "\n" . $data;
      }
     else
      {
       $resp{$tag} = bless [$code, $num, $tag, $data], "Net::PH::Result";
       push @tags, $tag;
      }
    }
   else
    {
     $ph->set_status($ph->parse_response($ln));
     return wantarray ? (\%resp, \@tags) : \%resp;
    }
  }

 return;
}

sub quit
{
 my $ph = shift;

 $ph->close
	if $ph->command("quit")->response == CMD_OK;
}

##
## Net::Cmd overrides
##

sub parse_response
{
 return ()
    unless $_[1] =~ s/^(-?)(\d\d\d):?//o;
 ($2, $1 eq "-");
}

sub debug_text { $_[2] =~ /^(clear)/i ? "$1 ....\n" : $_[2]; }

package Net::PH::Result;

sub code  { shift->[0] }
sub value { shift->[1] }
sub field { shift->[2] }
sub text  { shift->[3] }

package Net::PH::crypt;

#  The code in this package is based upon 'cryptit.c', Copyright (C) 1988 by
#  Steven Dorner, and Paul Pomes, and the University of Illinois Board
#  of Trustees, and by CSNET.

use integer;
use strict;
 
sub ROTORSZ () { 256 }
sub MASK () { 255 }

my(@t1,@t2,@t3,$n1,$n2);

sub crypt_start {
    my $pass = shift;
    $n1 = 0;
    $n2 = 0;
    crypt_init($pass);
}

sub crypt_init {
    my $pw = shift;
    my $i;

    @t2 = @t3 = (0) x ROTORSZ;

    my $buf = crypt($pw,$pw);
    return -1 unless length($buf) > 0;
    $buf = substr($buf . "\0" x 13,0,13);
    my @buf = map { ord $_ } split(//, $buf);


    my $seed = 123;
    for($i = 0 ; $i < 13 ; $i++) {
	$seed = $seed * $buf[$i] + $i;
    }
    @t1 = (0 .. ROTORSZ-1);
    
    for($i = 0 ; $i < ROTORSZ ; $i++) {
	$seed = 5 * $seed + $buf[$i % 13];
	my $random = $seed % 65521;
	my $k = ROTORSZ - 1 - $i;
	my $ic = ($random & MASK) % ($k + 1);
	$random >>= 8;
	@t1[$k,$ic] = @t1[$ic,$k];
	next if $t3[$k] != 0;
	$ic = ($random & MASK) % $k;
	while($t3[$ic] != 0) {
	    $ic = ($ic + 1) % $k;
	}
	$t3[$k] = $ic;
	$t3[$ic] = $k;
    }
    for($i = 0 ; $i < ROTORSZ ; $i++) {
	$t2[$t1[$i] & MASK] = $i
    }
}

sub encode {
    my $sp = shift;
    my $ch;
    my $n = scalar(@$sp);
    my @out = ($n);
    my $i;

    for($i = 0 ; $i < $n ; ) {
	my($f0,$f1,$f2) = splice(@$sp,0,3);
	push(@out,
	    $f0 >> 2,
	    ($f0 << 4) & 060 | ($f1 >> 4) & 017,
	    ($f1 << 2) & 074 | ($f2 >> 6) & 03,
	    $f2 & 077);
	$i += 3;
   }
   join("", map { chr((($_ & 077) + 35) & 0xff) } @out);  # ord('#') == 35
}

sub encryptit {
    my $from = shift;
    my @from = map { ord $_ } split(//, $from);
    my @sp = ();
    my $ch;
    while(defined($ch = shift @from)) {
	push(@sp,
	    $t2[($t3[($t1[($ch + $n1) & MASK] + $n2) & MASK] - $n2) & MASK] - $n1);

	$n1++;
	if($n1 == ROTORSZ) {
	    $n1 = 0;
	    $n2++;
	    $n2 = 0 if $n2 == ROTORSZ;
	}
    }
    encode(\@sp);
}

1;

__END__

=head1 NAME

Net::PH - CCSO Nameserver Client class

=head1 SYNOPSIS

    use Net::PH;
    
    $ph = Net::PH->new("some.host.name",
                       Port    => 105,
                       Timeout => 120,
                       Debug   => 0);

    if($ph) {
        $q = $ph->query({ field1 => "value1" },
                        [qw(name address pobox)]);
    
        if($q) {
        }
    }
    
    # Alternative syntax
    
    if($ph) {
        $q = $ph->query('field1=value1',
                        'name address pobox');
    
        if($q) {
        }
    }

=head1 DESCRIPTION

C<Net::PH> is a class implementing a simple Nameserver/PH client in Perl
as described in the CCSO Nameserver -- Server-Client Protocol. Like other
modules in the Net:: family the C<Net::PH> object inherits methods from
C<Net::Cmd>.

=head1 CONSTRUCTOR

=over 4

=item new ( [ HOST ] [, OPTIONS ])

    $ph = Net::PH->new("some.host.name",
                       Port    => 105,
                       Timeout => 120,
                       Debug   => 0
                      );

This is the constructor for a new Net::PH object. C<HOST> is the
name of the remote host to which a PH connection is required.

If C<HOST> is not given, then the C<SNPP_Host> specified in C<Net::Config>
will be used.

C<OPTIONS> is an optional list of named options which are passed in
a hash like fashion, using key and value pairs. Possible options are:-

B<Port> - Port number to connect to on remote host.

B<Timeout> - Maximum time, in seconds, to wait for a response from the
Nameserver, a value of zero will cause all IO operations to block.
(default: 120)

B<Debug> - Enable the printing of debugging information to STDERR

=back

=head1 METHODS

Unless otherwise stated all methods return either a I<true> or I<false>
value, with I<true> meaning that the operation was a success. When a method
states that it returns a value, failure will be returned as I<undef> or an
empty list.

=over 4

=item query( SEARCH [, RETURN ] )

    $q = $ph->query({ name => $myname },
		    [qw(name email schedule)]);
    
    foreach $handle (@{$q}) {
	foreach $field (keys %{$handle}) {
            $c = ${$handle}{$field}->code;
            $v = ${$handle}{$field}->value;
            $f = ${$handle}{$field}->field;
            $t = ${$handle}{$field}->text;
            print "field:[$field] [$c][$v][$f][$t]\n" ;
	}
    }

    

Search the database and return fields from all matching entries.

The C<SEARCH> argument is a reference to a HASH which contains field/value
pairs which will be passed to the Nameserver as the search criteria.

C<RETURN> is optional, but if given it should be a reference to a list which
contains field names to be returned.

The alternative syntax is to pass strings instead of references, for example

    $q = $ph->query('name=myname',
		    'name email schedule');

The C<SEARCH> argument is a string that is passed to the Nameserver as the 
search criteria. The strings being passed should B<not> contain any carriage
returns, or else the query command might fail or return invalid data.

C<RETURN> is optional, but if given it should be a string which will
contain field names to be returned.

Each match from the server will be returned as a HASH where the keys are the
field names and the values are C<Net::PH:Result> objects (I<code>, I<value>, 
I<field>, I<text>).

Returns a reference to an ARRAY which contains references to HASHs, one
per match from the server.

=item change( SEARCH , MAKE )

    $r = $ph->change({ email => "*.domain.name" },
                     { schedule => "busy");

Change field values for matching entries.

The C<SEARCH> argument is a reference to a HASH which contains field/value
pairs which will be passed to the Nameserver as the search criteria.

The C<MAKE> argument is a reference to a HASH which contains field/value
pairs which will be passed to the Nameserver that
will set new values to designated fields.

The alternative syntax is to pass strings instead of references, for example

    $r = $ph->change('email="*.domain.name"',
                     'schedule="busy"');

The C<SEARCH> argument is a string to be passed to the Nameserver as the 
search criteria. The strings being passed should B<not> contain any carriage
returns, or else the query command might fail or return invalid data.


The C<MAKE> argument is a string to be passed to the Nameserver that
will set new values to designated fields.

Upon success all entries that match the search criteria will have
the field values, given in the Make argument, changed.

=item login( USER, PASS [, ENCRYPT ])

    $r = $ph->login('username','password',1);

Enter login mode using C<USER> and C<PASS>. If C<ENCRYPT> is given and
is I<true> then the password will be used to encrypt a challenge text 
string provided by the server, and the encrypted string will be sent back
to the server. If C<ENCRYPT> is not given, or I<false> then the password 
will be sent in clear text (I<this is not recommended>)

=item logout()

    $r = $ph->logout();

Exit login mode and return to anonymous mode.

=item fields( [ FIELD_LIST ] )

    $fields = $ph->fields();
    foreach $field (keys %{$fields}) {
        $c = ${$fields}{$field}->code;
        $v = ${$fields}{$field}->value;
        $f = ${$fields}{$field}->field;
        $t = ${$fields}{$field}->text;
        print "field:[$field] [$c][$v][$f][$t]\n";
    }

In a scalar context, returns a reference to a HASH. The keys of the HASH are
the field names and the values are C<Net::PH:Result> objects (I<code>,
I<value>, I<field>, I<text>).

In an array context, returns a two element array. The first element is a
reference to a HASH as above, the second element is a reference to an array
which contains the tag names in the order that they were returned from the
server.

C<FIELD_LIST> is a string that lists the fields for which info will be
returned.

=item add( FIELD_VALUES )

    $r = $ph->add( { name => $name, phone => $phone });

This method is used to add new entries to the Nameserver database. You
must successfully call L<login> before this method can be used.

B<Note> that this method adds new entries to the database. To modify
an existing entry use L<change>.

C<FIELD_VALUES> is a reference to a HASH which contains field/value
pairs which will be passed to the Nameserver and will be used to 
initialize the new entry.

The alternative syntax is to pass a string instead of a reference, for example

    $r = $ph->add('name=myname phone=myphone');

C<FIELD_VALUES> is a string that consists of field/value pairs which the
new entry will contain. The strings being passed should B<not> contain any
carriage returns, or else the query command might fail or return invalid data.


=item delete( FIELD_VALUES )

    $r = $ph->delete('name=myname phone=myphone');

This method is used to delete existing entries from the Nameserver database.
You must successfully call L<login> before this method can be used.

B<Note> that this method deletes entries to the database. To modify
an existing entry use L<change>.

C<FIELD_VALUES> is a string that serves as the search criteria for the
records to be deleted. Any entry in the database which matches this search 
criteria will be deleted.

=item id( [ ID ] )

    $r = $ph->id('709');

Sends C<ID> to the Nameserver, which will enter this into its
logs. If C<ID> is not given then the UID of the user running the
process will be sent.

=item status()

Returns the current status of the Nameserver.

=item siteinfo()

    $siteinfo = $ph->siteinfo();
    foreach $field (keys %{$siteinfo}) {
        $c = ${$siteinfo}{$field}->code;
        $v = ${$siteinfo}{$field}->value;
        $f = ${$siteinfo}{$field}->field;
        $t = ${$siteinfo}{$field}->text;
        print "field:[$field] [$c][$v][$f][$t]\n";
    }

Returns a reference to a HASH containing information about the server's 
site. The keys of the HASH are the field names and values are
C<Net::PH:Result> objects (I<code>, I<value>, I<field>, I<text>).

=item quit()

    $r = $ph->quit();

Quit the connection

=back

=head1 Q&A

How do I get the values of a Net::PH::Result object?

    foreach $handle (@{$q}) {
        foreach $field (keys %{$handle}) {
            $my_code  = ${$q}{$field}->code;
            $my_value = ${$q}{$field}->value;
            $my_field = ${$q}{$field}->field;
            $my_text  = ${$q}{$field}->text;
        }
    }

How do I get a count of the returned matches to my query?

    $my_count = scalar(@{$query_result});

How do I get the status code and message of the last C<$ph> command?

    $status_code    = $ph->code;
    $status_message = $ph->message;

=head1 SEE ALSO

L<Net::Cmd>

=head1 AUTHORS

Graham Barr <gbarr@pobox.com>
Alex Hristov <hristov@slb.com>

=head1 ACKNOWLEDGMENTS

Password encryption code ported to perl by Broc Seib <bseib@purdue.edu>,
Purdue University Computing Center.

Otis Gospodnetic <otisg@panther.middlebury.edu> suggested
passing parameters as string constants. Some queries cannot be 
executed when passing parameters as string references.

        Example: query first_name last_name email="*.domain"

=head1 COPYRIGHT

The encryption code is based upon cryptit.c, Copyright (C) 1988 by
Steven Dorner, and Paul Pomes, and the University of Illinois Board
of Trustees, and by CSNET.

All other code is Copyright (c) 1996-1997 Graham Barr <gbarr@pobox.com>
and Alex Hristov <hristov@slb.com>. All rights reserved. This program is
free software; you can redistribute it and/or modify it under the same
terms as Perl itself.

=cut
WFTP_FILE_END: www_ftp/Net/PH.pm
WFTP_FILE_START: www_ftp/Net/POP3.pm
# Net::POP3.pm
#
# Copyright (c) 1995-1997 Graham Barr <gbarr@pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.

package Net::POP3;

use strict;
use IO::Socket;
use vars qw(@ISA $VERSION $debug);
use Net::Cmd;
use Carp;
use Net::Config;

$VERSION = "2.21"; # $Id$

@ISA = qw(Net::Cmd IO::Socket::INET);

sub new
{
 my $self = shift;
 my $type = ref($self) || $self;
 my $host = shift if @_ % 2;
 my %arg  = @_; 
 my $hosts = defined $host ? [ $host ] : $NetConfig{pop3_hosts};
 my $obj;
 my @localport = exists $arg{ResvPort} ? ( LocalPort => $arg{ResvPort} ): ();

 my $h;
 foreach $h (@{$hosts})
  {
   $obj = $type->SUPER::new(PeerAddr => ($host = $h), 
			    PeerPort => $arg{Port} || 'pop3(110)',
			    Proto    => 'tcp',
			    @localport,
			    Timeout  => defined $arg{Timeout}
						? $arg{Timeout}
						: 120
			   ) and last;
  }

 return undef
	unless defined $obj;

 ${*$obj}{'net_pop3_host'} = $host;

 $obj->autoflush(1);
 $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef);

 unless ($obj->response() == CMD_OK)
  {
   $obj->close();
   return undef;
  }

 ${*$obj}{'net_pop3_banner'} = $obj->message;

 $obj;
}

##
## We don't want people sending me their passwords when they report problems
## now do we :-)
##

sub debug_text { $_[2] =~ /^(pass|rpop)/i ? "$1 ....\n" : $_[2]; }

sub login
{
 @_ >= 1 && @_ <= 3 or croak 'usage: $pop3->login( USER, PASS )';
 my($me,$user,$pass) = @_;

 if(@_ <= 2)
  {
   require Net::Netrc;

   $user ||= eval { (getpwuid($>))[0] } || $ENV{NAME};

   my $m = Net::Netrc->lookup(${*$me}{'net_pop3_host'},$user);

   $m ||= Net::Netrc->lookup(${*$me}{'net_pop3_host'});

   $pass = $m ? $m->password || ""
              : "";
  }

 $me->user($user) and
    $me->pass($pass);
}

sub apop
{
 @_ >= 1 && @_ <= 3 or croak 'usage: $pop3->apop( USER, PASS )';
 my($me,$user,$pass) = @_;
 my $banner;

 unless(eval { require MD5 })
  {
   carp "You need to install MD5 to use the APOP command";
   return undef;
  }

 return undef
   unless ( $banner = (${*$me}{'net_pop3_banner'} =~ /(<.*>)/)[0] );

 if(@_ <= 2)
  {
   require Net::Netrc;

   $user ||= eval { (getpwuid($>))[0] } || $ENV{NAME};

   my $m = Net::Netrc->lookup(${*$me}{'net_pop3_host'},$user);

   $m ||= Net::Netrc->lookup(${*$me}{'net_pop3_host'});

   $pass = $m ? $m->password || ""
              : "";
  }

 my $md = new MD5;
 $md->add($banner,$pass);

 return undef
    unless($me->_APOP($user,$md->hexdigest));

 my $ret = ${*$me}{'net_pop3_count'} = ($me->message =~ /(\d+)\s+message/io)
	? $1 : ($me->popstat)[0];

 $ret ? $ret : "0E0";
}

sub user
{
 @_ == 2 or croak 'usage: $pop3->user( USER )';
 $_[0]->_USER($_[1]) ? 1 : undef;
}

sub pass
{
 @_ == 2 or croak 'usage: $pop3->pass( PASS )';

 my($me,$pass) = @_;

 return undef
   unless($me->_PASS($pass));

 my $ret = ${*$me}{'net_pop3_count'} = ($me->message =~ /(\d+)\s+message/io)
	? $1 : ($me->popstat)[0];

 $ret ? $ret : "0E0";
}

sub reset
{
 @_ == 1 or croak 'usage: $obj->reset()';

 my $me = shift;

 return 0 
   unless($me->_RSET);
  
 if(defined ${*$me}{'net_pop3_mail'})
  {
   local $_;
   foreach (@{${*$me}{'net_pop3_mail'}})
    {
     delete $_->{'net_pop3_deleted'};
    }
  }
}

sub last
{
 @_ == 1 or croak 'usage: $obj->last()';

 return undef
    unless $_[0]->_LAST && $_[0]->message =~ /(\d+)/;

 return $1;
}

sub top
{
 @_ == 2 || @_ == 3 or croak 'usage: $pop3->top( MSGNUM [, NUMLINES ])';
 my $me = shift;

 return undef
    unless $me->_TOP($_[0], $_[1] || 0);

 $me->read_until_dot;
}

sub popstat
{
 @_ == 1 or croak 'usage: $pop3->popstat()';
 my $me = shift;

 return ()
    unless $me->_STAT && $me->message =~ /(\d+)\D+(\d+)/;

 ($1 || 0, $2 || 0);
}

sub list
{
 @_ == 1 || @_ == 2 or croak 'usage: $pop3->list( [ MSGNUM ] )';
 my $me = shift;

 return undef
    unless $me->_LIST(@_);

 if(@_)
  {
   $me->message =~ /\d+\D+(\d+)/;
   return $1 || undef;
  }
 
 my $info = $me->read_until_dot
	or return undef;

 my %hash = map { (/(\d+)\D+(\d+)/) } @$info;

 return \%hash;
}

sub get
{
 @_ == 2 or @_ == 3 or croak 'usage: $pop3->get( MSGNUM [, FH ])';
 my $me = shift;

 return undef
    unless $me->_RETR(shift);

 $me->read_until_dot(@_);
}

sub delete
{
 @_ == 2 or croak 'usage: $pop3->delete( MSGNUM )';
 $_[0]->_DELE($_[1]);
}

sub uidl
{
 @_ == 1 || @_ == 2 or croak 'usage: $pop3->uidl( [ MSGNUM ] )';
 my $me = shift;
 my $uidl;

 $me->_UIDL(@_) or
    return undef;
 if(@_)
  {
   $uidl = ($me->message =~ /\d+\s+([\041-\176]+)/)[0];
  }
 else
  {
   my $ref = $me->read_until_dot
	or return undef;
   my $ln;
   $uidl = {};
   foreach $ln (@$ref) {
     my($msg,$uid) = $ln =~ /^\s*(\d+)\s+([\041-\176]+)/;
     $uidl->{$msg} = $uid;
   }
  }
 return $uidl;
}

sub ping
{
 @_ == 2 or croak 'usage: $pop3->ping( USER )';
 my $me = shift;

 return () unless $me->_PING(@_) && $me->message =~ /(\d+)\D+(\d+)/;

 ($1 || 0, $2 || 0);
}

 
sub _STAT { shift->command('STAT')->response() == CMD_OK }
sub _LIST { shift->command('LIST',@_)->response() == CMD_OK }
sub _RETR { shift->command('RETR',$_[0])->response() == CMD_OK }
sub _DELE { shift->command('DELE',$_[0])->response() == CMD_OK }
sub _NOOP { shift->command('NOOP')->response() == CMD_OK }
sub _RSET { shift->command('RSET')->response() == CMD_OK }
sub _QUIT { shift->command('QUIT')->response() == CMD_OK }
sub _TOP  { shift->command('TOP', @_)->response() == CMD_OK }
sub _UIDL { shift->command('UIDL',@_)->response() == CMD_OK }
sub _USER { shift->command('USER',$_[0])->response() == CMD_OK }
sub _PASS { shift->command('PASS',$_[0])->response() == CMD_OK }
sub _APOP { shift->command('APOP',@_)->response() == CMD_OK }
sub _PING { shift->command('PING',$_[0])->response() == CMD_OK }

sub _RPOP { shift->command('RPOP',$_[0])->response() == CMD_OK }
sub _LAST { shift->command('LAST')->response() == CMD_OK }

sub quit
{
 my $me = shift;

 $me->_QUIT;
 $me->close;
}

sub DESTROY
{
 my $me = shift;

 if(defined fileno($me))
  {
   $me->reset;
   $me->quit;
  }
}

##
## POP3 has weird responses, so we emulate them to look the same :-)
##

sub response
{
 my $cmd = shift;
 my $str = $cmd->getline() || return undef;
 my $code = "500";

 $cmd->debug_print(0,$str)
   if ($cmd->debug);

 if($str =~ s/^\+OK\s+//io)
  {
   $code = "200"
  }
 else
  {
   $str =~ s/^-ERR\s+//io;
  }

 ${*$cmd}{'net_cmd_resp'} = [ $str ];
 ${*$cmd}{'net_cmd_code'} = $code;

 substr($code,0,1);
}

1;

__END__

=head1 NAME

Net::POP3 - Post Office Protocol 3 Client class (RFC1081)

=head1 SYNOPSIS

    use Net::POP3;
    
    # Constructors
    $pop = Net::POP3->new('pop3host');
    $pop = Net::POP3->new('pop3host', Timeout => 60);

=head1 DESCRIPTION

This module implements a client interface to the POP3 protocol, enabling
a perl5 application to talk to POP3 servers. This documentation assumes
that you are familiar with the POP3 protocol described in RFC1081.

A new Net::POP3 object must be created with the I<new> method. Once
this has been done, all POP3 commands are accessed via method calls
on the object.

=head1 EXAMPLES

    Need some small examples in here :-)

=head1 CONSTRUCTOR

=over 4

=item new ( [ HOST, ] [ OPTIONS ] )

This is the constructor for a new Net::POP3 object. C<HOST> is the
name of the remote host to which a POP3 connection is required.

If C<HOST> is not given, then the C<POP3_Host> specified in C<Net::Config>
will be used.

C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
Possible options are:

B<ResvPort> - If given then the socket for the C<Net::POP3> object
will be bound to the local port given using C<bind> when the socket is
created.

B<Timeout> - Maximum time, in seconds, to wait for a response from the
POP3 server (default: 120)

B<Debug> - Enable debugging information

=back

=head1 METHODS

Unless otherwise stated all methods return either a I<true> or I<false>
value, with I<true> meaning that the operation was a success. When a method
states that it returns a value, failure will be returned as I<undef> or an
empty list.

=over 4

=item user ( USER )

Send the USER command.

=item pass ( PASS )

Send the PASS command. Returns the number of messages in the mailbox.

=item login ( [ USER [, PASS ]] )

Send both the the USER and PASS commands. If C<PASS> is not given the
C<Net::POP3> uses C<Net::Netrc> to lookup the password using the host
and username. If the username is not specified then the current user name
will be used.

Returns the number of messages in the mailbox. However if there are no
messages on the server the string C<"0E0"> will be returned. This is
will give a true value in a boolean context, but zero in a numeric context.

If there was an error authenticating the user then I<undef> will be returned.

=item apop ( USER, PASS )

Authenticate with the server identifying as C<USER> with password C<PASS>.
Similar ti L<login>, but the password is not sent in clear text. 

To use this method you must have the MD5 package installed, if you do not
this method will return I<undef>


=item top ( MSGNUM [, NUMLINES ] )

Get the header and the first C<NUMLINES> of the body for the message
C<MSGNUM>. Returns a reference to an array which contains the lines of text
read from the server.

=item list ( [ MSGNUM ] )

If called with an argument the C<list> returns the size of the message
in octets.

If called without arguments a reference to a hash is returned. The
keys will be the C<MSGNUM>'s of all undeleted messages and the values will
be their size in octets.

=item get ( MSGNUM [, FH ] )

Get the message C<MSGNUM> from the remote mailbox. If C<FH> is not given
then get returns a reference to an array which contains the lines of
text read from the server. If C<FH> is given then the lines returned
from the server are printed to the filehandle C<FH>.

=item last ()

Returns the highest C<MSGNUM> of all the messages accessed.

=item popstat ()

Returns a list of two elements. These are the number of undeleted
elements and the size of the mbox in octets.

=item ping ( USER )

Returns a list of two elements. These are the number of new messages
and the total number of messages for C<USER>.

=item uidl ( [ MSGNUM ] )

Returns a unique identifier for C<MSGNUM> if given. If C<MSGNUM> is not
given C<uidl> returns a reference to a hash where the keys are the
message numbers and the values are the unique identifiers.

=item delete ( MSGNUM )

Mark message C<MSGNUM> to be deleted from the remote mailbox. All messages
that are marked to be deleted will be removed from the remote mailbox
when the server connection closed.

=item reset ()

Reset the status of the remote POP3 server. This includes reseting the
status of all messages to not be deleted.

=item quit ()

Quit and close the connection to the remote POP3 server. Any messages marked
as deleted will be deleted from the remote mailbox.

=back

=head1 NOTES

If a C<Net::POP3> object goes out of scope before C<quit> method is called
then the C<reset> method will called before the connection is closed. This
means that any messages marked to be deleted will not be.

=head1 SEE ALSO

L<Net::Netrc>
L<Net::Cmd>

=head1 AUTHOR

Graham Barr <gbarr@pobox.com>

=head1 COPYRIGHT

Copyright (c) 1995-1997 Graham Barr. All rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut
WFTP_FILE_END: www_ftp/Net/POP3.pm
WFTP_FILE_START: www_ftp/Net/SMTP.pm
# Net::SMTP.pm
#
# Copyright (c) 1995-1997 Graham Barr <gbarr@pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.

package Net::SMTP;

require 5.001;

use strict;
use vars qw($VERSION @ISA);
use Socket 1.3;
use Carp;
use IO::Socket;
use Net::Cmd;
use Net::Config;

$VERSION = "2.15"; # $Id$

@ISA = qw(Net::Cmd IO::Socket::INET);

sub new
{
 my $self = shift;
 my $type = ref($self) || $self;
 my $host = shift if @_ % 2;
 my %arg  = @_; 
 my $hosts = defined $host ? [ $host ] : $NetConfig{smtp_hosts};
 my $obj;

 my $h;
 foreach $h (@{$hosts})
  {
   $obj = $type->SUPER::new(PeerAddr => ($host = $h), 
			    PeerPort => $arg{Port} || 'smtp(25)',
			    Proto    => 'tcp',
			    Timeout  => defined $arg{Timeout}
						? $arg{Timeout}
						: 120
			   ) and last;
  }

 return undef
	unless defined $obj;

 $obj->autoflush(1);

 $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef);

 unless ($obj->response() == CMD_OK)
  {
   $obj->close();
   return undef;
  }

 ${*$obj}{'net_smtp_host'} = $host;

 (${*$obj}{'net_smtp_banner'}) = $obj->message;
 (${*$obj}{'net_smtp_domain'}) = $obj->message =~ /\A\s*(\S+)/;

 unless($obj->hello($arg{Hello} || ""))
  {
   $obj->close();
   return undef;
  }

 $obj;
}

##
## User interface methods
##

sub banner
{
 my $me = shift;

 return ${*$me}{'net_smtp_banner'} || undef;
}

sub domain
{
 my $me = shift;

 return ${*$me}{'net_smtp_domain'} || undef;
}

sub etrn {
    my $self = shift;
    defined($self->supports('ETRN',500,["Command unknown: 'ETRN'"])) &&
	$self->_ETRN(@_);
}

sub hello
{
 my $me = shift;
 my $domain = shift ||
	      eval {
		    require Net::Domain;
		    Net::Domain::hostfqdn();
		   } ||
		"";
 my $ok = $me->_EHLO($domain);
 my @msg = $me->message;

 if($ok)
  {
   my $h = ${*$me}{'net_smtp_esmtp'} = {};
   my $ln;
   foreach $ln (@msg) {
     $h->{$1} = $2
	if $ln =~ /(\S+)\b[ \t]*([^\n]*)/;
    }
  }
 elsif($me->status == CMD_ERROR) 
  {
   @msg = $me->message
	if $ok = $me->_HELO($domain);
  }

 $ok && $msg[0] =~ /\A(\S+)/
	? $1
	: undef;
}

sub supports {
    my $self = shift;
    my $cmd = uc shift;
    return ${*$self}{'net_smtp_esmtp'}->{$cmd}
	if exists ${*$self}{'net_smtp_esmtp'}->{$cmd};
    $self->set_status(@_)
	if @_;
    return;
}

sub _addr
{
 my $addr = shift || "";

 return $1
    if $addr =~ /(<[^>]+>)/so;

 $addr =~ s/\n/ /sog;
 $addr =~ s/(\A\s+|\s+\Z)//sog;

 return "<" . $addr . ">";
}


sub mail
{
 my $me = shift;
 my $addr = _addr(shift);
 my $opts = "";

 if(@_)
  {
   my %opt = @_;
   my($k,$v);

   if(exists ${*$me}{'net_smtp_esmtp'})
    {
     my $esmtp = ${*$me}{'net_smtp_esmtp'};

     if(defined($v = delete $opt{Size}))
      {
       if(exists $esmtp->{SIZE})
        {
         $opts .= sprintf " SIZE=%d", $v + 0
        }
       else
        {
	 carp 'Net::SMTP::mail: SIZE option not supported by host';
        }
      }

     if(defined($v = delete $opt{Return}))
      {
       if(exists $esmtp->{DSN})
        {
	 $opts .= " RET=" . uc $v
        }
       else
        {
	 carp 'Net::SMTP::mail: DSN option not supported by host';
        }
      }

     if(defined($v = delete $opt{Bits}))
      {
       if(exists $esmtp->{'8BITMIME'})
        {
	 $opts .= $v == 8 ? " BODY=8BITMIME" : " BODY=7BIT"
        }
       else
        {
	 carp 'Net::SMTP::mail: 8BITMIME option not supported by host';
        }
      }

     if(defined($v = delete $opt{Transaction}))
      {
       if(exists $esmtp->{CHECKPOINT})
        {
	 $opts .= " TRANSID=" . _addr($v);
        }
       else
        {
	 carp 'Net::SMTP::mail: CHECKPOINT option not supported by host';
        }
      }

     if(defined($v = delete $opt{Envelope}))
      {
       if(exists $esmtp->{DSN})
        {
	 $v =~ s/([^\041-\176]|=|\+)/sprintf "+%02x", ord($1)/sge;
	 $opts .= " ENVID=$v"
        }
       else
        {
	 carp 'Net::SMTP::mail: DSN option not supported by host';
        }
      }

     carp 'Net::SMTP::recipient: unknown option(s) '
		. join(" ", keys %opt)
		. ' - ignored'
	if scalar keys %opt;
    }
   else
    {
     carp 'Net::SMTP::mail: ESMTP not supported by host - options discarded :-(';
    }
  }

 $me->_MAIL("FROM:".$addr.$opts);
}

sub send	  { shift->_SEND("FROM:" . _addr($_[0])) }
sub send_or_mail  { shift->_SOML("FROM:" . _addr($_[0])) }
sub send_and_mail { shift->_SAML("FROM:" . _addr($_[0])) }

sub reset
{
 my $me = shift;

 $me->dataend()
	if(exists ${*$me}{'net_smtp_lastch'});

 $me->_RSET();
}


sub recipient
{
 my $smtp = shift;
 my $opts = "";
 my $skip_bad = 0;

 if(@_ && ref($_[-1]))
  {
   my %opt = %{pop(@_)};
   my $v;

   $skip_bad = delete $opt{'SkipBad'};

   if(exists ${*$smtp}{'net_smtp_esmtp'})
    {
     my $esmtp = ${*$smtp}{'net_smtp_esmtp'};

     if(defined($v = delete $opt{Notify}))
      {
       if(exists $esmtp->{DSN})
        {
	 $opts .= " NOTIFY=" . join(",",map { uc $_ } @$v)
        }
       else
        {
	 carp 'Net::SMTP::recipient: DSN option not supported by host';
        }
      }

     carp 'Net::SMTP::recipient: unknown option(s) '
		. join(" ", keys %opt)
		. ' - ignored'
	if scalar keys %opt;
    }
   elsif(%opt)
    {
     carp 'Net::SMTP::recipient: ESMTP not supported by host - options discarded :-(';
    }
  }

 my @ok;
 my $addr;
 foreach $addr (@_) 
  {
    if($smtp->_RCPT("TO:" . _addr($addr) . $opts)) {
      push(@ok,$addr) if $skip_bad;
    }
    elsif(!$skip_bad) {
      return 0;
    }
  }

 return $skip_bad ? @ok : 1;
}

sub to { shift->recipient(@_) }

sub data
{
 my $me = shift;

 my $ok = $me->_DATA() && $me->datasend(@_);

 $ok && @_ ? $me->dataend
	   : $ok;
}

sub expand
{
 my $me = shift;

 $me->_EXPN(@_) ? ($me->message)
		: ();
}


sub verify { shift->_VRFY(@_) }

sub help
{
 my $me = shift;

 $me->_HELP(@_) ? scalar $me->message
	        : undef;
}

sub quit
{
 my $me = shift;

 $me->_QUIT;
 $me->close;
}

sub DESTROY
{
# ignore
}

##
## RFC821 commands
##

sub _EHLO { shift->command("EHLO", @_)->response()  == CMD_OK }   
sub _HELO { shift->command("HELO", @_)->response()  == CMD_OK }   
sub _MAIL { shift->command("MAIL", @_)->response()  == CMD_OK }   
sub _RCPT { shift->command("RCPT", @_)->response()  == CMD_OK }   
sub _SEND { shift->command("SEND", @_)->response()  == CMD_OK }   
sub _SAML { shift->command("SAML", @_)->response()  == CMD_OK }   
sub _SOML { shift->command("SOML", @_)->response()  == CMD_OK }   
sub _VRFY { shift->command("VRFY", @_)->response()  == CMD_OK }   
sub _EXPN { shift->command("EXPN", @_)->response()  == CMD_OK }   
sub _HELP { shift->command("HELP", @_)->response()  == CMD_OK }   
sub _RSET { shift->command("RSET")->response()	    == CMD_OK }   
sub _NOOP { shift->command("NOOP")->response()	    == CMD_OK }   
sub _QUIT { shift->command("QUIT")->response()	    == CMD_OK }   
sub _DATA { shift->command("DATA")->response()	    == CMD_MORE } 
sub _TURN { shift->unsupported(@_); } 			   	  
sub _ETRN { shift->command("ETRN", @_)->response()  == CMD_OK }

1;

__END__

=head1 NAME

Net::SMTP - Simple Mail Transfer Protocol Client

=head1 SYNOPSIS

    use Net::SMTP;
    
    # Constructors
    $smtp = Net::SMTP->new('mailhost');
    $smtp = Net::SMTP->new('mailhost', Timeout => 60);

=head1 DESCRIPTION

This module implements a client interface to the SMTP and ESMTP
protocol, enabling a perl5 application to talk to SMTP servers. This
documentation assumes that you are familiar with the concepts of the
SMTP protocol described in RFC821.

A new Net::SMTP object must be created with the I<new> method. Once
this has been done, all SMTP commands are accessed through this object.

The Net::SMTP class is a subclass of Net::Cmd and IO::Socket::INET.

=head1 EXAMPLES

This example prints the mail domain name of the SMTP server known as mailhost:

    #!/usr/local/bin/perl -w
    
    use Net::SMTP;
    
    $smtp = Net::SMTP->new('mailhost');
    print $smtp->domain,"\n";
    $smtp->quit;

This example sends a small message to the postmaster at the SMTP server
known as mailhost:

    #!/usr/local/bin/perl -w
    
    use Net::SMTP;
    
    $smtp = Net::SMTP->new('mailhost');
    
    $smtp->mail($ENV{USER});
    $smtp->to('postmaster');
    
    $smtp->data();
    $smtp->datasend("To: postmaster\n");
    $smtp->datasend("\n");
    $smtp->datasend("A simple test message\n");
    $smtp->dataend();
    
    $smtp->quit;

=head1 CONSTRUCTOR

=over 4

=item new Net::SMTP [ HOST, ] [ OPTIONS ]

This is the constructor for a new Net::SMTP object. C<HOST> is the
name of the remote host to which a SMTP connection is required.

If C<HOST> is not given, then the C<SMTP_Host> specified in C<Net::Config>
will be used.

C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
Possible options are:

B<Hello> - SMTP requires that you identify yourself. This option
specifies a string to pass as your mail domain. If not
given a guess will be taken.

B<Timeout> - Maximum time, in seconds, to wait for a response from the
SMTP server (default: 120)

B<Debug> - Enable debugging information


Example:


    $smtp = Net::SMTP->new('mailhost',
			   Hello => 'my.mail.domain'
			   Timeout => 30,
                           Debug   => 1,
			  );

=head1 METHODS

Unless otherwise stated all methods return either a I<true> or I<false>
value, with I<true> meaning that the operation was a success. When a method
states that it returns a value, failure will be returned as I<undef> or an
empty list.

=over 4

=item banner ()

Returns the banner message which the server replied with when the
initial connection was made.

=item domain ()

Returns the domain that the remote SMTP server identified itself as during
connection.

=item hello ( DOMAIN )

Tell the remote server the mail domain which you are in using the EHLO
command (or HELO if EHLO fails).  Since this method is invoked
automatically when the Net::SMTP object is constructed the user should
normally not have to call it manually.

=item etrn ( DOMAIN )

Request a queue run for the DOMAIN given.

=item mail ( ADDRESS [, OPTIONS] )

=item send ( ADDRESS )

=item send_or_mail ( ADDRESS )

=item send_and_mail ( ADDRESS )

Send the appropriate command to the server MAIL, SEND, SOML or SAML. C<ADDRESS>
is the address of the sender. This initiates the sending of a message. The
method C<recipient> should be called for each address that the message is to
be sent to.

The C<mail> method can some additional ESMTP OPTIONS which is passed
in hash like fashion, using key and value pairs.  Possible options are:

 Size        => <bytes>
 Return      => <???>
 Bits        => "7" | "8"
 Transaction => <ADDRESS>
 Envelope    => <ENVID>


=item reset ()

Reset the status of the server. This may be called after a message has been 
initiated, but before any data has been sent, to cancel the sending of the
message.

=item recipient ( ADDRESS [, ADDRESS [ ...]] [, OPTIONS ] )

Notify the server that the current message should be sent to all of the
addresses given. Each address is sent as a separate command to the server.
Should the sending of any address result in a failure then the
process is aborted and a I<false> value is returned. It is up to the
user to call C<reset> if they so desire.

The C<recipient> method can some additional OPTIONS which is passed
in hash like fashion, using key and value pairs.  Possible options are:

 Notify    =>
 SkipBad   => ignore bad addresses

If C<SkipBad> is true the C<recipient> will not return an error when a
bad address is encountered and it will return an array of addresses
that did succeed.

=item to ( ADDRESS [, ADDRESS [...]] )

A synonym for C<recipient>.

=item data ( [ DATA ] )

Initiate the sending of the data from the current message. 

C<DATA> may be a reference to a list or a list. If specified the contents
of C<DATA> and a termination string C<".\r\n"> is sent to the server. And the
result will be true if the data was accepted.

If C<DATA> is not specified then the result will indicate that the server
wishes the data to be sent. The data must then be sent using the C<datasend>
and C<dataend> methods described in L<Net::Cmd>.

=item expand ( ADDRESS )

Request the server to expand the given address Returns an array
which contains the text read from the server.

=item verify ( ADDRESS )

Verify that C<ADDRESS> is a legitimate mailing address.

=item help ( [ $subject ] )

Request help text from the server. Returns the text or undef upon failure

=item quit ()

Send the QUIT command to the remote SMTP server and close the socket connection.

=back

=head1 SEE ALSO

L<Net::Cmd>

=head1 AUTHOR

Graham Barr <gbarr@pobox.com>

=head1 COPYRIGHT

Copyright (c) 1995-1997 Graham Barr. All rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut
WFTP_FILE_END: www_ftp/Net/SMTP.pm
WFTP_FILE_START: www_ftp/Net/SNPP.pm
# Net::SNPP.pm
#
# Copyright (c) 1995-1997 Graham Barr <gbarr@pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.

package Net::SNPP;

require 5.001;

use strict;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
use Socket 1.3;
use Carp;
use IO::Socket;
use Net::Cmd;
use Net::Config;

$VERSION = "1.11"; # $Id:$
@ISA     = qw(Net::Cmd IO::Socket::INET);
@EXPORT  = (qw(CMD_2WAYERROR CMD_2WAYOK CMD_2WAYQUEUED), @Net::Cmd::EXPORT);

sub CMD_2WAYERROR  () { 7 }
sub CMD_2WAYOK     () { 8 }
sub CMD_2WAYQUEUED () { 9 }

sub new
{
 my $self = shift;
 my $type = ref($self) || $self;
 my $host = shift if @_ % 2;
 my %arg  = @_; 
 my $hosts = defined $host ? [ $host ] : $NetConfig{snpp_hosts};
 my $obj;

 my $h;
 foreach $h (@{$hosts})
  {
   $obj = $type->SUPER::new(PeerAddr => ($host = $h), 
			    PeerPort => $arg{Port} || 'snpp(444)',
			    Proto    => 'tcp',
			    Timeout  => defined $arg{Timeout}
						? $arg{Timeout}
						: 120
			    ) and last;
  }

 return undef
	unless defined $obj;

 ${*$obj}{'net_snpp_host'} = $host;

 $obj->autoflush(1);

 $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef);

 unless ($obj->response() == CMD_OK)
  {
   $obj->close();
   return undef;
  }

 $obj;
}

##
## User interface methods
##

sub pager_id
{
 @_ == 2 or croak 'usage: $snpp->pager_id( PAGER_ID )';
 shift->_PAGE(@_);
}

sub content
{
 @_ == 2 or croak 'usage: $snpp->content( MESSAGE )';
 shift->_MESS(@_);
}

sub send
{
 my $me = shift;

 if(@_)
  {
   my %arg = @_;

   if(exists $arg{Pager})
    {
     my $pagers = ref($arg{Pager}) ? $arg{Pager} : [ $arg{Pager} ];
     my $pager;
     foreach $pager (@$pagers)
      {
       $me->_PAGE($pager) || return 0
      }
    }

   $me->_MESS($arg{Message}) || return 0
	if(exists $arg{Message});

   $me->hold($arg{Hold}) || return 0
	if(exists $arg{Hold});

   $me->hold($arg{HoldLocal},1) || return 0
	if(exists $arg{HoldLocal});

   $me->_COVE($arg{Coverage}) || return 0
	if(exists $arg{Coverage});

   $me->_ALER($arg{Alert} ? 1 : 0) || return 0
	if(exists $arg{Alert});

   $me->service_level($arg{ServiceLevel}) || return 0
	if(exists $arg{ServiceLevel});
  }

 $me->_SEND();
}

sub data
{
 my $me = shift;

 my $ok = $me->_DATA() && $me->datasend(@_);

 return $ok
	unless($ok && @_);

 $me->dataend;
}

sub login
{
 @_ == 2 || @_ == 3 or croak 'usage: $snpp->login( USER [, PASSWORD ])';
 shift->_LOGI(@_);
}

sub help
{
 @_ == 1 or croak 'usage: $snpp->help()';
 my $me = shift;

 return $me->_HELP() ? $me->message
		     : undef;
}

sub xwho
{
 @_ == 1 or croak 'usage: $snpp->xwho()';
 my $me = shift;

 $me->_XWHO or return undef;

 my(%hash,$line);
 my @msg = $me->message;
 pop @msg; # Remove command complete line

 foreach $line (@msg) {
   $line =~ /^\s*(\S+)\s*(.*)/ and $hash{$1} = $2;
 }

 \%hash;
}

sub service_level
{
 @_ == 2 or croak 'usage: $snpp->service_level( LEVEL )';
 my $me = shift;
 my $level = int(shift);

 if($level < 0 || $level > 11)
  {
   $me->set_status(550,"Invalid Service Level");
   return 0;
  }

 $me->_LEVE($level);
}

sub alert
{
 @_ == 1 || @_ == 2 or croak 'usage: $snpp->alert( VALUE )';
 my $me = shift;
 my $value  = (@_ == 1 || shift) ? 1 : 0;

 $me->_ALER($value);
}

sub coverage
{
 @_ == 1 or croak 'usage: $snpp->coverage( AREA )';
 shift->_COVE(@_);
}

sub hold
{
 @_ == 2 || @_ == 3 or croak 'usage: $snpp->hold( TIME [, LOCAL ] )';
 my $me = shift;
 my $time = shift;
 my $local = (shift) ? "" : " +0000";

 my @g = reverse((gmtime($time))[0..5]);
 $g[1] += 1;
 $g[0] %= 100;

 $me->_HOLD( sprintf("%02d%02d%02d%02d%02d%02d%s",@g,$local));
}

sub caller_id
{
 @_ == 2 or croak 'usage: $snpp->caller_id( CALLER_ID )';
 shift->_CALL(@_);
}

sub subject
{
 @_ == 2 or croak 'usage: $snpp->subject( SUBJECT )';
 shift->_SUBJ(@_);
}

sub two_way
{
 @_ == 1 or croak 'usage: $snpp->two_way()';
 shift->_2WAY();
}

sub quit
{
 @_ == 1 or croak 'usage: $snpp->quit()';
 my $snpp = shift;

 $snpp->_QUIT;
 $snpp->close;
}

##
## IO/perl methods
##

sub DESTROY
{
 my $snpp = shift;
 defined(fileno($snpp)) && $snpp->quit
}

##
## Over-ride methods (Net::Cmd)
##

sub debug_text
{
 $_[2] =~ s/^((logi|page)\s+\S+\s+)\S+/$1 xxxx/io;
 $_[2];
}

sub parse_response
{
 return ()
    unless $_[1] =~ s/^(\d\d\d)(.?)//o;
 my($code,$more) = ($1, $2 eq "-");

 $more ||= $code == 214;

 ($code,$more);
}

##
## RFC1861 commands
##

# Level 1

sub _PAGE { shift->command("PAGE", @_)->response()  == CMD_OK }   
sub _MESS { shift->command("MESS", @_)->response()  == CMD_OK }   
sub _RESE { shift->command("RESE")->response()  == CMD_OK }   
sub _SEND { shift->command("SEND")->response()  == CMD_OK }   
sub _QUIT { shift->command("QUIT")->response()  == CMD_OK }   
sub _HELP { shift->command("HELP")->response()  == CMD_OK }   
sub _DATA { shift->command("DATA")->response()  == CMD_MORE }   
sub _SITE { shift->command("SITE",@_) }   

# Level 2

sub _LOGI { shift->command("LOGI", @_)->response()  == CMD_OK }   
sub _LEVE { shift->command("LEVE", @_)->response()  == CMD_OK }   
sub _ALER { shift->command("ALER", @_)->response()  == CMD_OK }   
sub _COVE { shift->command("COVE", @_)->response()  == CMD_OK }   
sub _HOLD { shift->command("HOLD", @_)->response()  == CMD_OK }   
sub _CALL { shift->command("CALL", @_)->response()  == CMD_OK }   
sub _SUBJ { shift->command("SUBJ", @_)->response()  == CMD_OK }   

# NonStandard

sub _XWHO { shift->command("XWHO")->response()  == CMD_OK }   

1;
__END__

=head1 NAME

Net::SNPP - Simple Network Pager Protocol Client

=head1 SYNOPSIS

    use Net::SNPP;
    
    # Constructors
    $snpp = Net::SNPP->new('snpphost');
    $snpp = Net::SNPP->new('snpphost', Timeout => 60);

=head1 NOTE

This module is not complete, yet !

=head1 DESCRIPTION

This module implements a client interface to the SNPP protocol, enabling
a perl5 application to talk to SNPP servers. This documentation assumes
that you are familiar with the SNPP protocol described in RFC1861.

A new Net::SNPP object must be created with the I<new> method. Once
this has been done, all SNPP commands are accessed through this object.

=head1 EXAMPLES

This example will send a pager message in one hour saying "Your lunch is ready"

    #!/usr/local/bin/perl -w
    
    use Net::SNPP;
    
    $snpp = Net::SNPP->new('snpphost');
    
    $snpp->send( Pager   => $some_pager_number,
	         Message => "Your lunch is ready",
	         Alert   => 1,
	         Hold    => time + 3600, # lunch ready in 1 hour :-)
	       ) || die $snpp->message;
    
    $snpp->quit;

=head1 CONSTRUCTOR

=over 4

=item new ( [ HOST, ] [ OPTIONS ] )

This is the constructor for a new Net::SNPP object. C<HOST> is the
name of the remote host to which a SNPP connection is required.

If C<HOST> is not given, then the C<SNPP_Host> specified in C<Net::Config>
will be used.

C<OPTIONS> are passed in a hash like fashion, using key and value pairs.
Possible options are:

B<Timeout> - Maximum time, in seconds, to wait for a response from the
SNPP server (default: 120)

B<Debug> - Enable debugging information


Example:


    $snpp = Net::SNPP->new('snpphost',
			   Debug => 1,
			  );

=head1 METHODS

Unless otherwise stated all methods return either a I<true> or I<false>
value, with I<true> meaning that the operation was a success. When a method
states that it returns a value, failure will be returned as I<undef> or an
empty list.

=over 4

=item reset ()

=item help ()

Request help text from the server. Returns the text or undef upon failure

=item quit ()

Send the QUIT command to the remote SNPP server and close the socket connection.

=back

=head1 EXPORTS

C<Net::SNPP> exports all that C<Net::CMD> exports, plus three more subroutines
that can bu used to compare against the result of C<status>. These are :-
C<CMD_2WAYERROR>, C<CMD_2WAYOK>, and C<CMD_2WAYQUEUED>.

=head1 SEE ALSO

L<Net::Cmd>
RFC1861

=head1 AUTHOR

Graham Barr <gbarr@pobox.com>

=head1 COPYRIGHT

Copyright (c) 1995-1997 Graham Barr. All rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut
WFTP_FILE_END: www_ftp/Net/SNPP.pm
WFTP_FILE_START: www_ftp/Net/Time.pm
# Net::Time.pm
#
# Copyright (c) 1995-1998 Graham Barr <gbarr@pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.

package Net::Time;

use strict;
use vars qw($VERSION @ISA @EXPORT_OK $TIMEOUT);
use Carp;
use IO::Socket;
require Exporter;
use Net::Config;
use IO::Select;

@ISA = qw(Exporter);
@EXPORT_OK = qw(inet_time inet_daytime);

$VERSION = "2.08";

$TIMEOUT = 120;

sub _socket
{
 my($pname,$pnum,$host,$proto,$timeout) = @_;

 $proto ||= 'udp';

 my $port = (getservbyname($pname, $proto))[2] || $pnum;

 my $hosts = defined $host ? [ $host ] : $NetConfig{$pname . '_hosts'};

 my $me;

 foreach $host (@$hosts)
  {
   $me = IO::Socket::INET->new(PeerAddr => $host,
    	    	    	       PeerPort => $port,
    	    	    	       Proto    => $proto
    	    	    	      ) and last;
  }

 return unless $me;

 $me->send("\n")
	if $proto eq 'udp';

 $timeout = $TIMEOUT
	unless defined $timeout;

 IO::Select->new($me)->can_read($timeout)
	? $me
	: undef;
}

sub inet_time
{
 my $s = _socket('time',37,@_) || return undef;
 my $buf = '';
 my $offset = 0 | 0;

 return undef
	unless $s->recv($buf, length(pack("N",0)));

 # unpack, we | 0 to ensure we have an unsigned
 my $time = (unpack("N",$buf))[0] | 0;

 # the time protocol return time in seconds since 1900, convert
 # it to a the required format

 if($^O eq "MacOS") {
   # MacOS return seconds since 1904, 1900 was not a leap year.
   $offset = (4 * 31536000) | 0;
 }
 else {
   # otherwise return seconds since 1972, there were 17 leap years between
   # 1900 and 1972
   $offset =  (70 * 31536000 + 17 * 86400) | 0;
 }

 $time - $offset;
}

sub inet_daytime
{
 my $s = _socket('daytime',13,@_) || return undef;
 my $buf = '';

 $s->recv($buf, 1024) ? $buf
    	              : undef;
}

1;

__END__

=head1 NAME

Net::Time - time and daytime network client interface

=head1 SYNOPSIS

    use Net::Time qw(inet_time inet_daytime);
    
    print inet_time();		# use default host from Net::Config
    print inet_time('localhost');
    print inet_time('localhost', 'tcp');
    
    print inet_daytime();	# use default host from Net::Config
    print inet_daytime('localhost');
    print inet_daytime('localhost', 'tcp');

=head1 DESCRIPTION

C<Net::Time> provides subroutines that obtain the time on a remote machine.

=over 4

=item inet_time ( [HOST [, PROTOCOL [, TIMEOUT]]])

Obtain the time on C<HOST>, or some default host if C<HOST> is not given
or not defined, using the protocol as defined in RFC868. The optional
argument C<PROTOCOL> should define the protocol to use, either C<tcp> or
C<udp>. The result will be a time value in the same units as returned
by time() or I<undef> upon failure.

=item inet_daytime ( [HOST [, PROTOCOL [, TIMEOUT]]])

Obtain the time on C<HOST>, or some default host if C<HOST> is not given
or not defined, using the protocol as defined in RFC867. The optional
argument C<PROTOCOL> should define the protocol to use, either C<tcp> or
C<udp>. The result will be an ASCII string or I<undef> upon failure.

=back

=head1 AUTHOR

Graham Barr <gbarr@pobox.com>

=head1 COPYRIGHT

Copyright (c) 1995-1998 Graham Barr. All rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut
WFTP_FILE_END: www_ftp/Net/Time.pm
WFTP_FILE_START: www_ftp/Net/FTP/A.pm
##
## Package to read/write on ASCII data connections
##

package Net::FTP::A;
use strict;
use vars qw(@ISA $buf $VERSION);
use Carp;

require Net::FTP::dataconn;

@ISA = qw(Net::FTP::dataconn);
$VERSION = "1.13"; # $Id: //depot/libnet/Net/FTP/A.pm#9 $

sub read {
  my    $data 	 = shift;
  local *buf 	 = \$_[0]; shift;
  my    $size 	 = shift || croak 'read($buf,$size,[$offset])';
  my    $timeout = @_ ? shift : $data->timeout;

  if (length(${*$data}) < $size && !${*$data}{'net_ftp_eof'}) {
    my $blksize = ${*$data}{'net_ftp_blksize'};
    $blksize = $size if $size > $blksize;

    my $l = 0;
    my $n;

    READ:
    {
      my $readbuf = defined(${*$data}{'net_ftp_cr'}) ? "\015" : '';

      $data->can_read($timeout) or
	   croak "Timeout";

      if ($n = sysread($data, $readbuf, $blksize, length $readbuf)) {
        ${*$data}{'net_ftp_bytesread'} += $n;
	${*$data}{'net_ftp_cr'} = substr($readbuf,-1) eq "\015"
					? chop($readbuf)
					: undef;
      }
      else {
        return undef
	  unless defined $n;

        ${*$data}{'net_ftp_eof'} = 1;
      }

      $readbuf =~ s/\015\012/\n/sgo;
      ${*$data} .= $readbuf;

      unless (length(${*$data})) {

        redo READ
	  if($n > 0);

        $size = length(${*$data})
          if($n == 0);
      }
    }
  }

  $buf = substr(${*$data},0,$size);
  substr(${*$data},0,$size) = '';

  length $buf;
}

sub write {
  my    $data 	= shift;
  local *buf 	= \$_[0]; shift;
  my    $size 	= shift || croak 'write($buf,$size,[$timeout])';
  my    $timeout = @_ ? shift : $data->timeout;

  $data->can_write($timeout) or
	 croak "Timeout";

  (my $tmp = substr($buf,0,$size)) =~ s/\n/\015\012/sg;

  # If the remote server has closed the connection we will be signal'd
  # when we write. This can happen if the disk on the remote server fills up

  local $SIG{PIPE} = 'IGNORE';

  my $len = length($tmp);
  my $off = 0;
  my $wrote = 0;

  while($len) {
    $off += $wrote;
    $wrote = syswrite($data, substr($tmp,$off), $len);
    return undef
      unless defined($wrote);
    $len -= $wrote;
  }

  $size;
}

1;
WFTP_FILE_END: www_ftp/Net/FTP/A.pm
WFTP_FILE_START: www_ftp/Net/FTP/dataconn.pm
##
## Generic data connection package
##

package Net::FTP::dataconn;

use Carp;
use vars qw(@ISA $timeout);
use Net::Cmd;

@ISA = qw(IO::Socket::INET);

sub reading
{
 my $data = shift;
 ${*$data}{'net_ftp_bytesread'} = 0;
}

sub abort
{
 my $data = shift;
 my $ftp  = ${*$data}{'net_ftp_cmd'};

 # no need to abort if we have finished the xfer
 return $data->close
    if ${*$data}{'net_ftp_eof'};

 # for some reason if we continously open RETR connections and not
 # read a single byte, then abort them after a while the server will
 # close our connection, this prevents the unexpected EOF on the
 # command channel -- GMB
 if(exists ${*$data}{'net_ftp_bytesread'}
	&& (${*$data}{'net_ftp_bytesread'} == 0)) {
   my $buf="";
   my $timeout = $data->timeout;
   $data->can_read($timeout) && sysread($data,$buf,1);
 }

 ${*$data}{'net_ftp_eof'} = 1; # fake

 $ftp->abort; # this will close me
}

sub _close
{
 my $data = shift;
 my $ftp  = ${*$data}{'net_ftp_cmd'};

 $data->SUPER::close();

 delete ${*$ftp}{'net_ftp_dataconn'}
    if exists ${*$ftp}{'net_ftp_dataconn'} &&
        $data == ${*$ftp}{'net_ftp_dataconn'};
}

sub close
{
 my $data = shift;
 my $ftp  = ${*$data}{'net_ftp_cmd'};

 if(exists ${*$data}{'net_ftp_bytesread'} && !${*$data}{'net_ftp_eof'}) {
   my $junk;
   $data->read($junk,1,0);
   return $data->abort unless ${*$data}{'net_ftp_eof'};
 }

 $data->_close;

 $ftp->response() == CMD_OK &&
    $ftp->message =~ /unique file name:\s*(\S*)\s*\)/ &&
    (${*$ftp}{'net_ftp_unique'} = $1);

 $ftp->status == CMD_OK;
}

sub _select
{
 my    $data 	= shift;
 local *timeout = \$_[0]; shift;
 my    $rw 	= shift;

 my($rin,$win);

 return 1 unless $timeout;

 $rin = '';
 vec($rin,fileno($data),1) = 1;

 $win = $rw ? undef : $rin;
 $rin = undef unless $rw;

 my $nfound = select($rin, $win, undef, $timeout);

 croak "select: $!"
	if $nfound < 0;

 return $nfound;
}

sub can_read
{
 my    $data    = shift;
 local *timeout = \$_[0];

 $data->_select($timeout,1);
}

sub can_write
{
 my    $data    = shift;
 local *timeout = \$_[0];

 $data->_select($timeout,0);
}

sub cmd
{
 my $ftp = shift;

 ${*$ftp}{'net_ftp_cmd'};
}

1;
WFTP_FILE_END: www_ftp/Net/FTP/dataconn.pm
WFTP_FILE_START: www_ftp/Net/FTP/E.pm
package Net::FTP::E;

require Net::FTP::I;

@ISA = qw(Net::FTP::I);

1;
WFTP_FILE_END: www_ftp/Net/FTP/E.pm
WFTP_FILE_START: www_ftp/Net/FTP/I.pm
##
## Package to read/write on BINARY data connections
##

package Net::FTP::I;

use vars qw(@ISA $buf $VERSION);
use Carp;

require Net::FTP::dataconn;

@ISA = qw(Net::FTP::dataconn);
$VERSION = "1.08"; # $Id: //depot/libnet/Net/FTP/I.pm#6$

sub read {
  my    $data 	 = shift;
  local *buf 	 = \$_[0]; shift;
  my    $size    = shift || croak 'read($buf,$size,[$timeout])';
  my    $timeout = @_ ? shift : $data->timeout;

  $data->can_read($timeout) or
	 croak "Timeout";

  my($b,$n,$l);
  my $blksize = ${*$data}{'net_ftp_blksize'};
  $blksize = $size if $size > $blksize;

  while(($l = length(${*$data})) < $size) {
   $n += ($b = sysread($data, ${*$data}, $blksize, $l));
   last unless $b;
  }

  $n = $size < ($l = length(${*$data})) ? $size : $l;

  $buf = substr(${*$data},0,$n);
  substr(${*$data},0,$n) = '';

  ${*$data}{'net_ftp_bytesread'} += $n if $n;
  ${*$data}{'net_ftp_eof'} = 1 unless $n;

  $n;
}

sub write {
  my    $data    = shift;
  local *buf     = \$_[0]; shift;
  my    $size    = shift || croak 'write($buf,$size,[$timeout])';
  my    $timeout = @_ ? shift : $data->timeout;

  $data->can_write($timeout) or
	 croak "Timeout";

  # If the remote server has closed the connection we will be signal'd
  # when we write. This can happen if the disk on the remote server fills up

  local $SIG{PIPE} = 'IGNORE';
  my $sent = $size;
  my $off = 0;

  while($sent > 0) {
    my $n = syswrite($data, $buf, $sent,$off);
    return undef unless defined($n);
    $sent -= $n;
    $off += $n;
  }

  $size;
}

1;
WFTP_FILE_END: www_ftp/Net/FTP/I.pm
WFTP_FILE_START: www_ftp/Net/FTP/L.pm
package Net::FTP::L;

require Net::FTP::I;

@ISA = qw(Net::FTP::I);

1;
WFTP_FILE_END: www_ftp/Net/FTP/L.pm