File Coverage

blib/lib/Grips/Gripsrc.pm

Criterion	Covered	Total	%
statement	12	87	13.7
branch	0	54	0.0
condition	0	23	0.0
subroutine	4	10	40.0
pod	5	5	100.0
total	21	179	11.7

# Grips::Gripsrc.pm
#
# Copyright (c) 2002 DIMDI . All rights reserved.
#
# This module is free software; you can redistribute it and/or modify it under
# the same terms as Perl itself, i.e. under the terms of either the GNU General
# Public License or the Artistic License, as specified in the F file.
package Grips::Gripsrc;

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

$VERSION = "0.01"; # $Id: Gripsrc.pm,v 1.2 2003-02-04 12:19:08 ahmed Exp $

my %gripsrc = ();

sub _readrc
{
 my $host = shift;
 my($home,$file);

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

 my $fh;
 local $_;

 $gripsrc{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'
     || $^O =~ /^cygwin/)
  {
   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 {};
   	 $gripsrc{default} = [$mach];

         next TOKEN;
        }

       last TOKEN
            unless @tok > 1;

       $tok = shift(@tok);

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

         $gripsrc{$host} = []
            unless exists($gripsrc{$host});
         push(@{$gripsrc{$host}}, $mach);
        }
       elsif($tok =~ /^(id|user|pwd)$/)
        {
         next TOKEN unless $mach;
         my $value = shift @tok;
         # Following line added by rmerrell to remove '/' escape char in .gripsrc
         $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,$id) = @_;

 _readrc()
    unless exists $gripsrc{default};

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

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

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

 return undef;
}

sub id
{
 my $me = shift;

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

sub pwd
{
 my $me = shift;

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

sub user
{
 my $me = shift;

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

sub iup
{
 my $me = shift;
 ($me->id, $me->user, $me->pwd);
}

1;

__END__