ppt
view release on metacpan or search on metacpan
# Parse and stash away -n switch, if provided
if ($#ARGV >= 0 && $ARGV[0] eq '-n') {
shift (@ARGV);
$~ = "format_n";
}
# Use system mailbox if none was specified on the command line
if ( $#ARGV < 0 ) {
if ( ! ($user = getlogin)) {
@a = getpwuid($<);
$user = $a[0];
}
if ( -r "/var/spool/mail/$user" ) { # Modern systems
@ARGV = ("/var/spool/mail/$user");
}
elsif ( -r "/usr/mail/$user" ) { # System V
@ARGV = ("/usr/mail/$user");
}
elsif ( -r "/usr/spool/mail" ) { # BSD
@ARGV = ("/usr/spool/mail/$user");
$matched = 0;
@errors = ();
# check for and do tilde expansion
if ( /^\~([^${dirsep}]*)/ ) {
my $usr = $1;
my $usrdir = (length $usr)
? (getpwnam($usr))[7]
: (defined $ENV{HOME} ? $ENV{HOME}
: (getpwuid($<))[7]);
$usrdir && s/^\~\Q$usr\E/$usrdir/ && $usr
or push @errors, "Unknown user: $usr";
}
# If there's no wildcards, just return it
return $_ unless /(?:^|[^\\])[*?\[\]{}]/;
# Make the glob into a regexp
# escape + , and |
s/([+.|])/\\$1/g;
&help if ( $opt_h );
if ( ($opt_G + $opt_g + $opt_p + $opt_u) > 1 ) {
print STDERR "You may only choose one of -G, -g, -p, or -u. Doh!\n\n";
&help;
}
my($user,$pw,$uid,$gid,$tp);
if ( @ARGV ) { # user specified
($user,$pw,$uid,$gid) = getpwnam $ARGV[0];
($user,$pw,$uid,$gid) = getpwuid $ARGV[0] unless ( $uid );
die "id: $ARGV[0]: No such user\n" unless ( $uid );
}
if ( $opt_u ) { # print uid
$tp = ($uid)?$uid:($opt_r)?$<:$>;
$tp = scalar getpwuid $tp || $tp if ( $opt_n );
}
elsif ( $opt_g ) { # print gid
$tp = ($gid)?$gid:(split(/\s+/,($opt_r)?$(:$)))[0];
$tp = scalar getgrgid $tp || $tp if ( $opt_n );
}
elsif ( $opt_p ) { # human-readable form (names when possible, etc.)
my($rgid,@rgids);
if ( $user ) {
$tp.="uid $user\n";
$tp.="rgid $gid\n";
@rgids=($gid);
while ( my($name,$pw,$gid,$members) = getgrent ) {
push(@rgids,$gid) if ( grep($_ eq $user,split(/\s+/,$members)) );
}
}
else {
my($login) = getlogin || die "getlogin failed!";
$tp.="login $login\n" if ( $login ne scalar getpwuid $< );
my($uid) = scalar getpwuid $< || $<;
$tp.="uid $uid\n";
my($euid) = scalar getpwuid $> || $>;
$tp.="euid $euid\n" if ( $< != $> );
($rgid,@rgids)=split(/\s+/,$();
my($egid)=split(/\s+/,$));
my($nrgid) = scalar getgrgid $rgid || $rgid;
my($negid) = scalar getgrgid $egid || $egid;
$tp.="rgid $nrgid\n";
$tp.="egid $negid\n" if ( $rgid != $egid );
}
my(%done);
@rgids=($gid);
while ( my($name,$pw,$gid,$members) = getgrent ) {
push(@rgids,$gid) if ( grep($_ eq $user,split(/\s+/,$members)) );
}
$nruid = $user;
$nrgid = scalar getgrgid $gid;
}
else {
($rgid,@rgids)=split(/\s+/,$();
$egid = (split(/\s+/,$)))[0];
$nruid = scalar getpwuid $<;
$neuid = scalar getpwuid $>;
$nrgid = scalar getgrgid $rgid;
$negid = scalar getgrgid $egid;
}
$tp=join("=","uid",($user)?$uid:$<);
$tp.=($nruid)?"($nruid) ":" ";
if ( !($user) && ($< != $>) ) {
$tp.="euid=$>";
$tp.=($neuid)?"($neuid) ":" ";
local $main::oterm = $main::term->getlflag();
local $main::echo = &POSIX::ECHO;
local $main::noecho = $main::oterm & ~$main::echo;
$| = 1; # Make our pipes piping hot!
my $key;
my $again;
if ( $Password )
{
$key = (getpwuid($<))[1];
}
else
{
print "Key: ";
noecho();
$key = <STDIN>;
echo();
print "\n";
chomp $key;
}
sub usage
{
print STDERR "usage: lock [-n] [-p] [-t timeout]\n";
}
sub code
{
my $word = shift;
my $pwd = (getpwuid($<))[1];
my $salt = substr($pwd,0,2);
return crypt($word,$salt);
}
# upon interupt
# lock: type in the unlock key.
sub handler
{
my $sig = shift;
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 $PathSep = "/"; # path separator
# (someone might want to patch this via
# File::Spec...)
my $SixMonths = # long listing time if < 6 months, else year
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
When used with B<-s>, list file/directory size in 1024-byte blocks.
=item -l
Long format listing of mode -- # of links, owner name, group name,
size in bytes, time of last modification, and name.
=item -n
List numeric uid and gid (default on platforms without getpwuid()).
=item -r
Reverse sorting order.
=item -s
List file/directory size in 512-byte blocks. (May not mean much
on non-Unix systems.)
}
# Work quietly.
local $SIG{__WARN__} = sub {} if $opts{'q'};
# Header info.
my $date = localtime;
my $cwd = cwd;
my $user = $opts{'s'} || do {
require Sys::Hostname;
(getlogin || getpwuid($<) || $ENV{USER} || $ENV{LOGNAME} || 'nobody')
. '@'
. Sys::Hostname::hostname();
};
# Header.
print $0 eq 'shar' ? <<INTRO_SHAR : <<INTRO_PAR;
#!/bin/sh
# This is a shell archive (produced by par $VERSION).
# To extract the files from this archive, save it to some FILE, remove
# everything before the '#!/bin/sh' line above, then type 'sh FILE'.
{
flock(SCORE, LOCK_UN);
close(SCORE);
return;
}
my($i, $count);
$uid = $<;
$score = $Arena{'PLAYER'}{'SCORE'};
$name = getpwuid($uid) || '???';
unshift(@{$High_Scores{$score}}, [ $uid, $score, $name ]);
# Clear and rewind
truncate(SCORE, 0);
seek(SCORE, 0, 0);
$i = 1;
$count = 0;
html/commands/from/from.jv view on Meta::CPAN
# Parse and stash away -n switch, if provided
if ($#ARGV >= 0 && $ARGV[0] eq '-n') {
shift (@ARGV);
$~ = "format_n";
}
# Use system mailbox if none was specified on the command line
if ( $#ARGV < 0 ) {
if ( ! ($user = getlogin)) {
@a = getpwuid($<);
$user = $a[0];
}
if ( -r "/var/spool/mail/$user" ) { # Modern systems
@ARGV = ("/var/spool/mail/$user");
}
elsif ( -r "/usr/mail/$user" ) { # System V
@ARGV = ("/usr/mail/$user");
}
elsif ( -r "/usr/spool/mail" ) { # BSD
@ARGV = ("/usr/spool/mail/$user");
html/commands/glob/glob.bradapp view on Meta::CPAN
$matched = 0;
@errors = ();
# check for and do tilde expansion
if ( /^\~([^${dirsep}]*)/ ) {
my $usr = $1;
my $usrdir = (length $usr)
? (getpwnam($usr))[7]
: (defined $ENV{HOME} ? $ENV{HOME}
: (getpwuid($<))[7]);
$usrdir && s/^\~\Q$usr\E/$usrdir/ && $usr
or push @errors, "Unknown user: $usr";
}
# If there's no wildcards, just return it
return $_ unless /(?:^|[^\\])[*?\[\]{}]/;
# Make the glob into a regexp
# escape + , and |
s/([+.|])/\\$1/g;
html/commands/id/id.theo view on Meta::CPAN
&help if ( $opt_h );
if ( ($opt_G + $opt_g + $opt_p + $opt_u) > 1 ) {
print STDERR "You may only choose one of -G, -g, -p, or -u. Doh!\n\n";
&help;
}
my($user,$pw,$uid,$gid,$tp);
if ( @ARGV ) { # user specified
($user,$pw,$uid,$gid) = getpwnam $ARGV[0];
($user,$pw,$uid,$gid) = getpwuid $ARGV[0] unless ( $uid );
die "id: $ARGV[0]: No such user\n" unless ( $uid );
}
if ( $opt_u ) { # print uid
$tp = ($uid)?$uid:($opt_r)?$<:$>;
$tp = scalar getpwuid $tp || $tp if ( $opt_n );
}
elsif ( $opt_g ) { # print gid
$tp = ($gid)?$gid:(split(/\s+/,($opt_r)?$(:$)))[0];
$tp = scalar getgrgid $tp || $tp if ( $opt_n );
}
elsif ( $opt_p ) { # human-readable form (names when possible, etc.)
my($rgid,@rgids);
if ( $user ) {
$tp.="uid $user\n";
$tp.="rgid $gid\n";
@rgids=($gid);
while ( my($name,$pw,$gid,$members) = getgrent ) {
push(@rgids,$gid) if ( grep($_ eq $user,split(/\s+/,$members)) );
}
}
else {
my($login) = getlogin || die "getlogin failed!";
$tp.="login $login\n" if ( $login ne scalar getpwuid $< );
my($uid) = scalar getpwuid $< || $<;
$tp.="uid $uid\n";
my($euid) = scalar getpwuid $> || $>;
$tp.="euid $euid\n" if ( $< != $> );
($rgid,@rgids)=split(/\s+/,$();
my($egid)=split(/\s+/,$));
my($nrgid) = scalar getgrgid $rgid || $rgid;
my($negid) = scalar getgrgid $egid || $egid;
$tp.="rgid $nrgid\n";
$tp.="egid $negid\n" if ( $rgid != $egid );
}
my(%done);
html/commands/id/id.theo view on Meta::CPAN
@rgids=($gid);
while ( my($name,$pw,$gid,$members) = getgrent ) {
push(@rgids,$gid) if ( grep($_ eq $user,split(/\s+/,$members)) );
}
$nruid = $user;
$nrgid = scalar getgrgid $gid;
}
else {
($rgid,@rgids)=split(/\s+/,$();
$egid = (split(/\s+/,$)))[0];
$nruid = scalar getpwuid $<;
$neuid = scalar getpwuid $>;
$nrgid = scalar getgrgid $rgid;
$negid = scalar getgrgid $egid;
}
$tp=join("=","uid",($user)?$uid:$<);
$tp.=($nruid)?"($nruid) ":" ";
if ( !($user) && ($< != $>) ) {
$tp.="euid=$>";
$tp.=($neuid)?"($neuid) ":" ";
html/commands/lock/lock.atkins view on Meta::CPAN
local $main::oterm = $main::term->getlflag();
local $main::echo = &POSIX::ECHO;
local $main::noecho = $main::oterm & ~$main::echo;
$| = 1; # Make our pipes piping hot!
my $key;
my $again;
if ( $Password )
{
$key = (getpwuid($<))[1];
}
else
{
print "Key: ";
noecho();
$key = <STDIN>;
echo();
print "\n";
chomp $key;
html/commands/lock/lock.atkins view on Meta::CPAN
}
sub usage
{
print STDERR "usage: lock [-n] [-p] [-t timeout]\n";
}
sub code
{
my $word = shift;
my $pwd = (getpwuid($<))[1];
my $salt = substr($pwd,0,2);
return crypt($word,$salt);
}
# upon interupt
# lock: type in the unlock key.
sub handler
{
my $sig = shift;
html/commands/ls/ls.fisherm view on Meta::CPAN
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 $PathSep = "/"; # path separator
# (someone might want to patch this via
# File::Spec...)
my $SixMonths = # long listing time if < 6 months, else year
html/commands/ls/ls.fisherm view on Meta::CPAN
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
html/commands/ls/ls.fisherm view on Meta::CPAN
When used with B<-s>, list file/directory size in 1024-byte blocks.
=item -l
Long format listing of mode -- # of links, owner name, group name,
size in bytes, time of last modification, and name.
=item -n
List numeric uid and gid (default on platforms without getpwuid()).
=item -r
Reverse sorting order.
=item -s
List file/directory size in 512-byte blocks. (May not mean much
on non-Unix systems.)
html/commands/ls/ls.fisherm.html view on Meta::CPAN
<dd>Long format listing of mode -- # of links,
owner name,
group name,
size in bytes,
time of last modification,
and name.</dd><p class="pad"></p>
<dt><a name="-n"
>-n</a></dt><p class="pad"></p>
<dd>List numeric uid and gid (default on platforms without getpwuid()).</dd><p class="pad"></p>
<dt><a name="-r"
>-r</a></dt><p class="pad"></p>
<dd>Reverse sorting order.</dd><p class="pad"></p>
<dt><a name="-s"
>-s</a></dt><p class="pad"></p>
<dd>List file/directory size in 512-byte blocks.
html/commands/ls/ls.mjd view on Meta::CPAN
next if /^\./;
my ($blocks, $line) = do_file("$dir/$_");
$tot_blocks += $blocks;
push @lines, $line;
}
($tot_blocks/2, @lines);
}
sub ui {
my ($u, $g) = @_;
$u = ($u{$u} ||= getpwuid($u));
$g = ($g{$g} ||= getgrgid($g));
($u, $g);
}
# Date formats:
# Recent: Mmm dd hh:mm (day space-filled; hour zero-filled T24)
$daterecent = '%b %d %H:%M';
# Older: Mmm dd yyyy
$dateolder = '%b %d %Y';
html/commands/ls/lst view on Meta::CPAN
sub wanted {
my $sb = stat($_); # XXX: should be stat or lstat?
return unless $sb;
$time{$name} = $sb->$IDX(); # indirect method call
$stat{$name} = $sb if $opt_l;
}
# cache user number to name conversions
sub user {
my $uid = shift;
$user{$uid} = getpwuid($uid)->name || "#$uid"
unless defined $user{$uid};
return $user{$uid};
}
# cache group number to name conversions
sub group {
my $gid = shift;
$group{$gid} = getgrgid($gid)->name || "#$gid"
unless defined $group{$gid};
return $group{$gid};
html/commands/ls/readme.fisherm view on Meta::CPAN
This is an enhanced V7 version of the Unix ls(1)
command. Notably, these BSD options are recognized:
-1 Force single-column output even to a tty
-R Recursively list directories
-S Sort by descending size
-g Accepted but ignored (uid and gid are always
listed for -l)
-k Use 1024-byte blocks instead of 512-byte blocks
-n List numeric uid and gid (default on platforms
without getpwuid() like Win3/95/NT)
Other BSD options won't print any error messages,
but they won't work either.
Also, this 'ls' defaults to multi-column output
when output is to a tty, like BSD 'ls' does.
This Perl implementation of I<ls>
was written by Mark Leighton Fisher of Thomson
Consumer Electronics, fisherm@tce.com.
html/commands/par/par view on Meta::CPAN
}
# Work quietly.
local $SIG{__WARN__} = sub {} if $opts{'q'};
# Header info.
my $date = localtime;
my $cwd = cwd;
my $user = $opts{'s'} || do {
require Sys::Hostname;
(getlogin || getpwuid($<) || $ENV{USER} || $ENV{LOGNAME} || 'nobody')
. '@'
. Sys::Hostname::hostname();
};
# Header.
print $0 eq 'shar' ? <<INTRO_SHAR : <<INTRO_PAR;
#!/bin/sh
# This is a shell archive (produced by par $VERSION).
# To extract the files from this archive, save it to some FILE, remove
# everything before the '#!/bin/sh' line above, then type 'sh FILE'.
html/commands/robots/robots view on Meta::CPAN
{
flock(SCORE, LOCK_UN);
close(SCORE);
return;
}
my($i, $count);
$uid = $<;
$score = $Arena{'PLAYER'}{'SCORE'};
$name = getpwuid($uid) || '???';
unshift(@{$High_Scores{$score}}, [ $uid, $score, $name ]);
# Clear and rewind
truncate(SCORE, 0);
seek(SCORE, 0, 0);
$i = 1;
$count = 0;
src/from/from.jv view on Meta::CPAN
# Parse and stash away -n switch, if provided
if ($#ARGV >= 0 && $ARGV[0] eq '-n') {
shift (@ARGV);
$~ = "format_n";
}
# Use system mailbox if none was specified on the command line
if ( $#ARGV < 0 ) {
if ( ! ($user = getlogin)) {
@a = getpwuid($<);
$user = $a[0];
}
if ( -r "/var/spool/mail/$user" ) { # Modern systems
@ARGV = ("/var/spool/mail/$user");
}
elsif ( -r "/usr/mail/$user" ) { # System V
@ARGV = ("/usr/mail/$user");
}
elsif ( -r "/usr/spool/mail" ) { # BSD
@ARGV = ("/usr/spool/mail/$user");
src/glob/glob.bradapp view on Meta::CPAN
$matched = 0;
@errors = ();
# check for and do tilde expansion
if ( /^\~([^${dirsep}]*)/ ) {
my $usr = $1;
my $usrdir = (length $usr)
? (getpwnam($usr))[7]
: (defined $ENV{HOME} ? $ENV{HOME}
: (getpwuid($<))[7]);
$usrdir && s/^\~\Q$usr\E/$usrdir/ && $usr
or push @errors, "Unknown user: $usr";
}
# If there's no wildcards, just return it
return $_ unless /(?:^|[^\\])[*?\[\]{}]/;
# Make the glob into a regexp
# escape + , and |
s/([+.|])/\\$1/g;
src/id/id.theo view on Meta::CPAN
&help if ( $opt_h );
if ( ($opt_G + $opt_g + $opt_p + $opt_u) > 1 ) {
print STDERR "You may only choose one of -G, -g, -p, or -u. Doh!\n\n";
&help;
}
my($user,$pw,$uid,$gid,$tp);
if ( @ARGV ) { # user specified
($user,$pw,$uid,$gid) = getpwnam $ARGV[0];
($user,$pw,$uid,$gid) = getpwuid $ARGV[0] unless ( $uid );
die "id: $ARGV[0]: No such user\n" unless ( $uid );
}
if ( $opt_u ) { # print uid
$tp = ($uid)?$uid:($opt_r)?$<:$>;
$tp = scalar getpwuid $tp || $tp if ( $opt_n );
}
elsif ( $opt_g ) { # print gid
$tp = ($gid)?$gid:(split(/\s+/,($opt_r)?$(:$)))[0];
$tp = scalar getgrgid $tp || $tp if ( $opt_n );
}
elsif ( $opt_p ) { # human-readable form (names when possible, etc.)
my($rgid,@rgids);
if ( $user ) {
$tp.="uid $user\n";
$tp.="rgid $gid\n";
@rgids=($gid);
while ( my($name,$pw,$gid,$members) = getgrent ) {
push(@rgids,$gid) if ( grep($_ eq $user,split(/\s+/,$members)) );
}
}
else {
my($login) = getlogin || die "getlogin failed!";
$tp.="login $login\n" if ( $login ne scalar getpwuid $< );
my($uid) = scalar getpwuid $< || $<;
$tp.="uid $uid\n";
my($euid) = scalar getpwuid $> || $>;
$tp.="euid $euid\n" if ( $< != $> );
($rgid,@rgids)=split(/\s+/,$();
my($egid)=split(/\s+/,$));
my($nrgid) = scalar getgrgid $rgid || $rgid;
my($negid) = scalar getgrgid $egid || $egid;
$tp.="rgid $nrgid\n";
$tp.="egid $negid\n" if ( $rgid != $egid );
}
my(%done);
src/id/id.theo view on Meta::CPAN
@rgids=($gid);
while ( my($name,$pw,$gid,$members) = getgrent ) {
push(@rgids,$gid) if ( grep($_ eq $user,split(/\s+/,$members)) );
}
$nruid = $user;
$nrgid = scalar getgrgid $gid;
}
else {
($rgid,@rgids)=split(/\s+/,$();
$egid = (split(/\s+/,$)))[0];
$nruid = scalar getpwuid $<;
$neuid = scalar getpwuid $>;
$nrgid = scalar getgrgid $rgid;
$negid = scalar getgrgid $egid;
}
$tp=join("=","uid",($user)?$uid:$<);
$tp.=($nruid)?"($nruid) ":" ";
if ( !($user) && ($< != $>) ) {
$tp.="euid=$>";
$tp.=($neuid)?"($neuid) ":" ";
src/lock/lock.atkins view on Meta::CPAN
local $main::oterm = $main::term->getlflag();
local $main::echo = &POSIX::ECHO;
local $main::noecho = $main::oterm & ~$main::echo;
$| = 1; # Make our pipes piping hot!
my $key;
my $again;
if ( $Password )
{
$key = (getpwuid($<))[1];
}
else
{
print "Key: ";
noecho();
$key = <STDIN>;
echo();
print "\n";
chomp $key;
src/lock/lock.atkins view on Meta::CPAN
}
sub usage
{
print STDERR "usage: lock [-n] [-p] [-t timeout]\n";
}
sub code
{
my $word = shift;
my $pwd = (getpwuid($<))[1];
my $salt = substr($pwd,0,2);
return crypt($word,$salt);
}
# upon interupt
# lock: type in the unlock key.
sub handler
{
my $sig = shift;
src/ls/ls.fisherm view on Meta::CPAN
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 $PathSep = "/"; # path separator
# (someone might want to patch this via
# File::Spec...)
my $SixMonths = # long listing time if < 6 months, else year
src/ls/ls.fisherm view on Meta::CPAN
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
src/ls/ls.fisherm view on Meta::CPAN
When used with B<-s>, list file/directory size in 1024-byte blocks.
=item -l
Long format listing of mode -- # of links, owner name, group name,
size in bytes, time of last modification, and name.
=item -n
List numeric uid and gid (default on platforms without getpwuid()).
=item -r
Reverse sorting order.
=item -s
List file/directory size in 512-byte blocks. (May not mean much
on non-Unix systems.)
src/ls/ls.mjd view on Meta::CPAN
next if /^\./;
my ($blocks, $line) = do_file("$dir/$_");
$tot_blocks += $blocks;
push @lines, $line;
}
($tot_blocks/2, @lines);
}
sub ui {
my ($u, $g) = @_;
$u = ($u{$u} ||= getpwuid($u));
$g = ($g{$g} ||= getgrgid($g));
($u, $g);
}
# Date formats:
# Recent: Mmm dd hh:mm (day space-filled; hour zero-filled T24)
$daterecent = '%b %d %H:%M';
# Older: Mmm dd yyyy
$dateolder = '%b %d %Y';
sub wanted {
my $sb = stat($_); # XXX: should be stat or lstat?
return unless $sb;
$time{$name} = $sb->$IDX(); # indirect method call
$stat{$name} = $sb if $opt_l;
}
# cache user number to name conversions
sub user {
my $uid = shift;
$user{$uid} = getpwuid($uid)->name || "#$uid"
unless defined $user{$uid};
return $user{$uid};
}
# cache group number to name conversions
sub group {
my $gid = shift;
$group{$gid} = getgrgid($gid)->name || "#$gid"
unless defined $group{$gid};
return $group{$gid};
src/ls/readme.fisherm view on Meta::CPAN
This is an enhanced V7 version of the Unix ls(1)
command. Notably, these BSD options are recognized:
-1 Force single-column output even to a tty
-R Recursively list directories
-S Sort by descending size
-g Accepted but ignored (uid and gid are always
listed for -l)
-k Use 1024-byte blocks instead of 512-byte blocks
-n List numeric uid and gid (default on platforms
without getpwuid() like Win3/95/NT)
Other BSD options won't print any error messages,
but they won't work either.
Also, this 'ls' defaults to multi-column output
when output is to a tty, like BSD 'ls' does.
This Perl implementation of I<ls>
was written by Mark Leighton Fisher of Thomson
Consumer Electronics, fisherm@tce.com.
src/par/par view on Meta::CPAN
}
# Work quietly.
local $SIG{__WARN__} = sub {} if $opts{'q'};
# Header info.
my $date = localtime;
my $cwd = cwd;
my $user = $opts{'s'} || do {
require Sys::Hostname;
(getlogin || getpwuid($<) || $ENV{USER} || $ENV{LOGNAME} || 'nobody')
. '@'
. Sys::Hostname::hostname();
};
# Header.
print $0 eq 'shar' ? <<INTRO_SHAR : <<INTRO_PAR;
#!/bin/sh
# This is a shell archive (produced by par $VERSION).
# To extract the files from this archive, save it to some FILE, remove
# everything before the '#!/bin/sh' line above, then type 'sh FILE'.
src/robots/robots view on Meta::CPAN
{
flock(SCORE, LOCK_UN);
close(SCORE);
return;
}
my($i, $count);
$uid = $<;
$score = $Arena{'PLAYER'}{'SCORE'};
$name = getpwuid($uid) || '???';
unshift(@{$High_Scores{$score}}, [ $uid, $score, $name ]);
# Clear and rewind
truncate(SCORE, 0);
seek(SCORE, 0, 0);
$i = 1;
$count = 0;
( run in 0.518 second using v1.01-cache-2.11-cpan-454fe037f31 )