# @(#)$Id: File.pm 204 2012-09-02 20:52:12Z pjf $ package Class::Usul::File; use strict; use version; our $VERSION = qv( sprintf '0.1.%d', q$Rev: 204 $ =~ /\d+/gmx ); use Class::Usul::Moose; use Class::Usul::Constants; use Class::Usul::Functions qw(abs_path arg_list create_token is_arrayref merge_attributes throw untaint_path); use English qw(-no_match_vars); use File::DataClass::Constants (); use File::DataClass::IO (); use File::DataClass::Schema; use File::Spec::Functions qw(catdir catfile); File::DataClass::Constants->Exception_Class( EXCEPTION_CLASS ); has '_usul' => is => 'ro', isa => Object, handles => [ qw(config debug lock log) ], init_arg => 'builder', reader => 'usul', required => TRUE, weak_ref => TRUE; sub absolute { my ($self, $base, $path) = @_; $base ||= NUL; $path or return NUL; is_arrayref $base and $base = catdir( @{ $base } ); return $self->io( $path )->absolute( $base ); } sub data_dump { my ($self, @rest) = @_; my $args = arg_list @rest; my $attr = {}; defined $args->{storage_class} and $attr->{storage_class} = delete $args->{storage_class}; return $self->dataclass_schema( $attr )->dump( $args ); } sub data_load { my ($self, @rest) = @_; my $args = arg_list @rest; my $attr = {}; defined $args->{arrays} and $attr->{storage_attributes}->{force_array} = $args->{arrays}; defined $args->{storage_class} and $attr->{storage_class} = $args->{storage_class}; return $self->dataclass_schema( $attr )->load( @{ $args->{paths} || [] } ); } sub dataclass_schema { my ($self, @rest) = @_; my $attr = arg_list @rest; if (blessed $self) { $attr->{builder} = $self->usul } else { $attr->{cache_class} = q(none) } $attr->{storage_class} ||= q(Any); return File::DataClass::Schema->new( $attr ); } sub delete_tmp_files { return $_[ 0 ]->io( $_[ 1 ] || $_[ 0 ]->tempdir )->delete_tmp_files; } sub extensions { return $_[ 0 ]->dataclass_schema->extensions; } sub io { my $self = shift; return File::DataClass::IO->new( @_ ); } sub status_for { return $_[ 0 ]->io( $_[ 1 ] )->stat; } sub symlink { my ($self, $base, $from, $to) = @_; $from or throw 'Symlink path from undefined'; $from = $self->absolute( $base, $from ); $from->exists or throw error => 'Path [_1] does not exist', args => [ $from->pathname ]; $to or throw 'Symlink path to undefined'; $to = $self->io( $to ); -l $to->pathname and $to->unlink; $to->exists and throw error => 'Path [_1] already exists', args => [ $to->pathname ]; CORE::symlink $from->pathname, $to->pathname or throw $ERRNO; return "Symlinked ${from} to ${to}"; } sub tempdir { return $_[ 0 ]->config->tempdir; } sub tempfile { return $_[ 0 ]->io( $_[ 1 ] || $_[ 0 ]->tempdir )->tempfile; } sub tempname { my ($self, $dir) = @_; my $path; while (not $path or -f $path) { my $file = sprintf '%6.6d%s', $PID, (substr create_token, 0, 4); $path = catfile( $dir || $self->tempdir, $file ); } return $path; } sub uuid { return $_[ 0 ]->io( $_[ 1 ] || UUID_PATH )->lock->chomp->getline; } __PACKAGE__->meta->make_immutable; 1; __END__ =pod =head1 Name Class::Usul::File - File and directory IO base class =head1 Version 0.6.$Revision: 204 $ =head1 Synopsis package MyBaseClass; use base qw(Class::Usul::File); =head1 Description Provides file and directory methods to the application base class =head1 Subroutines/Methods =head2 absolute $absolute_path = $self->absolute( $base, $path ); Prepends F<$base> to F<$path> unless F<$path> is an absolute path =head2 data_dump $self->dump( @args ); Accepts either a list or a hash ref. Calls L</dataclass_schema> with the I<storage_class> attribute if supplied. Calls the L<dump|File::DataClass::Schema/dump> method =head2 data_load $self->load( @args ); Accepts either a list or a hash ref. Calls L</dataclass_schema> with the I<storage_class> and I<arrays> attributes if supplied. Calls the L<load|File::DataClass::Schema/load> method =head2 dataclass_schema $f_dc_schema_obj = $self->dataclass_schema( $attrs ); Returns a L<File::DataClass::Schema> object. Object uses our C<exception_class>, no caching and no locking by default. Works as a class method =head2 delete_tmp_files $self->delete_tmp_files( $dir ); Delete this processes temporary files. Files are in the C<$dir> directory which defaults to C<< $self->tempdir >> =head2 extensions $hash_ref = $self->extensions; Class method that returns the extensions supported by L<File::DataClass::Storage> =head2 io $io_obj = $self->io( $pathname ); Expose the methods in L<File::DataClass::IO> =head2 status_for $stat_ref = $self->status_for( $path ); Return a hash for the given path containing it's inode status information =head2 symlink $out_ref = $self->symlink( $base, $from, $to ); Creates a symlink. If either C<$from> or C<$to> is a relative path then C<$base> is prepended to make it absolute. Returns a message indicating success or throws an exception on failure =head2 tempdir $temporary_directory = $self->tempdir; Returns C<< $self->config->tempdir >> or L<File::Spec/tmpdir> =head2 tempfile $tempfile_obj = $self->tempfile( $dir ); Returns a L<File::Temp> object in the C<$dir> directory which defaults to C<< $self->tempdir >>. File is automatically deleted if the C<$tempfile_obj> reference goes out of scope =head2 tempname $pathname = $self->tempname( $dir ); Returns the pathname of a temporary file in the given directory which defaults to C<< $self->tempdir >>. The file will be deleted by L</delete_tmp_files> if it is called otherwise it will persist =head2 uuid $uuid = $self->uuid; Return the contents of F</proc/sys/kernel/random/uuid> =head1 Diagnostics None =head1 Configuration and Environment None =head1 Dependencies =over 3 =item L<Class::Usul::Constants> =item L<File::DataClass::IO> =item L<File::Temp> =back =head1 Incompatibilities The L</uuid> method with only work on a OS with a F</proc> filesystem =head1 Bugs and Limitations There are no known bugs in this module. Please report problems to the address below. Patches are welcome =head1 Author Peter Flanigan, C<< <Support at RoxSoft.co.uk> >> =head1 License and Copyright Copyright (c) 2012 Peter Flanigan. All rights reserved This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L<perlartistic> This program is distributed in the hope that it will be useful, but WITHOUT WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE =cut # Local Variables: # mode: perl # tab-width: 3 # End: