451 lines
7.8 KiB
Perl
451 lines
7.8 KiB
Perl
package Win32::File::Object;
|
|
|
|
=pod
|
|
|
|
=head1 NAME
|
|
|
|
Win32::File::Object - Simplified object abstraction over Win32::File
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
# Get a handle for the file.
|
|
my $object = Win32::File::Object->new( $filename, $autowrite );
|
|
|
|
# Read a property flag for the file.
|
|
my $readonly = $object->readonly;
|
|
|
|
# Set a propertly flag for the file.
|
|
$object->readonly(1);
|
|
|
|
# If autowrite is false, write the changes to the file.
|
|
$object->write;
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
L<Win32::File> is an interface to the Win32 API for file
|
|
attributes.
|
|
|
|
Unfortunately it is a B<direct> interface to the underlying Win32 API,
|
|
with a completely non-Perlish interface involving CamelCase function
|
|
names, bit-field flags and return-by-param.
|
|
|
|
B<Win32::File::Object> is a straight-forward object-oriented Perlish
|
|
wrapper around the raw underlying API wrapper.
|
|
|
|
=head1 METHODS
|
|
|
|
=cut
|
|
|
|
use 5.006;
|
|
use strict;
|
|
use Carp ();
|
|
use Win32::File ();
|
|
|
|
use vars qw{$VERSION};
|
|
BEGIN {
|
|
$VERSION = '0.02';
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
#####################################################################
|
|
# Constructor
|
|
|
|
=pod
|
|
|
|
=head2 new
|
|
|
|
my $file = Win32::File::Object->new( $path, $autowrite );
|
|
|
|
The C<new> constructor creates a new handle to the Win32 filesystem
|
|
attributes of an existing file or directory.
|
|
|
|
The compulsory C<$filename> parameter is the name of the file or
|
|
directory to create the handle on.
|
|
|
|
The optional C<$autowrite> parameter, if true, indicates that the
|
|
object should write the filesystem attributes to the file every
|
|
time the method is called to set the property.
|
|
|
|
If the C<$autowrite> param is false or not provided, you will
|
|
need to call an explicit C<write> method in order to apply the
|
|
changes to the file.
|
|
|
|
=cut
|
|
|
|
sub new {
|
|
my $class = shift;
|
|
my $path = shift;
|
|
my $autowrite = !! shift;
|
|
unless ( $path ) {
|
|
Carp::croak("Did not provide a file name");
|
|
}
|
|
unless ( -f $path ) {
|
|
Carp::croak("File '$path' does not exist");
|
|
}
|
|
|
|
# Create the object
|
|
my $self = bless {
|
|
path => $path,
|
|
autowrite => $autowrite,
|
|
rollback => ! 1,
|
|
}, $class;
|
|
|
|
# Get the attributes
|
|
$self->read;
|
|
|
|
return $self;
|
|
}
|
|
|
|
=pod
|
|
|
|
=head2 path
|
|
|
|
The C<path> accessor returns the original file path as provided to
|
|
the constructor as a string.
|
|
|
|
=cut
|
|
|
|
sub path {
|
|
$_[0]->{path};
|
|
}
|
|
|
|
=pod
|
|
|
|
=head2 autowrite
|
|
|
|
The C<autowrite> accessor returns true if the object will
|
|
automatically write changes to the filesystem, or false if
|
|
not.
|
|
|
|
=cut
|
|
|
|
sub autowrite {
|
|
$_[0]->{autowrite};
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
#####################################################################
|
|
# Main Methods
|
|
|
|
=pod
|
|
|
|
=head2 read
|
|
|
|
the C<read> method reads (updates) the filesystem attributes, in case
|
|
they have been updated since the object was originally created.
|
|
|
|
Returns true on success or throws an exception (dies) on error.
|
|
|
|
=cut
|
|
|
|
sub read {
|
|
my $self = shift;
|
|
|
|
# Read the bitfield
|
|
my $bits;
|
|
my $path = $self->path;
|
|
unless ( Win32::File::GetAttributes( $self->path => $bits ) ) {
|
|
Carp::croak("GetAttributes failed for '$path'");
|
|
}
|
|
|
|
# Read the flags
|
|
$self->{archive} = ( $bits & Win32::File::ARCHIVE() ) ? 1 : 0;
|
|
$self->{compressed} = ( $bits & Win32::File::COMPRESSED() ) ? 1 : 0;
|
|
$self->{directory} = ( $bits & Win32::File::DIRECTORY() ) ? 1 : 0;
|
|
$self->{hidden} = ( $bits & Win32::File::HIDDEN() ) ? 1 : 0;
|
|
$self->{normal} = ( $bits & Win32::File::NORMAL() ) ? 1 : 0;
|
|
$self->{offline} = ( $bits & Win32::File::OFFLINE() ) ? 1 : 0;
|
|
$self->{readonly} = ( $bits & Win32::File::READONLY() ) ? 1 : 0;
|
|
$self->{system} = ( $bits & Win32::File::SYSTEM() ) ? 1 : 0;
|
|
$self->{temporary} = ( $bits & Win32::File::TEMPORARY() ) ? 1 : 0;
|
|
|
|
return 1;
|
|
}
|
|
|
|
=pod
|
|
|
|
=head2 write
|
|
|
|
the C<write> method writes the object attributes back to the filesystem.
|
|
|
|
Returns true on success or throws an exception (dies) on error.
|
|
|
|
=cut
|
|
|
|
sub write {
|
|
my $self = shift;
|
|
|
|
# Generate the bitfield from the attributes
|
|
my $bits = 0;
|
|
if ( $self->archive ) {
|
|
$bits += Win32::File::ARCHIVE();
|
|
}
|
|
if ( $self->compressed ) {
|
|
$bits += Win32::File::COMPRESSED();
|
|
}
|
|
if ( $self->directory ) {
|
|
$bits += Win32::File::DIRECTORY();
|
|
}
|
|
if ( $self->hidden ) {
|
|
$bits += Win32::File::HIDDEN();
|
|
}
|
|
if ( $self->normal ) {
|
|
$bits += Win32::File::NORMAL();
|
|
}
|
|
if ( $self->offline ) {
|
|
$bits += Win32::File::OFFLINE();
|
|
}
|
|
if ( $self->readonly ) {
|
|
$bits += Win32::File::READONLY();
|
|
}
|
|
if ( $self->system ) {
|
|
$bits += Win32::File::SYSTEM();
|
|
}
|
|
if ( $self->temporary ) {
|
|
$bits += Win32::File::TEMPORARY();
|
|
}
|
|
|
|
# Apply the attributes to the file
|
|
my $path = $self->path;
|
|
unless ( Win32::File::SetAttributes( $path, $bits ) ) {
|
|
Carp::croak("SetAttributes failed for '$path'");
|
|
}
|
|
|
|
return 1;
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
#####################################################################
|
|
# Attribute Methods
|
|
|
|
=pod
|
|
|
|
=head2 archive
|
|
|
|
# Get the value
|
|
my $archive = $file->archive;
|
|
|
|
# Set the value
|
|
$file->archive(1);
|
|
|
|
The C<archive> accessor gets or set the Win32 "archive" status for
|
|
the file.
|
|
|
|
=cut
|
|
|
|
sub archive {
|
|
shift->_attr( archive => @_ );
|
|
}
|
|
|
|
=pod
|
|
|
|
=head2 compressed
|
|
|
|
# Get the value
|
|
my $compressed = $file->compressed;
|
|
|
|
# Set the value
|
|
$file->compressed(1);
|
|
|
|
The C<compressed> accessor gets or set the Win32 "compressed" status
|
|
for the file.
|
|
|
|
=cut
|
|
|
|
sub compressed {
|
|
shift->_attr( compressed => @_ );
|
|
}
|
|
|
|
=pod
|
|
|
|
=head2 directory
|
|
|
|
# Get the value
|
|
my $directory = $file->directory;
|
|
|
|
# Set the value
|
|
$file->directory(1);
|
|
|
|
The C<directory> accessor gets or set the Win32 "directory" status for
|
|
the file.
|
|
|
|
=cut
|
|
|
|
sub directory {
|
|
shift->_attr( directory => @_ );
|
|
}
|
|
|
|
=pod
|
|
|
|
=head2 hidden
|
|
|
|
# Get the value
|
|
my $hidden = $file->hidden;
|
|
|
|
# Set the value
|
|
$file->hidden(1);
|
|
|
|
The C<hidden> accessor gets or set the Win32 "hidden" status for
|
|
the file.
|
|
|
|
=cut
|
|
|
|
sub hidden {
|
|
shift->_attr( hidden => @_ );
|
|
}
|
|
|
|
=pod
|
|
|
|
=head2 normal
|
|
|
|
# Get the value
|
|
my $normal = $file->normal;
|
|
|
|
# Set the value
|
|
$file->normal(1);
|
|
|
|
The C<normal> accessor gets or set the Win32 "normal" status for
|
|
the file.
|
|
|
|
=cut
|
|
|
|
sub normal {
|
|
shift->_attr( normal => @_ );
|
|
}
|
|
|
|
=pod
|
|
|
|
=head2 offline
|
|
|
|
# Get the value
|
|
my $offline = $file->offline;
|
|
|
|
# Set the value
|
|
$file->offline(1);
|
|
|
|
The C<offline> accessor gets or set the Win32 "offline" status for
|
|
the file.
|
|
|
|
=cut
|
|
|
|
sub offline {
|
|
shift->_attr( offline => @_ );
|
|
}
|
|
|
|
=pod
|
|
|
|
=head2 readonly
|
|
|
|
# Get the value
|
|
my $readonly = $file->readonly;
|
|
|
|
# Set the value
|
|
$file->readonly(1);
|
|
|
|
The C<readonly> accessor gets or set the Win32 "readonly" status for
|
|
the file.
|
|
|
|
=cut
|
|
|
|
sub readonly {
|
|
shift->_attr( readonly => @_ );
|
|
}
|
|
|
|
=pod
|
|
|
|
=head2 system
|
|
|
|
# Get the value
|
|
my $system = $file->system;
|
|
|
|
# Set the value
|
|
$file->system(1);
|
|
|
|
The C<system> accessor gets or set the Win32 "system" status for
|
|
the file.
|
|
|
|
=cut
|
|
|
|
sub system {
|
|
shift->_attr( system => @_ );
|
|
}
|
|
|
|
=pod
|
|
|
|
=head2 temporary
|
|
|
|
# Get the value
|
|
my $temporary = $file->temporary;
|
|
|
|
# Set the value
|
|
$file->temporary(1);
|
|
|
|
The C<temporary> accessor gets or set the Win32 "temporary" status for
|
|
the file.
|
|
|
|
=cut
|
|
|
|
sub temporary {
|
|
shift->_attr( temporary => @_ );
|
|
}
|
|
|
|
sub _attr {
|
|
my $self = shift;
|
|
my $name = shift;
|
|
my $new = $_[0] ? 1 : 0;
|
|
return $self->{$name} unless @_;
|
|
return $self->{$name} if $new == $self->{$name};
|
|
|
|
# Set the rollback if needed
|
|
if ( $self->{rollback} and ! exists $self->{rollback}->{$name} ) {
|
|
$self->{rollback}->{$name} = $new;
|
|
}
|
|
|
|
# Set the new value
|
|
$self->{$name} = $new;
|
|
$self->write if $self->autowrite;
|
|
|
|
return $self->{$name};
|
|
}
|
|
|
|
1;
|
|
|
|
=pod
|
|
|
|
=head1 SUPPORT
|
|
|
|
Bugs should be reported via the CPAN bug tracker at
|
|
|
|
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Win32-File-Object>
|
|
|
|
For other issues, or commercial enhancement or support, contact the author.
|
|
|
|
=head1 AUTHOR
|
|
|
|
Adam Kennedy E<lt>adamk@cpan.orgE<gt>
|
|
|
|
=head1 SEE ALSO
|
|
|
|
L<Win32::File>
|
|
|
|
=head1 COPYRIGHT
|
|
|
|
Copyright 2008 - 2009 Adam Kennedy.
|
|
|
|
This program is free software; you can redistribute
|
|
it and/or modify it under the same terms as Perl itself.
|
|
|
|
The full text of the license can be found in the
|
|
LICENSE file included with this module.
|
|
|
|
=cut
|