BSD-stat
view release on metacpan or search on metacpan
! stat.pm stat.xs
+ t/utimes.t
utimes() and lutimes() added
! Makefile.PL
LICENSE => 'perl', # explicitly stated
1.21 2001.01.29
! stat.xs
* newSVuv() that prevented perl prior to 5.6.0 from compiling
was fixed. For perl prior to 5.6.0 newSViv() is used
(That's how Perl's internal stat() behaves).
1.20 2001.01.26
! stat.xs
* stat()->size returns negative value for files larger
than 2**31 bytes. Now fixed. (newSViv -> newSVnv)
* following the changes above, types of other members
was also changed to match CORE::stat (newSViv -> newSVuv)
1.11 2001.01.12
! backward compatible to 5.00503 (<miyagawa@edge.co.jp>);
"use warnings" pragma is post-5.6.
another side effect for starting module w/ h2xs which
version is "too new." sigh...
1.10 2001.01.12
+ $st_* variable exported with :FILED tag. BSD::stat is now
fully upper-compatible with File::stat (but with performance
penalty. See pod for details)
! pod revised
1.00 2001.01.11
! t/filehandle.t misteriously commented out #use FileHandle
uncommented (<miyagawa@edge.co.jp>)
! pod revised
! version raised to 1.00
0.43 2001.01.10
! possible memory leaks fixed this time
! prototype added as l?stat(;$);
0.42 2001.01.08
! possible memory leaks fixed
! OP_STAT and OP_LSTAT is set when and only when the
operation is successful
0.41 2001.01.08
! stat.xs is more compliant with perlxs guidelines
! further code optimization
0.40 2001.12.30
BSD::stat is now as much like CORE::stat as a module can get!
+ now supports _ special filehandle
! too much perlgut--wrenching?
* so version is now 0.40, not just 0.31
0.30 2001.12.28
BSD::stat is now more like CORE::stat
+ Now accepts filehandle as an argument
+ Now uses $_ when an argument is omitted
+ More performance gain
- AUTOLOAD() no longer used.
! README is now more dist-safe
0.25 2001.12.19
optimized: anystat()
safer: AUTOLOAD()
added: t/benchmark.pl
changed: test.pl -> t/*.t
0.24 2001.12.18
fixed: lstat() and stat() behaved the same.
0.23 2001.12.17
fixed: $scalar = lstat("nonexistent") wrongly got a reference
which always evaluates true. Now it returns undef when stat
fails.
0.22 2001.12.17
Debris in stat.pm removed; duplicate occurance of $VERSION
0.21 2001.12.17
First preview release
0.01 2001.12.17
- original version; created by h2xs 1.21 with options
-n BSD::stat -f
{
"abstract" : "stat() with BSD 4.4 extentions",
"author" : [
"Dan Kogai <dankogai@dan.co.jp>"
],
"dynamic_config" : 1,
"generated_by" : "ExtUtils::MakeMaker version 7.70, CPAN::Meta::Converter version 2.150010",
"license" : [
"perl_5"
],
"meta-spec" : {
"url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
---
abstract: 'stat() with BSD 4.4 extentions'
author:
- 'Dan Kogai <dankogai@dan.co.jp>'
build_requires:
ExtUtils::MakeMaker: '0'
configure_requires:
ExtUtils::MakeMaker: '0'
dynamic_config: 1
generated_by: 'ExtUtils::MakeMaker version 7.70, CPAN::Meta::Converter version 2.150010'
license: perl
meta-spec:
#
# $Id: README,v 1.22 2012/08/19 15:46:15 dankogai Exp $
#
BSD/stat
========
This module's default exports override the core stat() and
lstat() functions, replacing them with versions that con-
tains BSD 4.4 extentions such as flags. This module also
adds chflags function.
INSTALLATION
To install this module type the following:
perl Makefile.PL
make
make test
($1 eq '@') ? \@{"$pkg\::$sym"} :
($1 eq '%') ? \%{"$pkg\::$sym"} :
($1 eq '*') ? \*{"$pkg\::$sym"} : \&{"$pkg\::$sym"};
}
}
bootstrap BSD::stat $VERSION; # make XS available;
# Looks like as of Perl 5.18.1 the stat cache must be filled
# before BSD::stat makes use of it
CORE::lstat(__FILE__);
my $field = {
dev => 0,
ino => 1,
mode => 2,
nlink => 3,
uid => 4,
gid => 5,
rdev => 6,
size => 7,
};
sub DESTROY{
$DEBUG or return;
carp "Destroying ", __PACKAGE__;
$DEBUG >= 2 or return;
eval qq{ require Devel::Peek; } and Devel::Peek::Dump $_[0];
return;
}
sub stat(;$){
my $arg = shift || $_;
my $self =
ref \$arg eq 'SCALAR' ? xs_stat($arg) : xs_fstat(fileno($arg), 0);
defined $self or return;
$USE_OUR_ST and $set_our_st->($self);
return wantarray ? @$self : bless $self;
}
sub lstat(;$){
my $arg = shift || $_;
my $self =
ref \$arg eq 'SCALAR' ? xs_lstat($arg) : xs_fstat(fileno($arg), 1);
defined $self or return;
$USE_OUR_ST and $set_our_st->($self);
return wantarray ? @$self : bless $self;
}
# chflag implementation
# see <sys/stat.h>
use constant UF_SETTABLE => 0x0000ffff;
use constant UF_NODUMP => 0x00000001;
}
# Autoload methods go after =cut, and are processed by the autosplit program.
1;
__END__
# Below is stub documentation for your module. You better edit it!
=head1 NAME
BSD::stat - stat() with BSD 4.4 extentions
=head1 SYNOPSIS
use BSD::stat;
# just like CORE::stat
($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
$atime,$mtime,$ctime,$blksize,$blocks,
$atimensec,$mtimensec,$ctimensec,$flags,$gen)
= stat($filename);
# BSD::stat now accepts filehandles, too
open F, "foo";
my @stat = stat(*F);
# omit an argument and it will use $_;
my $_ = "foo";
my stat = stat;
# stat($file) then -x _ works like CORE::stat();
stat("foo") and -x _ and print "foo is executable"
# but -x $file then stat(_) will not!!!
# just like File::stat
$st = stat($file) or die "No $file: $!";
if ( ($st->mode & 0111) && $st->nlink > 1) ) {
print "$file is executable with lotsa links\n";
}
use BSD::stat qw(:FIELDS);
stat($file) or die "No $file: $!";
if ( ($st_mode & 0111) && $st_nlink > 1) ) {
print "$file is executable with lotsa links\n";
}
# chflags
chflags(UF_IMMUTABLE, @files)
# utimes and lutimes
my $when = 1234567890.987654;
utimes $when, $when, @files;
lutimes $when, $when, @links;
=head1 DESCRIPTION
This module's default exports override the core stat() and
lstat() functions, replacing them with versions that contain BSD 4.4
extentions such as file flags. This module also adds chflags function.
=head2 BSD::stat vs. CORE::stat
When called as array context, C<lstat()> and C<stat()> return an array
like CORE::stat. Here are the meaning of the fields:
0 dev device number of filesystem
1 ino inode number
2 mode file mode (type and permissions)
3 nlink number of (hard) links to the file
4 uid numeric user ID of file's owner
5 gid numeric group ID of file's owner
6 rdev the device identifier (special files only)
7 size total size of file, in bytes
11 blksize preferred block size for file system I/O
12 blocks actual number of blocks allocated
13 atimensec nsec of last access
14 mtimensec nsec of last data modification
15 ctimensec nsec of last file status change
16 flags user defined flags for file
17 gen file generation number
Like CORE::stat, BSD::stat supports _ filehandle. It does set "stat
cache" so the following -x _ operators can benefit. Be careful,
however, that BSD::stat::stat(_) will not work (or cannot be made to
work) because BSD::stat::stat() holds more info than that is stored in
Perl's internal stat cache.
C<atimespec>, C<mtimespec>, C<ctimespec> are available only as methods
that return times in floating point.
my $st = stat($path);
printf "%f\n" $st->atimespec; # $st->atime + $st->atimensec / 1e9
=head2 BSD::stat vs File::stat
When called as scalar context, it returns an object whose methods are
named as above, just like File::stat.
Like File::stat, You may also import all the structure fields directly
nto yournamespace 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.
Note: besides polluting the name space, :FIELDS comes with
performance penalty for setting extra variables. Unlike File::stat
which always sets $File::stat::st_* (even when not exported),
BSD::stat implements its own import mechanism to prevent performance
loss when $st_* is not needed
32160.80/s (n=100000)
Core::stat: 1 wallclock secs ( 1.18 usr + 0.76 sys = 1.94 CPU) @
51612.90/s (n=100000)
File::stat: 7 wallclock secs ( 6.40 usr + 0.93 sys = 7.33 CPU) @
13646.06/s (n=100000)
Not too bad, huh?
=head1 EXPORT
stat(), lstat(), chflags() and chflags-related constants are exported
as default. $st_* variables are also exported when used with :FIELDS
=head1 BUGS
This is the best approximation of CORE::stat() and File::stat::stat()
that module can go.
In exchange of '_' support, BSD::stat now peeks and pokes too much of
perlguts in terms tat BSD::stat uses such variables as PL_statcache
that does not appear in "perldoc perlapi" and such.
Very BSD specific. It will not work on any other platform.
=head1 SEE ALSO
sva[14] = sv_2mortal(newSViv(st->st_mtimespec.tv_nsec));
sva[15] = sv_2mortal(newSViv(st->st_ctimespec.tv_nsec));
sva[16] = sv_2mortal(newSVuv(st->st_flags));
sva[17] = sv_2mortal(newSVuv(st->st_gen));
retval = newRV_noinc((SV *)av_make(NUMSTATMEM, sva));
return retval;
}
static SV *
xs_stat(char *path){
struct stat st;
int err = stat(path, &st);
if (setbang(err)){
return &PL_sv_undef;
}else{
PL_laststype = OP_STAT;
return st2aref(&st);
}
}
static SV *
xs_lstat(char *path){
struct stat st;
int err = lstat(path, &st);
if (setbang(err)){
return &PL_sv_undef;
}else{
PL_laststype = OP_LSTAT;
return st2aref(&st);
}
}
static SV *
xs_fstat(int fd, int waslstat){
struct stat st;
int err = fstat(fd, &st);
if (setbang(err)){
return &PL_sv_undef;
}else{
PL_laststype = waslstat ? OP_LSTAT : OP_STAT;
return st2aref(&st);
}
}
static int
xs_chflags(char *path, int flags){
return setbang(err);
}
/* */
MODULE = BSD::stat PACKAGE = BSD::stat
PROTOTYPES: ENABLE
SV *
xs_stat(path)
char * path;
CODE:
RETVAL = xs_stat(path);
OUTPUT:
RETVAL
SV *
xs_lstat(path)
char * path;
CODE:
RETVAL = xs_lstat(path);
OUTPUT:
RETVAL
SV *
xs_fstat(fd, waslstat)
int fd;
int waslstat;
CODE:
RETVAL = xs_fstat(fd, waslstat);
OUTPUT:
RETVAL
int
xs_chflags(path, flags)
char * path;
int flags;
CODE:
RETVAL = xs_chflags(path, flags);
OUTPUT:
use Test;
use strict;
my $Debug = 0;
BEGIN { plan tests => 16 };
use BSD::stat;
ok(1); # If we made it this far, we're ok.
my $stat;
$stat = BSD::stat::stat($0);
$! ? ok(0) : ok(1);
$stat = BSD::stat::stat('nonexistent');
$! ? ok(1) : ok(0);
$Debug and warn $!;
my @bsdstat = lstat($0);
my @perlstat = CORE::lstat($0);
for my $i (0..$#perlstat){
$perlstat[$i] == $bsdstat[$i] ? ok(1) : ok(0);
}
$Debug and warn join(",", @bsdstat), "\n";
t/benchmark.pl view on Meta::CPAN
use Benchmark;
my $count = $ARGV[0] || 1024;
print <<"";
----
File::stat = $File::stat::VERSION
BSD::stat = $BSD::stat::VERSION
----
timethese($count, {
'Core::stat' => sub { my @st = CORE::stat("/dev/null") },
'BSD::stat' => sub { my $st = BSD::stat::stat("/dev/null")},
'File::stat' => sub { my $st = File::stat::stat("/dev/null")},
});
t/chflags.t view on Meta::CPAN
my $Debug = 0;
use BSD::stat;
use File::Copy;
my $dummy = $0; $dummy =~ s,([^/]+)$,dummy,o;
copy($0, $dummy) or die "copy $0 -> $dummy failed!";
SKIP:{
skip 'chflags() not supported', 5 unless chflags(UF_IMMUTABLE, $dummy);
ok chflags(UF_IMMUTABLE, $dummy), "chflags(UF_IMMUTABLE, '$dummy')";
is lstat($dummy)->flags, UF_IMMUTABLE, "lstat('$dummy')->flags";
ok !unlink($dummy), "unlink('$dummy') must fail";
$Debug and warn $!;
ok chflags(0, $dummy), "chflags(0, '$dummy')";
ok unlink($dummy), "unlink('$dummy') must work now";
}
unlink $dummy;
#########################
# change 'tests => 1' to 'tests => last_test_to_print';
use Test;
use strict;
my $Debug = 0;
BEGIN { plan tests => 18 };
use BSD::stat qw(:FIELDS);
my $bsdstat = lstat($0);
for my $s (qw(dev ino mode nlink uid gid rdev size
atime mtime ctime blksize blocks
atimensec mtimensec ctimensec flags gen))
{
no strict;
$Debug and warn "\$st_$s = ", ${"st_$s"};
ok($bsdstat->$s() == ${"st_$s"});
}
t/filehandle.t view on Meta::CPAN
# change 'tests => 1' to 'tests => last_test_to_print';
use Test;
use strict;
my $Debug = 0;
BEGIN { plan tests => 36 };
use BSD::stat;
my @lstat = lstat($0);
open F, $0 or die "$0:$!";
my @fstat1 = lstat(*F);
close F;
use FileHandle;
my $fh = FileHandle->new($0) or die "$0:$!";
my @fstat2 = lstat($fh);
undef $fh;
for my $i (0..$#lstat){
ok($lstat[$i] == $fstat1[$i]);
ok($lstat[$i] == $fstat2[$i]);
}
$Debug and warn join(",", @fstat1), "\n";
# change 'tests => 1' to 'tests => last_test_to_print';
use Test;
use strict;
my $Debug = 0;
BEGIN { plan tests => 13 };
use BSD::stat;
use File::stat ();
my $bsdstat = lstat($0);
my $perlstat = File::stat::lstat($0);
no strict 'refs';
for my $s (qw(dev ino mode nlink uid gid rdev size
atime mtime ctime blksize blocks))
{
$perlstat->$s() == $bsdstat->$s() ? ok(1) : ok(0);
}
use strict;
$Debug and print $bsdstat->dev, "\n";
t/statcache.t view on Meta::CPAN
# change 'tests => 1' to 'tests => last_test_to_print';
use Test;
use strict;
my $Debug = $ARGV[0] || 0;
BEGIN { plan tests => 27 };
use BSD::stat ();
BSD::stat::lstat($0); ok((-r _) == (-r $0));
BSD::stat::lstat($0); ok((-w _) == (-w $0));
BSD::stat::lstat($0); ok((-x _) == (-x $0));
BSD::stat::lstat($0); ok((-o _) == (-o $0));
BSD::stat::lstat($0); ok((-R _) == (-R $0));
BSD::stat::lstat($0); ok((-W _) == (-W $0));
BSD::stat::lstat($0); ok((-X _) == (-X $0));
BSD::stat::lstat($0); ok((-O _) == (-O $0));
BSD::stat::lstat($0); ok((-e _) == (-e $0));
BSD::stat::lstat($0); ok((-z _) == (-z $0));
BSD::stat::lstat($0); ok((-s _) == (-s $0));
BSD::stat::lstat($0); ok((-f _) == (-f $0));
BSD::stat::lstat($0); ok((-d _) == (-d $0));
# -l _ should only work on lstat so we test that, too.
BSD::stat::lstat($0); ok((-l _) == (-l $0));
eval {BSD::stat::stat($0); (-l _)}; ok($@);
BSD::stat::lstat($0); ok((-p _) == (-p $0));
BSD::stat::lstat($0); ok((-S _) == (-S $0));
BSD::stat::lstat($0); ok((-b _) == (-b $0));
BSD::stat::lstat($0); ok((-c _) == (-c $0));
# Stat cache does not work on -t so this one is commented out.
# BSD::stat::lstat(*STDIN); (-t _) == (-t STDIN));
BSD::stat::lstat($0); ok((-u _) == (-u $0));
BSD::stat::lstat($0); ok((-g _) == (-g $0));
BSD::stat::lstat($0); ok((-k _) == (-k $0));
BSD::stat::lstat($0); ok((-T _) == (-T $0));
BSD::stat::lstat($0); ok((-B _) == (-B $0));
BSD::stat::lstat($0); ok((-M _) == (-M $0));
BSD::stat::lstat($0); ok((-A _) == (-A $0));
BSD::stat::lstat($0); ok((-C _) == (-C $0));
if ($Debug){
my @lstat = BSD::stat::lstat(*STDIN);
warn join(",", @lstat), "\n";
}
t/underscore.t view on Meta::CPAN
# change 'tests => 1' to 'tests => last_test_to_print';
use Test;
use strict;
my $Debug = 0;
BEGIN { plan tests => 18 };
use BSD::stat;
my @lstat1 = lstat($0);
$_ = $0;
my @lstat2 = lstat;
for my $i (0..$#lstat1){
$lstat1[$i] == $lstat2[$i] ? ok(1) : ok(0);
}
$Debug and warn join(",", @lstat1), "\n";
use warnings;
use BSD::stat;
use Test::More tests => 7;
use File::Spec;
my $target = File::Spec->catfile('t', "test$$");
my $symlink = File::Spec->catfile('t', "link$$");
open my $wfh, ">$target" or die "($target):$!";
my $when = 1234567898.765432;
ok utimes($when, $when, $target), "utimes($when, $when, $target)";
my $st = stat($target);
$when = 1234567890.987654;
ok utimes($when, $when, $wfh), "utimes($when, $when, $wfh)";
$st = stat($wfh);
close $wfh;
symlink $target, $symlink or die "symlink $target, $symlink : $!";
ok lutimes(0, 0, $symlink), "lutimes(0, 0, $symlink)";
is lstat($symlink)->mtime, 0, "lutimes() does touch $symlink";
is lstat($target)->mtime, 1234567890, "lutimes() leaves $target";
$when = 1234.5678;
ok lutimes($when, $when, $symlink), "lutimes($when, $when, $symlink)";
is lstat($symlink)->mtime, 1234, "lutimes() wrong sec on $symlink";
# some fs (like HFS+) does not have this field so test skipped
#is lstat($symlink)->mtimensec, 567800000, "lutimes() wrong nsec on $symlink";
unlink($target, $symlink) == 2 or die "unlink($target, $symlink):$!";
( run in 1.620 second using v1.01-cache-2.11-cpan-49f99fa48dc )