[p5sagit/p5-mst-13.2.git] / lib / File / stat.pm

package File::stat;
use 5.006;

use strict;
use warnings;
use warnings::register;
use Carp;

BEGIN { *warnif = \&warnings::warnif }

our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS);

our $VERSION = '1.02';

my @fields;
BEGIN { 
    use Exporter   ();
    @EXPORT      = qw(stat lstat);
    @fields      = qw( $st_dev	   $st_ino    $st_mode 
		       $st_nlink   $st_uid    $st_gid 
		       $st_rdev    $st_size 
		       $st_atime   $st_mtime  $st_ctime 
		       $st_blksize $st_blocks
		    );
    @EXPORT_OK   = ( @fields, "stat_cando" );
    %EXPORT_TAGS = ( FIELDS => [ @fields, @EXPORT ] );
}
use vars @fields;

use Fcntl qw(S_IRUSR S_IWUSR S_IXUSR);

BEGIN {
    # These constants will croak on use if the platform doesn't define
    # them. It's important to avoid inflicting that on the user.
    no strict 'refs';
    for (qw(suid sgid svtx)) {
        my $val = eval { &{"Fcntl::S_I\U$_"} };
        *{"_$_"} = defined $val ? sub { $_[0] & $val ? 1 : "" } : sub { "" };
    }
    for (qw(SOCK CHR BLK REG DIR FIFO LNK)) {
        *{"S_IS$_"} = defined eval { &{"Fcntl::S_IF$_"} }
            ? \&{"Fcntl::S_IS$_"} : sub { "" };
    }
}

# from doio.c
sub _ingroup {

    $^O eq "MacOS"  and return 1;
    
    my ($gid, $eff)   = @_;

    # I am assuming that since VMS doesn't have getgroups(2), $) will
    # always only contain a single entry.
    $^O eq "VMS"    and return $_[0] == $);

    my ($egid, @supp) = split " ", $);
    my ($rgid)        = split " ", $(;

    $gid == ($eff ? $egid : $rgid)  and return 1;
    grep $gid == $_, @supp          and return 1;

    return "";
}

# VMS uses the Unix version of the routine, even though this is very
# suboptimal. VMS has a permissions structure that doesn't really fit
# into struct stat, and unlike on Win32 the normal -X operators respect
# that, but unfortunately by the time we get here we've already lost the
# information we need. It looks to me as though if we were to preserve
# the st_devnam entry of vmsish.h's fake struct stat (which actually
# holds the filename) it might be possible to do this right, but both
# getting that value out of the struct (perl's stat doesn't return it)
# and interpreting it later would require this module to have an XS
# component (at which point we might as well just call Perl_cando and
# have done with it).
    
if (grep $^O eq $_, qw/os2 MSWin32 dos/) {

    # from doio.c
    *cando = sub { ($_[0][2] & $_[1]) ? 1 : "" };
}
else {

    # from doio.c
    *cando = sub {
        my ($s, $mode, $eff) = @_;
        my $uid = $eff ? $> : $<;

        $^O ne "VMS" and $uid == 0  and return 1;

        my ($stmode, $stuid, $stgid) = @$s[2,4,5];

        # This code basically assumes that the rwx bits of the mode are
        # the 0777 bits, but so does Perl_cando.
        if ($stuid == $uid) {
            $stmode & $mode         and return 1;
        }
        elsif (_ingroup($stgid, $eff)) {
            $stmode & ($mode >> 3)  and return 1;
        }
        else {
            $stmode & ($mode >> 6)  and return 1;
        }
        return "";
    };
}

# alias for those who don't like objects
*stat_cando = \&cando;

my %op = (
    r => sub { cando($_[0], S_IRUSR, 1) },
    w => sub { cando($_[0], S_IWUSR, 1) },
    x => sub { cando($_[0], S_IXUSR, 1) },
    o => sub { $_[0][4] == $>           },

    R => sub { cando($_[0], S_IRUSR, 0) },
    W => sub { cando($_[0], S_IWUSR, 0) },
    X => sub { cando($_[0], S_IXUSR, 0) },
    O => sub { $_[0][4] == $<           },

    e => sub { 1 },
    z => sub { $_[0][7] == 0    },
    s => sub { $_[0][7]         },

    f => sub { S_ISREG ($_[0][2]) },
    d => sub { S_ISDIR ($_[0][2]) },
    l => sub { S_ISLNK ($_[0][2]) },
    p => sub { S_ISFIFO($_[0][2]) },
    S => sub { S_ISSOCK($_[0][2]) },
    b => sub { S_ISBLK ($_[0][2]) },
    c => sub { S_ISCHR ($_[0][2]) },

    u => sub { _suid($_[0][2]) },
    g => sub { _sgid($_[0][2]) },
    k => sub { _svtx($_[0][2]) },

    M => sub { ($^T - $_[0][9] ) / 86400 },
    C => sub { ($^T - $_[0][10]) / 86400 },
    A => sub { ($^T - $_[0][8] ) / 86400 },
);

use constant HINT_FILETEST_ACCESS => 0x00400000;

# we need fallback=>1 or stringifying breaks
use overload 
    fallback => 1,
    -X => sub {
        my ($s, $op) = @_;

        if (index "rwxRWX", $op) {
            (caller 0)[8] & HINT_FILETEST_ACCESS
                and warnif("File::stat ignores use filetest 'access'");

            $^O eq "VMS" and warnif("File::stat ignores VMS ACLs");

            # It would be nice to have a warning about using -l on a
            # non-lstat, but that would require an extra member in the
            # object.
        }

        if ($op{$op}) {
            return $op{$op}->($_[0]);
        }
        else {
            croak "-$op is not implemented on a File::stat object";
        }
    };

# Class::Struct forbids use of @ISA
sub import { goto &Exporter::import }

use Class::Struct qw(struct);
struct 'File::stat' => [
     map { $_ => '$' } qw{
	 dev ino mode nlink uid gid rdev size
	 atime mtime ctime blksize blocks
     }
];

sub populate (@) {
    return unless @_;
    my $stob = new();
    @$stob = (
	$st_dev, $st_ino, $st_mode, $st_nlink, $st_uid, $st_gid, $st_rdev,
        $st_size, $st_atime, $st_mtime, $st_ctime, $st_blksize, $st_blocks ) 
	    = @_;
    return $stob;
} 

sub lstat ($)  { populate(CORE::lstat(shift)) }

sub stat ($) {
    my $arg = shift;
    my $st = populate(CORE::stat $arg);
    return $st if defined $st;
	my $fh;
    {
		local $!;
		no strict 'refs';
		require Symbol;
		$fh = \*{ Symbol::qualify( $arg, caller() )};
		return unless defined fileno $fh;
	}
    return populate(CORE::stat $fh);
}

1;
__END__

=head1 NAME

File::stat - by-name interface to Perl's built-in stat() functions

=head1 SYNOPSIS

 use File::stat;
 $st = stat($file) or die "No $file: $!";
 if ( ($st->mode & 0111) && $st->nlink > 1) ) {
     print "$file is executable with lotsa links\n";
 } 

 if ( -x $st ) {
     print "$file is executable\n";
 }

 use Fcntl "S_IRUSR";
 if ( $st->cando(S_IRUSR, 1) ) {
     print "My effective uid can read $file\n";
 }

 use File::stat qw(:FIELDS);
 stat($file) or die "No $file: $!";
 if ( ($st_mode & 0111) && ($st_nlink > 1) ) {
     print "$file is executable with lotsa links\n";
 } 

=head1 DESCRIPTION

This module's default exports override the core stat() 
and lstat() functions, replacing them with versions that return 
"File::stat" objects.  This object has methods that
return the similarly named structure field name from the
stat(2) function; namely,
dev,
ino,
mode,
nlink,
uid,
gid,
rdev,
size,
atime,
mtime,
ctime,
blksize,
and
blocks.  

As of version 1.02 (provided with perl 5.12) the object provides C<"-X">
overloading, so you can call filetest operators (C<-f>, C<-x>, and so
on) on it. It also provides a C<< ->cando >> method, called like

 $st->cando( ACCESS, EFFECTIVE )

where I<ACCESS> is one of C<S_IRUSR>, C<S_IWUSR> or C<S_IXUSR> from the
L<Fcntl|Fcntl> module, and I<EFFECTIVE> indicates whether to use
effective (true) or real (false) ids. The method interprets the C<mode>,
C<uid> and C<gid> fields, and returns whether or not the current process
would be allowed the specified access.

If you don't want to use the objects, you may import the C<< ->cando >>
method into your namespace as a regular function called C<stat_cando>.
This takes an arrayref containing the return values of C<stat> or
C<lstat> as its first argument, and interprets it for you.

You may also import all the structure fields directly into your namespace
as regular variables using the :FIELDS import tag.  (Note that this still
overrides your stat() and lstat() functions.)  Access these fields as
variables named with a preceding C<st_> in front their method names.
Thus, C<$stat_obj-E<gt>dev()> corresponds to $st_dev if you import
the fields.

To access this functionality without the core overrides,
pass the C<use> an empty import list, and then access
function functions with their full qualified names.
On the other hand, the built-ins are still available
via the C<CORE::> pseudo-package.

=head1 BUGS

As of Perl 5.8.0 after using this module you cannot use the implicit
C<$_> or the special filehandle C<_> with stat() or lstat(), trying
to do so leads into strange errors.  The workaround is for C<$_> to
be explicit

    my $stat_obj = stat $_;

and for C<_> to explicitly populate the object using the unexported
and undocumented populate() function with CORE::stat():

    my $stat_obj = File::stat::populate(CORE::stat(_));

=head1 ERRORS

=over 4

=item -%s is not implemented on a File::stat object

The filetest operators C<-t>, C<-T> and C<-B> are not implemented, as
they require more information than just a stat buffer.

=back

=head1 WARNINGS

These can all be disabled with

    no warnings "File::stat";

=over 4

=item File::stat ignores use filetest 'access'

You have tried to use one of the C<-rwxRWX> filetests with C<use
filetest 'access'> in effect. C<File::stat> will ignore the pragma, and
just use the information in the C<mode> member as usual.

=item File::stat ignores VMS ACLs

VMS systems have a permissions structure that cannot be completely
represented in a stat buffer, and unlike on other systems the builtin
filetest operators respect this. The C<File::stat> overloads, however,
do not, since the information required is not available.

=back

=head1 NOTE

While this class is currently implemented using the Class::Struct
module to build a struct-like class, you shouldn't rely upon this.

=head1 AUTHOR

Tom Christiansen
Commit	Line	Data
36477c24	1	package File::stat;
3b825e41	2	use 5.006;
3b825e41	3
36477c24	4	use strict;
b395063c	5	use warnings;
b7c4737f	6	use warnings::register;
448e77d7	7	use Carp;
36477c24	8
b7c4737f	9	BEGIN { *warnif = \&warnings::warnif }
b7c4737f	10
17f410f9	11	our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
17f410f9	12
f29a27fe	13	our $VERSION = '1.02';
b75c8c73	14
4f9e7902	15	my @fields;
36477c24	16	BEGIN {
36477c24	17	use Exporter ();
36477c24	18	@EXPORT = qw(stat lstat);
4f9e7902	19	@fields = qw( $st_dev $st_ino $st_mode
36477c24	20	$st_nlink $st_uid $st_gid
	21	$st_rdev $st_size
	22	$st_atime $st_mtime $st_ctime
	23	$st_blksize $st_blocks
	24	);
4f9e7902	25	@EXPORT_OK = ( @fields, "stat_cando" );
4f9e7902	26	%EXPORT_TAGS = ( FIELDS => [ @fields, @EXPORT ] );
36477c24	27	}
4f9e7902	28	use vars @fields;
36477c24	29
448e77d7	30	use Fcntl qw(S_IRUSR S_IWUSR S_IXUSR);
	31
	32	BEGIN {
	33	# These constants will croak on use if the platform doesn't define
	34	# them. It's important to avoid inflicting that on the user.
	35	no strict 'refs';
	36	for (qw(suid sgid svtx)) {
	37	my $val = eval { &{"Fcntl::S_I\U$_"} };
	38	*{"_$_"} = defined $val ? sub { $_[0] & $val ? 1 : "" } : sub { "" };
	39	}
	40	for (qw(SOCK CHR BLK REG DIR FIFO LNK)) {
	41	*{"S_IS$_"} = defined eval { &{"Fcntl::S_IF$_"} }
	42	? \&{"Fcntl::S_IS$_"} : sub { "" };
	43	}
	44	}
	45
	46	# from doio.c
	47	sub _ingroup {
	48
	49	$^O eq "MacOS" and return 1;
	50
	51	my ($gid, $eff) = @_;
	52
	53	# I am assuming that since VMS doesn't have getgroups(2), $) will
	54	# always only contain a single entry.
	55	$^O eq "VMS" and return $_[0] == $);
	56
	57	my ($egid, @supp) = split " ", $);
	58	my ($rgid) = split " ", $(;
	59
	60	$gid == ($eff ? $egid : $rgid) and return 1;
	61	grep $gid == $_, @supp and return 1;
	62
	63	return "";
	64	}
	65
	66	# VMS uses the Unix version of the routine, even though this is very
	67	# suboptimal. VMS has a permissions structure that doesn't really fit
	68	# into struct stat, and unlike on Win32 the normal -X operators respect
	69	# that, but unfortunately by the time we get here we've already lost the
	70	# information we need. It looks to me as though if we were to preserve
	71	# the st_devnam entry of vmsish.h's fake struct stat (which actually
	72	# holds the filename) it might be possible to do this right, but both
	73	# getting that value out of the struct (perl's stat doesn't return it)
	74	# and interpreting it later would require this module to have an XS
	75	# component (at which point we might as well just call Perl_cando and
	76	# have done with it).
	77
	78	if (grep $^O eq $_, qw/os2 MSWin32 dos/) {
	79
	80	# from doio.c
0e985b6b	81	*cando = sub { ($_[0][2] & $_[1]) ? 1 : "" };
448e77d7	82	}
	83	else {
	84
	85	# from doio.c
	86	*cando = sub {
	87	my ($s, $mode, $eff) = @_;
	88	my $uid = $eff ? $> : $<;
	89
cf5afd78	90	$^O ne "VMS" and $uid == 0 and return 1;
448e77d7	91
4f9e7902	92	my ($stmode, $stuid, $stgid) = @$s[2,4,5];
4f9e7902	93
448e77d7	94	# This code basically assumes that the rwx bits of the mode are
448e77d7	95	# the 0777 bits, but so does Perl_cando.
4f9e7902	96	if ($stuid == $uid) {
4f9e7902	97	$stmode & $mode and return 1;
448e77d7	98	}
4f9e7902	99	elsif (_ingroup($stgid, $eff)) {
4f9e7902	100	$stmode & ($mode >> 3) and return 1;
448e77d7	101	}
448e77d7	102	else {
4f9e7902	103	$stmode & ($mode >> 6) and return 1;
448e77d7	104	}
	105	return "";
	106	};
	107	}
	108
4f9e7902	109	# alias for those who don't like objects
	110	*stat_cando = \&cando;
	111
448e77d7	112	my %op = (
	113	r => sub { cando($_[0], S_IRUSR, 1) },
	114	w => sub { cando($_[0], S_IWUSR, 1) },
	115	x => sub { cando($_[0], S_IXUSR, 1) },
4f9e7902	116	o => sub { $_[0][4] == $> },
448e77d7	117
	118	R => sub { cando($_[0], S_IRUSR, 0) },
	119	W => sub { cando($_[0], S_IWUSR, 0) },
	120	X => sub { cando($_[0], S_IXUSR, 0) },
4f9e7902	121	O => sub { $_[0][4] == $< },
448e77d7	122
448e77d7	123	e => sub { 1 },
4f9e7902	124	z => sub { $_[0][7] == 0 },
	125	s => sub { $_[0][7] },
	126
	127	f => sub { S_ISREG ($_[0][2]) },
	128	d => sub { S_ISDIR ($_[0][2]) },
	129	l => sub { S_ISLNK ($_[0][2]) },
	130	p => sub { S_ISFIFO($_[0][2]) },
	131	S => sub { S_ISSOCK($_[0][2]) },
	132	b => sub { S_ISBLK ($_[0][2]) },
	133	c => sub { S_ISCHR ($_[0][2]) },
	134
	135	u => sub { _suid($_[0][2]) },
	136	g => sub { _sgid($_[0][2]) },
	137	k => sub { _svtx($_[0][2]) },
	138
	139	M => sub { ($^T - $_[0][9] ) / 86400 },
	140	C => sub { ($^T - $_[0][10]) / 86400 },
	141	A => sub { ($^T - $_[0][8] ) / 86400 },
448e77d7	142	);
448e77d7	143
b7c4737f	144	use constant HINT_FILETEST_ACCESS => 0x00400000;
b7c4737f	145
4f9e7902	146	# we need fallback=>1 or stringifying breaks
448e77d7	147	use overload
	148	fallback => 1,
	149	-X => sub {
	150	my ($s, $op) = @_;
b7c4737f	151
	152	if (index "rwxRWX", $op) {
	153	(caller 0)[8] & HINT_FILETEST_ACCESS
	154	and warnif("File::stat ignores use filetest 'access'");
	155
	156	$^O eq "VMS" and warnif("File::stat ignores VMS ACLs");
	157
	158	# It would be nice to have a warning about using -l on a
	159	# non-lstat, but that would require an extra member in the
	160	# object.
	161	}
4f9e7902	162
448e77d7	163	if ($op{$op}) {
	164	return $op{$op}->($_[0]);
	165	}
	166	else {
	167	croak "-$op is not implemented on a File::stat object";
	168	}
	169	};
	170
8cc95fdb	171	# Class::Struct forbids use of @ISA
	172	sub import { goto &Exporter::import }
	173
ee28235b	174	use Class::Struct qw(struct);
36477c24	175	struct 'File::stat' => [
	176	map { $_ => '$' } qw{
	177	dev ino mode nlink uid gid rdev size
	178	atime mtime ctime blksize blocks
	179	}
	180	];
	181
	182	sub populate (@) {
	183	return unless @_;
	184	my $stob = new();
	185	@$stob = (
	186	$st_dev, $st_ino, $st_mode, $st_nlink, $st_uid, $st_gid, $st_rdev,
	187	$st_size, $st_atime, $st_mtime, $st_ctime, $st_blksize, $st_blocks )
	188	= @_;
	189	return $stob;
	190	}
	191
14d597e2	192	sub lstat ($) { populate(CORE::lstat(shift)) }
36477c24	193
	194	sub stat ($) {
	195	my $arg = shift;
	196	my $st = populate(CORE::stat $arg);
448e77d7	197	return $st if defined $st;
2f173a71	198	my $fh;
	199	{
	200	local $!;
	201	no strict 'refs';
	202	require Symbol;
83716b1e	203	$fh = \*{ Symbol::qualify( $arg, caller() )};
2f173a71	204	return unless defined fileno $fh;
	205	}
	206	return populate(CORE::stat $fh);
36477c24	207	}
	208
	209	1;
	210	__END__
	211
	212	=head1 NAME
	213
2ae324a7	214	File::stat - by-name interface to Perl's built-in stat() functions
36477c24	215
	216	=head1 SYNOPSIS
	217
	218	use File::stat;
	219	$st = stat($file) or die "No $file: $!";
	220	if ( ($st->mode & 0111) && $st->nlink > 1) ) {
	221	print "$file is executable with lotsa links\n";
	222	}
	223
6cf0ee86	224	if ( -x $st ) {
	225	print "$file is executable\n";
	226	}
	227
	228	use Fcntl "S_IRUSR";
	229	if ( $st->cando(S_IRUSR, 1) ) {
	230	print "My effective uid can read $file\n";
	231	}
	232
36477c24	233	use File::stat qw(:FIELDS);
36477c24	234	stat($file) or die "No $file: $!";
592b6146	235	if ( ($st_mode & 0111) && ($st_nlink > 1) ) {
36477c24	236	print "$file is executable with lotsa links\n";
	237	}
	238
	239	=head1 DESCRIPTION
	240
	241	This module's default exports override the core stat()
	242	and lstat() functions, replacing them with versions that return
	243	"File::stat" objects. This object has methods that
	244	return the similarly named structure field name from the
	245	stat(2) function; namely,
	246	dev,
	247	ino,
	248	mode,
	249	nlink,
	250	uid,
	251	gid,
	252	rdev,
	253	size,
	254	atime,
	255	mtime,
	256	ctime,
	257	blksize,
	258	and
	259	blocks.
	260
6cf0ee86	261	As of version 1.02 (provided with perl 5.12) the object provides C<"-X">
	262	overloading, so you can call filetest operators (C<-f>, C<-x>, and so
	263	on) on it. It also provides a C<< ->cando >> method, called like
	264
	265	$st->cando( ACCESS, EFFECTIVE )
	266
	267	where I<ACCESS> is one of C<S_IRUSR>, C<S_IWUSR> or C<S_IXUSR> from the
	268	L<Fcntl\|Fcntl> module, and I<EFFECTIVE> indicates whether to use
	269	effective (true) or real (false) ids. The method interprets the C<mode>,
	270	C<uid> and C<gid> fields, and returns whether or not the current process
	271	would be allowed the specified access.
	272
	273	If you don't want to use the objects, you may import the C<< ->cando >>
	274	method into your namespace as a regular function called C<stat_cando>.
	275	This takes an arrayref containing the return values of C<stat> or
	276	C<lstat> as its first argument, and interprets it for you.
	277
36477c24	278	You may also import all the structure fields directly into your namespace
	279	as regular variables using the :FIELDS import tag. (Note that this still
	280	overrides your stat() and lstat() functions.) Access these fields as
	281	variables named with a preceding C<st_> in front their method names.
	282	Thus, C<$stat_obj-E<gt>dev()> corresponds to $st_dev if you import
	283	the fields.
	284
	285	To access this functionality without the core overrides,
	286	pass the C<use> an empty import list, and then access
	287	function functions with their full qualified names.
	288	On the other hand, the built-ins are still available
	289	via the C<CORE::> pseudo-package.
	290
5c4d9947	291	=head1 BUGS
	292
	293	As of Perl 5.8.0 after using this module you cannot use the implicit
	294	C<$_> or the special filehandle C<_> with stat() or lstat(), trying
	295	to do so leads into strange errors. The workaround is for C<$_> to
	296	be explicit
	297
	298	my $stat_obj = stat $_;
	299
	300	and for C<_> to explicitly populate the object using the unexported
	301	and undocumented populate() function with CORE::stat():
	302
	303	my $stat_obj = File::stat::populate(CORE::stat(_));
	304
6cf0ee86	305	=head1 ERRORS
	306
	307	=over 4
	308
	309	=item -%s is not implemented on a File::stat object
	310
	311	The filetest operators C<-t>, C<-T> and C<-B> are not implemented, as
	312	they require more information than just a stat buffer.
	313
	314	=back
	315
	316	=head1 WARNINGS
	317
	318	These can all be disabled with
	319
	320	no warnings "File::stat";
	321
	322	=over 4
	323
	324	=item File::stat ignores use filetest 'access'
	325
	326	You have tried to use one of the C<-rwxRWX> filetests with C<use
	327	filetest 'access'> in effect. C<File::stat> will ignore the pragma, and
	328	just use the information in the C<mode> member as usual.
	329
	330	=item File::stat ignores VMS ACLs
	331
	332	VMS systems have a permissions structure that cannot be completely
	333	represented in a stat buffer, and unlike on other systems the builtin
	334	filetest operators respect this. The C<File::stat> overloads, however,
	335	do not, since the information required is not available.
	336
	337	=back
	338
36477c24	339	=head1 NOTE
36477c24	340
8cc95fdb	341	While this class is currently implemented using the Class::Struct
36477c24	342	module to build a struct-like class, you shouldn't rely upon this.
	343
	344	=head1 AUTHOR
	345
	346	Tom Christiansen