This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
58f066363d88ead197caaaff1c5fcb0baeef192e
[perl5.git] / lib / Net / Netrc.pm
1 package Net::Netrc;
2
3 use Carp;
4 use strict;
5
6 my %netrc = ();
7
8 sub _readrc {
9  my $host = shift;
10  my $file = (getpwuid($>))[7] . "/.netrc";
11  my($login,$pass,$acct) = (undef,undef,undef);
12  local *NETRC;
13  local $_;
14
15  $netrc{default} = undef;
16
17  my @stat = stat($file);
18
19  if(@stat)
20   {
21    if($stat[2] & 077)
22     {
23      carp "Bad permissions: $file";
24      return ();
25     }
26    if($stat[4] != $<)
27     {
28      carp "Not owner: $file";
29      return ();
30     }
31   }
32
33  if(open(NETRC,$file))
34   {
35    my($mach,$macdef,$tok,@tok) = (0,0);
36
37    while(<NETRC>) 
38     {
39      undef $macdef if /\A\n\Z/;
40
41      if($macdef)
42       {
43        push(@$macdef,$_);
44        next;
45       }
46
47      push(@tok, split(/[\s\n]+/, $_));
48
49 TOKEN:
50      while(@tok)
51       {
52        if($tok[0] eq "default")
53         {
54          shift(@tok);
55          $mach = $netrc{default} = {};
56
57          next TOKEN;
58         }
59
60        last TOKEN unless @tok > 1;
61        $tok = shift(@tok);
62
63        if($tok eq "machine")
64         {
65          my $host = shift @tok;
66          $mach = $netrc{$host} = {};
67         }
68        elsif($tok =~ /^(login|password|account)$/)
69         {
70          next TOKEN unless $mach;
71          my $value = shift @tok;
72          $mach->{$1} = $value;
73         }
74        elsif($tok eq "macdef")
75         {
76          next TOKEN unless $mach;
77          my $value = shift @tok;
78          $mach->{macdef} = {} unless exists $mach->{macdef};
79          $macdef = $mach->{machdef}{$value} = [];
80         }
81       }
82     }
83    close(NETRC);
84   }
85 }
86
87 sub lookup {
88  my $pkg = shift;
89  my $mach = shift;
90
91  _readrc() unless exists $netrc{default};
92
93  return bless \$mach if exists $netrc{$mach};
94
95  return bless \("default") if defined $netrc{default};
96
97  return undef;
98 }
99
100 sub login {
101  my $me = shift;
102  $me = $netrc{$$me};
103  exists $me->{login} ? $me->{login} : undef;
104 }
105
106 sub account {
107  my $me = shift;
108  $me = $netrc{$$me};
109  exists $me->{account} ? $me->{account} : undef;
110 }
111
112 sub password {
113  my $me = shift;
114  $me = $netrc{$$me};
115  exists $me->{password} ? $me->{password} : undef;
116 }
117
118 sub lpa {
119  my $me = shift;
120  ($me->login, $me->password, $me->account);
121 }
122
123 1;