view release on metacpan or  search on metacpan

stat.pm  view on Meta::CPAN

#$Id: stat.pm,v 1.36 2024/06/22 22:25:59 dankogai Exp $

package BSD::stat;

use 5.00503;
use strict;
use warnings;
use Carp;

require Exporter;
require DynaLoader;
use AutoLoader;

use vars qw($VERSION $DEBUG);

$VERSION = sprintf "%d.%02d", q$Revision: 1.36 $ =~ /(\d+)/g;

# In favor of speed, especially when $st_ series variables are exported,
# Exporter is no longer used, though EXPORT variables are still used
# to make the code easier to read. see how $USE_OUR_ST is used

use vars qw(@ISA @EXPORT_OK @EXPORT $USE_OUR_ST);

@ISA = qw(DynaLoader);

@EXPORT_OK = 
    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
	$st_atimensec $st_mtimensec $st_ctimensec $st_flags $st_gen
	);

@EXPORT = 
    qw(
       stat
       lstat
       chflags
       utimes
       lutimes
       UF_SETTABLE
       UF_NODUMP
       UF_IMMUTABLE
       UF_APPEND
       UF_OPAQUE
       UF_NOUNLINK
       SF_SETTABLE
       SF_ARCHIVED
       SF_IMMUTABLE
       SF_APPEND
       SF_NOUNLINK
       );

$USE_OUR_ST = 0;

sub import{
    no strict 'refs';
    my $pkg = shift;
    my $callpkg = caller();
    if (my ($flag) = @_){  # we have an arg
	if ($flag eq ":FIELDS"){
	    # import everything available
	    @_ = (@{"$pkg\::EXPORT"}, @{"$pkg\::EXPORT_OK"});
	    $USE_OUR_ST = 1;
	}else{
	    # just use the supplied list
	}
    }else{ # no arg.  Default @EXPORT used;
		@_ = @{"$pkg\:\:EXPORT"};
	}
    for my $sym (@_) {
        no warnings 'uninitialized';
	$sym =~ s/^([\$\@\%\*\&])//o;
	*{"$callpkg\::$sym"} = 
	    ($1 eq '$') ? \${"$pkg\::$sym"} :
	    ($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,
    atime     =>  8,
    mtime     =>  9,
    ctime     => 10,
    blksize   => 11,
    blocks    => 12,
    atimensec => 13,
    mtimensec => 14,
    ctimensec => 15,
    flags     => 16,
    gen       => 17,
};

# define attribute methods all at once w/o AUTOLOAD

while (my ($method, $index) = each %{$field}){
    no strict 'refs';
    *$method = sub{ $_[0]->[$index] };
}

sub atimespec { $_[0]->[8] + $_[0]->[13] / 1e9 }
sub mtimespec { $_[0]->[9] + $_[0]->[14] / 1e9 }
sub ctimespec { $_[0]->[10] + $_[0]->[15] / 1e9 }