view release on metacpan or  search on metacpan

share/ppt/ls.pl  view on Meta::CPAN

use File::stat;
use Getopt::Std;
use File::Spec;

# ------ partial inline of Stat::lsMode v0.50 code
# (see http://www.plover.com/~mjd/perl/lsMode/
# for the complete module)

#
#
# Stat::lsMode
#
# Copyright 1998 M-J. Dominus
# (mjd-perl-lsmode@plover.com)
#
# You may distribute this module under the same terms as Perl itself.

my @perms = qw(--- --x -w- -wx r-- r-x rw- rwx);
my @ftype = qw(. p c ? d ? b ? - ? l ? s ? ? ?);
$ftype[0] = '';

sub format_mode {
  my $mode = shift;
  my %opts = @_;

  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;
}

# ------ define variables
my $Arg = "";		# file/directory name argument from @ARGV
my $ArgCount = 0;	# file/directory argument count
my $Attributes = "";	# File::stat from STDOUT (isatty() kludge)
my %Attributes = ();	# File::stat directory entry attributes
my %DirEntries = ();	# hash of dir entries and stat attributes
my $Getgrgid = "";	# getgrgid() for this platform
my $Getpwuid = "";	# getpwuid() for this platform
my @Dirs = ();		# directories in ARGV
my @Files = ();		# non-directories in ARGV
my $First = 1;		# first directory entry on command line
my $Maxlen = 1;		# longest string we've seen
my $Now = time;		# time we were invoked
my %Options = ();	# option/flag arguments
my $SixMonths =		# long listing time if < 6 months, else year
 60*60*24*(365/2);
my $VERSION = '0.70';	# because we're V7-compatible :)
my $WinSize = "\0" x 8;	# window size buffer
my $TIOCGWINSZ =	# get window size via ioctl()
 0x40087468;		# should be require sys/ioctl.pl,
			# but that won't exist on all platforms
my $WinCols = 0;	# window columns of output
my $WinRows = 0;	# window rows of output
my $Xpixel = 0;		# window start X
my $Ypixel = 0;		# window start Y

# ------ compensate for lack of getpwuid/getgrgid on some platforms
eval { my $dummy = ""; $dummy = (getpwuid(0))[0] };
if ($@) {
	$Getpwuid = sub { return ($_[0], 0); };
	$Getgrgid = sub { return ($_[0], 0); };
} else {
	$Getpwuid = sub { return getpwuid($_[0]); };
	$Getgrgid = sub { return getgrgid($_[0]); };
}

# ------ functions

# ------ get directory entries
sub DirEntries {
	my $Options = shift;	# option arguments hashref
	local *DH;		# directory handle
	my %Attributes = ();	# entry/attributes hash
	my @Entries = ();	# entries in original order
	my $Name = "";		# entry name

	if (!opendir(DH, $_[0]) || exists($Options{'d'})) {
		if (-e $_[0]) {
			closedir(DH) if (defined(DH));
			push(@Entries, $_[0]);
			$Attributes{$_[0]} = stat($_[0]);
			push(@Entries, \%Attributes);
			return @Entries;
		}
		print "pls: can't access '$_[0]': $!\n";
		return ();
	}
	while ($Name = readdir(DH)) {
		next if (!exists($Options->{'a'}) &&
		 $Name =~ m/^\./o);
		push(@Entries, $Name);
		$Attributes{$Name} = stat( File::Spec->catfile( $_[0], $Name ) );
	}
	closedir(DH);

	# ------ return list with %Attributes ref at end
	push(@Entries, \%Attributes);
	return @Entries;
}

# ------ format directory entry
sub EntryFormat {
	my $Options = shift;	# ls option arguments
	my $Attributes = shift;	# entry attributes hashref
	my $Entry = shift;	# directory entry name
	my $Blocks = 0;		# block size when otherwise unknown