diff options
Diffstat (limited to 'Master/tlpkg/tlperl0/lib/Win32/File/Object.pm')
-rwxr-xr-x | Master/tlpkg/tlperl0/lib/Win32/File/Object.pm | 450 |
1 files changed, 450 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl0/lib/Win32/File/Object.pm b/Master/tlpkg/tlperl0/lib/Win32/File/Object.pm new file mode 100755 index 00000000000..bb4aa90ecdc --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Win32/File/Object.pm @@ -0,0 +1,450 @@ +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 |