134 lines
2.7 KiB
Perl
134 lines
2.7 KiB
Perl
use strict; use warnings;
|
|
package IO::All::Filesys;
|
|
|
|
use IO::All::Base -base;
|
|
use Fcntl qw(:flock);
|
|
|
|
my %spec_map = (
|
|
unix => 'Unix',
|
|
win32 => 'Win32',
|
|
vms => 'VMS',
|
|
mac => 'Mac',
|
|
os2 => 'OS2',
|
|
);
|
|
sub os {
|
|
my ($self, $type) = @_;
|
|
|
|
my ($v, $d, $f) = $self->_spec_class->splitpath($self->name);
|
|
my @d = $self->_spec_class->splitdir($d);
|
|
|
|
$self->_spec_class($spec_map{$type});
|
|
|
|
$self->name( $self->_spec_class->catfile( @d, $f ) );
|
|
|
|
return $self
|
|
}
|
|
|
|
sub exists { my $self = shift; -e $self->name }
|
|
|
|
sub filename {
|
|
my $self = shift;
|
|
my $filename;
|
|
(undef, undef, $filename) = $self->splitpath;
|
|
return $filename;
|
|
}
|
|
|
|
sub ext {
|
|
my $self = shift;
|
|
|
|
return $1 if $self->filename =~ m/\.([^\.]+)$/
|
|
}
|
|
{
|
|
no warnings 'once';
|
|
*extension = \&ext;
|
|
}
|
|
|
|
sub mimetype {
|
|
require File::MimeInfo;
|
|
return File::MimeInfo::mimetype($_[0]->filename)
|
|
}
|
|
|
|
sub is_absolute {
|
|
my $self = shift;
|
|
return *$self->{is_absolute} = shift if @_;
|
|
return *$self->{is_absolute}
|
|
if defined *$self->{is_absolute};
|
|
*$self->{is_absolute} = IO::All::is_absolute($self) ? 1 : 0;
|
|
}
|
|
|
|
sub is_executable { my $self = shift; -x $self->name }
|
|
sub is_readable { my $self = shift; -r $self->name }
|
|
sub is_writable { my $self = shift; -w $self->name }
|
|
{
|
|
no warnings 'once';
|
|
*is_writeable = \&is_writable;
|
|
}
|
|
|
|
sub pathname {
|
|
my $self = shift;
|
|
return *$self->{pathname} = shift if @_;
|
|
return *$self->{pathname} if defined *$self->{pathname};
|
|
return $self->name;
|
|
}
|
|
|
|
sub relative {
|
|
my $self = shift;
|
|
if (my $base = $_[0]) {
|
|
$self->pathname(File::Spec->abs2rel($self->pathname, $base))
|
|
} elsif ($self->is_absolute) {
|
|
$self->pathname(File::Spec->abs2rel($self->pathname))
|
|
}
|
|
$self->is_absolute(0);
|
|
return $self;
|
|
}
|
|
|
|
sub rename {
|
|
my $self = shift;
|
|
my $new = shift;
|
|
rename($self->name, "$new")
|
|
? UNIVERSAL::isa($new, 'IO::All')
|
|
? $new
|
|
: $self->_constructor->($new)
|
|
: undef;
|
|
}
|
|
|
|
sub set_lock {
|
|
my $self = shift;
|
|
return unless $self->_lock;
|
|
my $io_handle = $self->io_handle;
|
|
my $flag = $self->mode =~ /^>>?$/
|
|
? LOCK_EX
|
|
: LOCK_SH;
|
|
flock $io_handle, $flag;
|
|
}
|
|
|
|
sub stat {
|
|
my $self = shift;
|
|
return IO::All::stat($self, @_)
|
|
if $self->is_open;
|
|
CORE::stat($self->pathname);
|
|
}
|
|
|
|
sub touch {
|
|
my $self = shift;
|
|
$self->utime;
|
|
}
|
|
|
|
sub unlock {
|
|
my $self = shift;
|
|
flock $self->io_handle, LOCK_UN
|
|
if $self->_lock;
|
|
}
|
|
|
|
sub utime {
|
|
my $self = shift;
|
|
my $atime = shift;
|
|
my $mtime = shift;
|
|
$atime = time unless defined $atime;
|
|
$mtime = $atime unless defined $mtime;
|
|
utime($atime, $mtime, $self->name);
|
|
return $self;
|
|
}
|
|
|
|
1;
|