Update Socket to CPAN version 2.016
[perl.git] / cpan / libnet / t / netrc.t
1 #!./perl
2
3 BEGIN {
4     if ($ENV{PERL_CORE}) {
5         chdir 't' if -d 't';
6         @INC = '../lib';
7     }
8     if (!eval "require Socket") {
9         print "1..0 # no Socket\n"; exit 0;
10     }
11     if (ord('A') == 193 && !eval "require Convert::EBCDIC") {
12         print "1..0 # EBCDIC but no Convert::EBCDIC\n"; exit 0;
13     }
14 }
15
16 use strict;
17
18 use Cwd;
19 print "1..20\n";
20
21 # for testing _readrc
22 $ENV{HOME} = Cwd::cwd();
23
24 # avoid "used only once" warning
25 local (*CORE::GLOBAL::getpwuid, *CORE::GLOBAL::stat);
26
27 *CORE::GLOBAL::getpwuid = sub ($) {
28         ((undef) x 7, Cwd::cwd());
29 };
30
31 # for testing _readrc
32 my @stat;
33 *CORE::GLOBAL::stat = sub (*) {
34         return @stat;
35 };
36
37 # for testing _readrc
38 $INC{'FileHandle.pm'} = 1;
39
40 (my $libnet_t = __FILE__) =~ s/\w+.t$/libnet_t.pl/;
41 require $libnet_t;
42
43 # now that the tricks are out of the way...
44 eval { require Net::Netrc; };
45 ok( !$@, 'should be able to require() Net::Netrc safely' );
46 ok( exists $INC{'Net/Netrc.pm'}, 'should be able to use Net::Netrc' );
47 $Net::Netrc::TESTING=$Net::Netrc::TESTING=1;
48
49 SKIP: {
50         skip('incompatible stat() handling for OS', 4), next SKIP 
51                 if ($^O =~ /os2|win32|macos|cygwin/i or $] < 5.005);
52
53         my $warn;
54         local $SIG{__WARN__} = sub {
55                 $warn = shift;
56         };
57
58         # add write access for group/other
59         $stat[2] = 077;
60         ok( !defined(Net::Netrc::_readrc()),
61                 '_readrc() should not read world-writable file' );
62         ok( scalar($warn =~ /^Bad permissions:/),
63                 '... and should warn about it' );
64
65         # the owner field should still not match
66         $stat[2] = 0;
67
68         if ($<) { 
69           ok( !defined(Net::Netrc::_readrc()), 
70               '_readrc() should not read file owned by someone else' ); 
71           ok( scalar($warn =~ /^Not owner:/),
72                 '... and should warn about it' ); 
73         } else { 
74           skip("testing as root",2);
75         } 
76 }
77
78 # this field must now match, to avoid the last-tested warning
79 $stat[4] = $<;
80
81 # this curious mix of spaces and quotes tests a regex at line 79 (version 2.11)
82 FileHandle::set_lines(split(/\n/, <<LINES));
83 macdef   bar
84 login    baz
85 machine  "foo"
86 login    nigol "password" drowssap
87 machine  foo "login" l2
88 password p2
89 account  tnuocca
90 default  login "baz" password p2
91 default  "login" baz password p3
92 macdef
93 LINES
94
95 # having set several lines and the uid, this should succeed
96 is( Net::Netrc::_readrc(), 1, '_readrc() should succeed now' );
97
98 # on 'foo', the login is 'nigol'
99 is( Net::Netrc->lookup('foo')->{login}, 'nigol', 
100         'lookup() should find value by host name' );
101
102 # on 'foo' with login 'l2', the password is 'p2'
103 is( Net::Netrc->lookup('foo', 'l2')->{password}, 'p2',
104         'lookup() should find value by hostname and login name' );
105
106 # the default password is 'p3', as later declarations have priority
107 is( Net::Netrc->lookup()->{password}, 'p3', 
108         'lookup() should find default value' );
109
110 # lookup() ignores the login parameter when using default data
111 is( Net::Netrc->lookup('default', 'baz')->{password}, 'p3',
112         'lookup() should ignore passed login when searching default' );
113
114 # lookup() goes to default data if hostname cannot be found in config data 
115 is( Net::Netrc->lookup('abadname')->{login}, 'baz',
116         'lookup() should use default for unknown machine name' );
117
118 # now test these accessors
119 my $instance = bless({}, 'Net::Netrc');
120 for my $accessor (qw( login account password )) {
121         is( $instance->$accessor(), undef, 
122                 "$accessor() should return undef if $accessor is not set" );
123         $instance->{$accessor} = $accessor;
124         is( $instance->$accessor(), $accessor,
125                 "$accessor() should return value when $accessor is set" );
126 }
127
128 # and the three-for-one accessor
129 is( scalar( () = $instance->lpa()), 3, 
130         'lpa() should return login, password, account');
131 is( join(' ', $instance->lpa), 'login password account', 
132         'lpa() should return appropriate values for l, p, and a' );
133
134 package FileHandle;
135
136 sub new {
137         tie *FH, 'FileHandle', @_;
138         bless \*FH, $_[0];
139 }
140
141 sub TIEHANDLE {
142         my ($class, $file, $mode) = @_[0,2,3];
143         bless({ file => $file, mode => $mode }, $class);
144 }
145
146 my @lines;
147 sub set_lines {
148         @lines = @_;
149 }
150
151 sub READLINE {
152         shift @lines;
153 }
154
155 sub close { 1 }
156