view release on metacpan or  search on metacpan

lib/Secure/File.pm  view on Meta::CPAN

        if ($mode =~ /^\d+$/) {
            defined $perms or $perms = 0666;
            $x=sysopen($self, $file, $mode, $perms);
        }
	else
	{
           $file = IO::Handle::_open_mode_string($mode) . " $file\0";
   	   $x = open($self, $file);
	}
    }
   else
     {
	$x =open($self, $mode.$file);
     }

   carp "Secure::File: Couldn't open $file" unless $x;
   if ($mode =~ /^[>\sw]+$/ || ($mode =~ /^\d+$/ && $mode & O_WRONLY) ||
	(!@S && ($mode =~ /w/ || ($mode =~ /^\d+$/ && $mode & O_RDWR))))
     {
	return $x;
     }
   return 0 unless @S;
   if ($self->handle_check(@S))
     {
        return $self;
     }
   $self->close();
   return 0;
}

sub open_precheck($$)
{
   my $name=shift;
   if ($name =~ /^<\s*([^\s]+)$/)
        {
	   r_check($1);
	}
   elsif ($name =~ /^>\s*([^\s]+)$/)
        {
	   w_check($1);
        }
   elsif (@_ && defined $_[0] && (($_[0]=~/^\d+$/ && ($_[0] & O_WRONLY))
		|| lc($_[0]) eq 'w'))
        {
	   w_check($name);
	}
   elsif (defined $_[0] && (($_[0] =~ /r/i && $_[0] =~ /w/i) ||
			    ($_[0] =~ /^\d+$/ && ($_[0] & O_RDWR))))
        {
	   rw_check($name);
        }
   else
        {
	   r_check($name);
        }
}

sub r_check
{
    #Check to see if the real user has read privileges
    my @S=stat($_[0]);
    if (!@S) {return;}
    return @S if -R _;
}

sub w_check
{
    #Check to see if the real user has write privileges
    my @S=stat($_[0]);
    if (!@S)
      {
         if ($_[0] =~ /^(.*)\/[^\/]+$/)
	   {
	      @S=stat($1);
	      return @S if -W _;
	   }
         return;
      }
    return @S if -W _;
}

sub rw_check
{
    #Check to see if the real user has read/write privileges
    my @S=stat($_[0]);
    if (!@S) {return;}
    return undef if !-R _;
    return @S    if  -W _;
}

sub handle_check
{
   #Check to be sure that the inode has not changed!
   my $Handle = shift;

   #Get the information on the file
   my @S2 = $Handle->stat;

   #If the file doesn't exist, return false;
   return 0 unless @S2;

   #Return true if and only if the file has the same ID:
   # That is: its dev, rdev, inode all match
   if ($_[0] != $S2[0] || $_[1] != $S2[1] || $_[6] != $S2[6]) {return 0;}
   1;
}