view release on metacpan or  search on metacpan

Ls.pm  view on Meta::CPAN

sub format_mode {
    my $s = ref($_[0]) ? shift : (File::Stat::Ls->new);
    my $mode = shift;
    my %opts = @_;

    my @perms = qw(--- --x -w- -wx r-- r-x rw- rwx);
    my @ftype = qw(. p c ? d ? b ? - ? l ? s ? ? ?);
    $ftype[0] = '';
    my $setids = ($mode & 07000)>>9;
    my @permstrs = @perms[($mode&0700)>>6, ($mode&0070)>>3, $mode&0007];
    my $ftype = $ftype[($mode & 0170000)>>12];
  
    if ($setids) {
      if ($setids & 01) {         # Sticky bit
        $permstrs[2] =~ s/([-x])$/$1 eq 'x' ? 't' : 'T'/e;
      }
      if ($setids & 04) {         # Setuid bit
        $permstrs[0] =~ s/([-x])$/$1 eq 'x' ? 's' : 'S'/e;
      }
      if ($setids & 02) {         # Setgid bit
        $permstrs[1] =~ s/([-x])$/$1 eq 'x' ? 's' : 'S'/e;
      }
    }
  
    join '', $ftype, @permstrs;
}

=head2 ls_stat ($fn)

Input variables:

  $fn - file name
     ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
      $atime,$mtime,$ctime,$blksize,$blocks) = stat($fn);


Variables used or routines called:

  None

How to use:

   my $ls = $self->ls_stat($fn);

Return: the ls string such as one of the followings:

  -r-xr-xr-x   1 root     other         4523 Jul 12 09:49 uniq
  drwxr-xr-x   2 root     other       2048 Jul 12 09:50 bin
  lrwxrwxrwx   1 oracle7  dba           40 Jun 12  2002 linked.pl 
               -> /opt/bin/linked2.pl

=cut

sub ls_stat {
    my $s = ref($_[0]) ? shift : (File::Stat::Ls->new);
    my $fn = shift; 
    my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
        $atime,$mtime,$ctime,$blksize,$blocks) = lstat $fn;
    my @a = lstat $fn; 
    my $dft = "%b %d  %Y";
    my $ud = getpwuid($uid);
    my $gd = getgrgid($gid); 
    my $fm = format_mode($mode); 
    my $mt = strftime $dft,localtime $mtime; 
    my $fmt = "%10s %3d %7s %4s %12d %12s %-26s\n";  
    return sprintf $fmt, $fm,$nlink,$ud,$gd,$size,$mt,$fn;
}

=head2 stat_attr ($fn, $typ)

Input variables:

  $fn - file name for getting stat attributes
     ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
      $atime,$mtime,$ctime,$blksize,$blocks) = stat($fn);
  $typ - what type of object that you want it to return.
    The default is to return a hash containing filename, longname,
    and a hash ref with all the element from stat.
    SFTP - to return a Net::SFTP::Attributes object 
    


Variables used or routines called:

  ls_stat

How to use:

   my $hr = $self->stat_attr($fn);  # get hash ref
   my %h  = $self->stat_attr($fn);  # get hash

Return: $hr or %h where the hash elements are depended on the type.
The default is to get a hash array with the following elements:

  filename - file name
  longname - the ls_stat string for the file
  a        - the attributes of the file with the following elements:
             dev,ino,mode,nlink,uid,gid,rdev,size,atime,mtime,
             ctime,blksize,blocks

If the type is SFTP, then it will only return a 
I<Net::SFTP::Attributes> object with the following elements: 

  flags,perm,uid,gid,size,atime,mtime

=cut

sub stat_attr {
    my $s = ref($_[0]) ? shift : (File::Stat::Ls->new);
    my ($fn,$typ) = @_; 
    croak "ERR: no file name for stat_attr.\n" if ! $fn;
    return undef if ! $fn;
    my $vs  = 'dev,ino,mode,nlink,uid,gid,rdev,size,atime,mtime,';
       $vs .= 'ctime,blksize,blocks';
    my $v1  = 'flags,perm,uid,gid,size,atime,mtime';
    my $ls = ls_stat $fn;  chomp $ls;
    my @a = (); my @v = (); 
    my $attr = {};
    if ($typ && $typ =~ /SFTP/i) {
        @v = split /,/, $v1; 
        @a = (stat($fn))[1,2,4,5,7,8,9];