[not yet sent to p5p; comments welcome]
Is this valuable for anyone? I could probably turn something like this into an
article for perl.com or the Perl Journal or even use.perl, if anyone could
sweet-talk an editor or thinks gonzo testing ought to be promoted.
Schwern thinks it's clever, so it can't be all bad.
-- c
--- ~MANIFEST Sun Oct 21 14:36:07 2001
+++ MANIFEST Sun Oct 21 14:36:23 2001
@@ -1087,6 +1087,7 @@
lib/Net/netent.pm By-name interface to Perl's builtin getnet*
lib/Net/netent.t See if Net::netent works
lib/Net/Netrc.pm libnet
+lib/Net/Netrc.t See if Net::Netrc works
lib/Net/NNTP.pm libnet
lib/Net/Ping.pm Hello, anybody home?
lib/Net/POP3.pm libnet
--- /dev/null Thu Aug 30 03:54:37 2001
+++ lib/Net/Netrc.t Sun Oct 21 14:35:50 2001
@@ -0,0 +1,130 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use strict;
+use Cwd;
+use Test::More tests => 19;
+
+# for testing _readrc
+$ENV{HOME} = Cwd::cwd();
+
+local *CORE::GLOBAL::getpwuid = sub ($) {
+ ((undef) x 7, Cwd::cwd());
+};
+
+# for testing _readrc
+my @stat;
+local *CORE::GLOBAL::stat = sub (*) {
+ return @stat;
+};
+
+# for testing _readrc
+$INC{'FileHandle.pm'} = 1;
+
+# now that the tricks are out of the way...
+use_ok( 'Net::Netrc' );
+
+SKIP: {
+ skip('incompatible stat() handling for OS', 4)
+ if ($^O =~ /os2|win32|macos|cygwin/i);
+
+ my $warn;
+ local $SIG{__WARN__} = sub {
+ $warn = shift;
+ };
+
+ # add write access for group/other
+ $stat[2] = 077;
+ is( Net::Netrc::_readrc(), undef,
+ '_readrc() should not read world-writable file' );
+ like( $warn, qr/^Bad permissions/, '... and should warn about it' );
+
+ # the owner field should still not match
+ $stat[2] = 0;
+ is( Net::Netrc::_readrc(), undef,
+ '_readrc() should not read file owned by someone else' );
+ like( $warn, qr/^Not owner/, '... and should warn about it' );
+}
+
+# this field must now match, to avoid the last-tested warning
+$stat[4] = $<;
+
+# this curious mix of spaces and quotes tests a regex at line 79 (version 2.11)
+FileHandle::set_lines(split(/\n/, <<LINES));
+macdef bar
+login baz
+ machine "foo"
+login nigol "password" drowssap
+machine foo "login" l2
+ password p2
+account tnuocca
+default login "baz" password p2
+default "login" baz password p3
+macdef
+LINES
+
+# having set several lines and the uid, this should succeed
+is( Net::Netrc::_readrc(), 1, '_readrc() should succeed now' );
+
+# on 'foo', the login is 'nigol'
+is( Net::Netrc->lookup('foo')->{login}, 'nigol',
+ 'lookup() should find value by host name' );
+
+# on 'foo' with login 'l2', the password is 'p2'
+is( Net::Netrc->lookup('foo', 'l2')->{password}, 'p2',
+ 'lookup() should find value by hostname and login name' );
+
+# the default password is 'p3', as later declarations have priority
+is( Net::Netrc->lookup()->{password}, 'p3',
+ 'lookup() should find default value' );
+
+# lookup() ignores the login parameter when using default data
+is( Net::Netrc->lookup('default', 'baz')->{password}, 'p3',
+ 'lookup() should ignore passed login when searching default' );
+
+# lookup() goes to default data if hostname cannot be found in config data
+is( Net::Netrc->lookup('abadname')->{login}, 'baz',
+ 'lookup() should use default for unknown machine name' );
+
+# now test these accessors
+my $instance = bless({}, 'Net::Netrc');
+for my $accessor (qw( login account password )) {
+ is( $instance->$accessor(), undef,
+ "$accessor() should return undef if $accessor is not set" );
+ $instance->{$accessor} = $accessor;
+ is( $instance->$accessor(), $accessor,
+ "$accessor() should return value when $accessor is set" );
+}
+
+# and the three-for-one accessor
+is( scalar( () = $instance->lpa()), 3,
+ 'lpa() should return login, password, account');
+is( join(' ', $instance->lpa), 'login password account',
+ 'lpa() should return appropriate values for l, p, and a' );
+
+package FileHandle;
+
+sub new {
+ tie *FH, 'FileHandle', @_;
+ return \*FH;
+}
+
+sub TIEHANDLE {
+ my ($class, undef, $file, $mode) = @_;
+ bless({ file => $file, mode => $mode }, $class);
+}
+
+my @lines;
+sub set_lines {
+ @lines = @_;
+}
+
+sub READLINE {
+ shift @lines;
+}
+
+sub close { 1 }
