# Copyright 2002-2008 Josh Clark and Global Moxie, LLC. This code cannot be # redistributed without permission from globalmoxie.com. For more # information, consult your Big Medium license. # # $Id: DiskUtil.pm 3245 2008-08-23 14:47:57Z josh $ package BigMed::DiskUtil; use strict; use utf8; use Carp; our @EXPORT_OK = qw( bm_file_path bm_load_file bm_write_file bm_delete_file bm_confirm_dir bm_check_space bm_file_chmod bm_datafile_chmod bm_dir_chmod bm_datadir_chmod bm_set_dir_chmod bm_set_datadir_chmod bm_set_file_chmod bm_set_datafile_chmod bm_untaint_filepath bm_copy_file bm_move_file bm_delete_dir bm_copy_dir bm_move_dir bm_dir_permissions ); use base 'Exporter'; use File::Spec; use BigMed::Error; use Fcntl qw(:DEFAULT :flock); use File::Copy; my $PERL_5_8 = ( $] >= 5.008 ); #determines utf-8 handling #these permission chmod values are defaults only; #the bm-setup.pl settings get priority over these values my $DIR_PERM = 0755; #public directory permissions my $DATADIR_PERM = 0700; #data directory permissions my $FILE_PERM = 0644; #public file permissions my $DATAFILE_PERM = 0600; #data directory permissions my $ERR = 'BigMed::Error'; ########################################################### # FILE/DIRECTORY ROUTINES ########################################################### sub bm_file_path { return File::Spec->catfile(@_); } sub bm_untaint_filepath { #faster to use $_[0] instead of var name here; #index also faster than regex # used to do this blacklist, which is just inherently insecure: # m{\A([^\|;<>\`\*\(\)\[\]\{\}\$\n\r]+)\z}ms # changed to whitelist no locale; if ( $_[0] && index( $_[0], q{..} ) < 0 && $_[0] =~ m{\A([\w_\-.\ ~@\(\)&!':/\\?,"]+)\z}ms ) { return $1; } my $path = $_[0]; $path = '[UNDEFINED]' if !defined $path; return $ERR->set_error( head => 'DISKUTIL_ERR_HEAD_Bad File Name', text => ['DISKUTIL_ERR_TEXT_Bad File Name', $path], ); } sub bm_load_file { return if !-e ( my $file = bm_untaint_filepath( $_[0] ) or return ); my $LOADFILE; open( $LOADFILE, '<', $file ) or return $ERR->set_io_error( $LOADFILE, 'open', $file, $! ); flock( $LOADFILE, 1 ) #just a tiny bit faster than LOCK_SH or return $ERR->set_io_error( $LOADFILE, 'lock_sh', $file, $! ); #scoped file handle closes on its own; modest improvement if #don't put file contents into an array before returning. if ($PERL_5_8) { binmode( $LOADFILE, ":utf8" ); return map { chomp; $_; } <$LOADFILE>; } else { #have to mark as utf8 return map { chomp; pack "U0C*", unpack "C*", $_ } <$LOADFILE>; } } sub bm_dir_chmod { $DIR_PERM } sub bm_datadir_chmod { $DATADIR_PERM } sub bm_file_chmod { $FILE_PERM } sub bm_datafile_chmod { $DATAFILE_PERM } sub bm_set_dir_chmod { $DIR_PERM = $_[0] if $_[0] } sub bm_set_datadir_chmod { $DATADIR_PERM = $_[0] if $_[0] } sub bm_set_file_chmod { $FILE_PERM = $_[0] if $_[0] } sub bm_set_datafile_chmod { $DATAFILE_PERM = $_[0] if $_[0] } sub bm_write_file { my $orig_path = shift; my $file = bm_untaint_filepath($orig_path) or return; my $contents = shift; my $rparam = shift; my %pref = ref $rparam eq 'HASH' ? %$rparam : (); my $chmod = $pref{data} ? $DATAFILE_PERM : $FILE_PERM; my ( $volume, $dir, $filename ) = File::Spec->splitpath($file); $dir = File::Spec->catpath( $volume, $dir, "" ); $dir =~ s![/\\]$!!; if ( $pref{build_path} ) { bm_confirm_dir( $dir, $rparam ) or return undef; } my $WRITEFILE; unless ( sysopen( $WRITEFILE, $file, O_WRONLY | O_TRUNC | O_CREAT, $chmod ) ) { $dir ||= 'moxiebin'; if ( $! eq "No such file or directory" ) { $ERR->set_error( head => 'DISKUTIL_ERR_HEAD_Could Not Write File', text => [ q{DISKUTIL_ERR_TEXT_Directory doesn't exist}, $filename, $dir ], ); } elsif ( $! eq "Permission denied" ) { $ERR->set_error( head => 'DISKUTIL_ERR_HEAD_Could Not Write File', text => [ 'DISKUTIL_ERR_TEXT_No_File_Write_Permission', $filename, $dir ], ); } else { $ERR->set_error( head => 'DISKUTIL_ERR_HEAD_Could Not Write File', text => [ 'DISKUTIL_ERR_TEXT_Could Not Write File', $filename, $dir, $! ], ); } return undef; } flock( $WRITEFILE, LOCK_EX ) or return $ERR->set_io_error( $WRITEFILE, "lock_ex", $file, $! ); if ( $pref{'binmode'} ) { binmode $WRITEFILE; } elsif ($PERL_5_8) { binmode( $WRITEFILE, ":utf8" ); } else { #perl 5.6 $contents = pack "C*", unpack "U0C*", $contents; } print $WRITEFILE $contents or return $ERR->set_io_error( $WRITEFILE, "write", $file, $! ); close($WRITEFILE) or return $ERR->set_io_error( undef, "close", $file, $! ); chmod $chmod, $file; return 1; } sub bm_delete_file { my $orig_path = shift; my $file = bm_untaint_filepath($orig_path) or croak "Bad filename: '$orig_path'"; if ( -e $file ) { unlink $file or return $ERR->set_io_error( undef, 'unlink', $file, $! ); } 1; } sub bm_delete_dir { my ($dirpath) = shift; my $dir = bm_untaint_filepath($dirpath) or return undef; if ( -e $dir ) { require File::Path; import File::Path; rmtree($dir) or return $ERR->set_io_error( undef, 'rmtree', $dir, $! ); } 1; } sub bm_copy_file { #expects orig, new, rparam (supported keys are build_path and data) my ( $orig, $new, $chmod ) = _vet_file_paths_and_chmod(@_); return undef if !$orig; copy( $orig, $new ) or return $ERR->set_io_error( undef, "copy", "$orig to $new", $! ); chmod $chmod, $new; 1; } sub bm_move_file { my ( $orig, $new, $chmod ) = _vet_file_paths_and_chmod(@_); return undef if !$orig; move( $orig, $new ) or return $ERR->set_io_error( undef, "move", "$orig to $new", $! ); chmod $chmod, $new; 1; } sub bm_copy_dir { my ( $old_dir, $new_dir ) = @_; ( $old_dir, $new_dir ) = _vet_file_paths_and_chmod( $old_dir, $new_dir, { build_path => 1 } ); return undef if !$old_dir; #caught error require File::Copy::Recursive; import File::Copy::Recursive qw(dircopy); eval { local $SIG{'__DIE__'}; #ignore any custom hooks dircopy( $old_dir, $new_dir ) or return $ERR->set_io_error( undef, "copy", "$old_dir to $new_dir", $! ); }; return $@ ? $ERR->set_io_error( undef, "copy", "$old_dir to $new_dir", $@ ) : 1; } sub bm_move_dir { my ( $old_dir, $new_dir ) = @_; ( $old_dir, $new_dir ) = _vet_file_paths_and_chmod( $old_dir, $new_dir, { build_path => 1 } ); return undef if !$old_dir; #caught error require File::Copy::Recursive; import File::Copy::Recursive qw(dirmove); eval { local $SIG{'__DIE__'}; #ignore any custom hooks dirmove( $old_dir, $new_dir ) or return $ERR->set_io_error( undef, "move", "$old_dir to $new_dir", $! ); }; return $@ ? $ERR->set_io_error( undef, "move", "$old_dir to $new_dir", $@ ) : 1; } sub _vet_file_paths_and_chmod { my ( $orig, $new, $rparam ) = @_; my %pref = ref $rparam eq 'HASH' ? %$rparam : (); my $chmod = $pref{data} ? $DATAFILE_PERM : $FILE_PERM; my $orig_ok = bm_untaint_filepath($orig) or return undef; my $new_ok = bm_untaint_filepath($new) or return undef; if ( $pref{build_path} ) { my ( $volume, $dir, $filename ) = File::Spec->splitpath($new_ok); $dir = File::Spec->catpath( $volume, $dir, "" ); $dir =~ s![/\\]$!! if length $dir > 1; bm_confirm_dir( $dir, $rparam ) or return (); } ( $orig_ok, $new_ok, $chmod ); } sub bm_confirm_dir { my $orig_path = shift or croak "No directory path supplied in bm_confirm_dir request"; my $param = shift; my $dir = bm_untaint_filepath($orig_path) or croak "Bad filename: '$orig_path'"; my %pref = ref $param ? %$param : (); my $chmod = $pref{data} ? $DATADIR_PERM : $DIR_PERM; if ( -e $dir || mkdir( $dir, $chmod ) ) { chmod $chmod, $dir; return 1; } ## DIRECTORY CREATION FAILED; Figure out why, and fix if we can my $error = $! || ""; my ( $volume, $parent_dir ) = File::Spec->splitpath($dir); my @directories = File::Spec->splitdir($parent_dir); my $dir_name = $pref{name} || 'directory'; my $dirnum = 1; if ( $error eq "No such file or directory" ) { #backup and find the last directory; most servers #don't need this (can just go forward through directory #path as in the loop below). But I've run into at least #one Windows setup where it could not see the top level #directories (-e tests failed), and only could see lower- #level dirs at wwwroot and below. So, climb backward from #the end to find the last directory that exists... then #move forward in loop below. $dirnum = @directories - 2; while ( $dirnum > 1 ) { my $test_path = File::Spec->catpath( $volume, File::Spec->catdir( @directories[0 .. $dirnum] ), q{} ); $test_path =~ s![/\\]$!!; #clip trailing slash last if -e $test_path; $dirnum--; } $dirnum = 1 if $dirnum < 1; #step forward through directory path to build missing directories, #building the directories if build_path is set. my $build_path = $pref{build_path}; while ( $dirnum <= @directories - 1 ) { my $test_path = File::Spec->catpath( $volume, File::Spec->catdir( @directories[0 .. $dirnum] ), "" ); $test_path =~ s![/\\]$!!; #clip trailing slash if ( !-e $test_path ) { if ( !$build_path ) { return $ERR->set_error( head => 'DISKUTIL_ERR_HEAD_Could Not Create Directory', text => [ 'DISKUTIL_ERR_TEXT_No such path', $dir, $test_path, $dir_name ], ); } else { bm_confirm_dir( $test_path, \%pref ) or return; } } $dirnum++; } if ($build_path) { #we've built the parent paths; try again delete $pref{build_path}; return bm_confirm_dir( $dir, \%pref ); } } if ( $error eq "Permission denied" ) { #is it a problem with execute permissions along the path? pop(@directories); #excludes the parent dir while ( $dirnum < @directories - 1 ) { my $test_path = File::Spec->catpath( $volume, File::Spec->catdir( @directories[0 .. $dirnum] ), "" ); $test_path =~ s![/\\]$!!; unless ( -x $test_path ) { $ERR->set_error( head => 'DISKUTIL_ERR_HEAD_Could Not Create Directory', text => [ 'DISKUTIL_ERR_TEXT_No Execute Permissions', $dir, $test_path, $dir_name ], ); return undef; } $dirnum++; } #is it because the parent directory is not writeable? my $test_path = File::Spec->catpath( $volume, $parent_dir, "" ); $test_path =~ s![/\\]$!!; if ( $parent_dir && !-w $test_path ) { $ERR->set_error( head => 'DISKUTIL_ERR_HEAD_Could Not Create Directory', text => [ 'DISKUTIL_ERR_TEXT_No Directory Write Perms', $dir, $test_path, $dir_name ], ); return undef; } elsif ( !$parent_dir ) { $ERR->set_error( head => 'DISKUTIL_ERR_HEAD_Could Not Create Directory', text => [ 'DISKUTIL_ERR_Cannot create directory in root dir', $dir_name ], ); return undef; } } #not sure why, pass along the system error $ERR->set_error( head => 'DISKUTIL_ERR_HEAD_Could Not Create Directory', text => [ 'DISKUTIL_ERR_miscellaneous directory error', $error, $dir_name, $dir ], ); return undef; } sub bm_check_space { #Should call this only after confirming that the directory #exists. #This is long, long way from a foolproof method and should #be improved. All we do here is write a short file and #make sure that it works correctly. Won't prevent out-of-space #errors that occur in the middle of writing data, but can #prevent problems when disk space is already gone. #also the kilobyte space check isn't currently implemented #but it's probably wise to include that parameter for when/if #it's eventually implemented # bm_check_space($directory_path, 1024) or $bigmed->error_stop; my $dir = shift; my $kilobytes = shift; #not currently implemented my $random = int( rand(1000000000) ); my $file = bm_file_path( $dir, "bm-test-$random.txt" ); my $test_text = "Big Medium content management system"; bm_write_file( $file, $test_text ) or return undef; my $got_space = ( -s $file == length($test_text) ); bm_delete_file($file) or return undef; return $ERR->set_error( head => 'DISKUTIL_ERR_HEAD_Out of Disk Space', text => 'DISKUTIL_ERR_TEXT_Out of Disk Space', ) if !$got_space; return 1; } sub bm_dir_permissions { my $orig_path = shift or croak "No directory path supplied in bm_dir_permissions request"; my $param = shift; my $dirpath = bm_untaint_filepath($orig_path) or croak "Bad filename: '$orig_path'"; croak "Not a directory: $dirpath" if !-d $dirpath; my %pref = ref $param ? %$param : (); my $dir_chmod = $pref{data} ? $DATADIR_PERM : $DIR_PERM; my $file_chmod = $pref{data} ? $DATAFILE_PERM : $FILE_PERM; chmod $dir_chmod, $dirpath; my $DIR; my @files; opendir( $DIR, $dirpath ) or return $ERR->set_io_error( $DIR, 'opendir', $dirpath, $! ); while ( defined( my $file = readdir($DIR) ) ) { push @files, $file if index( $file, '.' ) != 0; } closedir($DIR); foreach my $file (@files) { my $path = bm_untaint_filepath( bm_file_path( $dirpath, $file ) ) or return; if ( -d $path ) { bm_dir_permissions( $path, $param ) or return; } else { chmod $file_chmod, $path; } } return 1; } 1; __END__ =head1 NAME BigMed::DiskUtil - Common file and directory I/O operations =head1 DESCRIPTION BigMed::DiskUtil provides several routines to help read and write files and directories, providing support for the Big Medium content management system. BigMed::DiskUtil exports routines only on demand, so your C statement should explicitly name the routines you would like to import into your package namespace. =head2 SYNOPSIS use BigMed::DiskUtil qw( bm_file_path bm_load_file bm_write_file bm_confirm_dir bm_check_space bm_file_chmod bm_datafile_chmod bm_dir_chmod bm_datadir_chmod bm_set_dir_chmod bm_set_datadir_chmod bm_set_file_chmod bm_set_datafile_chmod bm_untaint_filepath bm_copy_file bm_move_file bm_copy_dir bm_move_dir bm_delete_dir ); #build a platform-specific file path my $dir_path = bm_file_path('full', 'path', 'to', 'directory'); #make sure it's a safe file path $dir_path = bm_untaint_filepath($dir_path) or BigMed::Error->error_stop; #make sure we have a data directory at that location; #build it if necessary bm_confirm_dir($dir_path, {data => 1, build_path => 1}) or BigMed::Error->error_stop; #see if there's disk space to write to that directory bm_check_space($dir_path, 1024); #get the file path for our file my $file_path = bm_file_path($dir_path, 'filename.txt'); #write to that file - specify with data permissions bm_write_file($file_path, $file_contents, {data => 1}) or BigMed::Error->error_stop; #read the file my @file_lines = bm_load_file($file_path) or (BigMed::Error->error && BigMed::->error_stop); #copy the file bm_copy_file( $file_path, $copy_file_path, {data => 1, build_path => 1} ) or BigMed::Error->error_stop; #move the file bm_move_file( $file_path, $new_file_path, {data => 1, build_path => 1} ) or BigMed::Error->error_stop; #delete a file bm_delete_file( $file_path ) or BigMed::Error->error_stop; =head1 USAGE =head3 C<< bm_build_path(@path_elements) >> Builds a file pathname that is appropriate to the operating system. Send the method one or more directory names and a filename to form a complete path ending with a filename. my $path = BigMed->build_path( @directories, $filename ); =head3 C<< bm_confirm_dir($dir_path, \%options) >> Returns true if a directory exists at the $dir_path location. If no directory exists or if there's a request to build the path to the directory and the routine is unable to do so, the return value will be untrue and an error will be added to the BigMed::Error queue. bm_confirm_dir($dir_path, {data=>1, build_path=>1}) or BigMed::Error->error_stop; The optional second argument may contain a hash reference of options: =over 4 =item * data => 1 If set to a true value, the directory will be given the relatively more restrictive settings of a data directory. If not, it will be given permissions for a public directory (e.g., for html files). =item * build_path => 1 If set to a true value and the directory does not exist, the routine will try to create the directory, including any missing parent directories. These directories will be set to have the same permission as the target directory, based on the value of the data option. =back =head3 C<< bm_write_file($file_path, $contents, \%options) >> Creates or replaces a file at $file_path with the contents specified in $contents. Returns true if successful. If there's a problem, returns untrue and adds an error to the BigMed::Error queue. bm_write_file( $file_path, $contents, { data => 1, build_path => 1 } ) or ( BigMed::Error->error && BigMed::->error_stop ); The optional third argument may contain a hash reference of options: =over 4 =item * data => 1 If set to a true value, the file will be given the relatively more restrictive settings of a data directory. If not, it will be given permissions for a public file (e.g., for html files). =item * build_path => 1 If set to a true value and the parent directory does not exist, the routine will try to create the directory, including any missing parent directories. If the data option is set, these directories will be set with data permissions; otherwise, they will be set with public permissions. =item * binmode => 1 If true, the file will be saved with binmode enabled. =back =head3 C<< bm_load_file($filepath) >> Returns a chomped array corresponding to the lines of the file in the passed file path. Returns an empty array if the file does not exist or if there was an error reading the file: my @file_lines = bm_load_file($file_path) or (BigMed::Error->error && BigMed::->error_stop); =head3 C<< bm_delete_file($filepath) >> Deletes the file named in the filepath argument. Returns true if successful (or if the file does not exist). Returns false and sets an error message if the file could not be deleted. =head3 C<< bm_delete_dir($directory_path) >> Recursively deletes the directory and all of its contents (be careful!). Returns true if successful (or if the file already does not exist). Returns false and sets an error message if there's trouble. =head3 C<< bm_check_space($dir_path, $kilobytes) >> This is a relatively weak disk-space check. It currently creates a very small file and, if that file has the expected size, the routine proclaims success. This is really just a last-ditch hedge against writing files when a disk quota is blocking write access. Returns true if there's disk space. If not, returns untrue value and adds an error message to the Bigmed::Error queue. The $dir_path argument determines where the test file will be written. The $kilobytes argument is currently not implemented but will likely eventually trigger a test for a file of a specific size. Even though it doesn't do anything now, it's recommended that you still provide a kilobyte size. bm_check_space('path/to/directory', 1024) or BigMed::Error->error_stop; =head3 C<< bm_untaint_filepath($file_path) >> Checks a filepath to make sure that it does not contain any of the following characters and, if it's clean, returns the untainted filepath: .. | ; < > ` * ( ) [ ] { } $ \n \r Returns undef if the filename contains any of those characters. =head3 C<< bm_move_file($orig_file_path, $new_file_path, \%options) >> Moves a file from $orig_file_path to $new_file_path. Returns true if successful. If there's a problem, returns untrue and adds an error to the BigMed::Error queue. bm_move_file( $file_path, $new_file_path, { data => 1, build_path => 1 } ) or BigMed::->error_stop; The optional third argument may contain a hash reference of options: =over 4 =item * data => 1 If set to a true value, the moved file will be given the relatively more restrictive settings of a data directory. If not, it will be given permissions for a public file (e.g., for html files). =item * build_path => 1 If set to a true value and the directory for the new file location does not exist, the routine will try to create the directory, including any missing parent directories. If the data option is set, these directories will be set with data permissions; otherwise, they will be set with public permissions. =back =head3 C<< bm_copy_file($orig_file_path, $new_file_path, \%options) >> Same behavior as bm_move_file except that it copies and leaves the original file in the same location. =head3 C<< bm_copy_dir($orig_file_path, $new_file_path, \%options) >> Recursively copies all of a directory's contents to the new directory, building directories along the path if necessary. If a directory already exists at the target directory path, the files in that directory are left intact and the files are copied from the original location into the existing target directory; otherwise, a new directory is created. The routine tries to maintain the same permissions as the original files. =head3 C<< bm_move_dir($orig_file_path, $new_file_path ) >> Recursively moves all of a directory's contents to the new directory, building directories along the path if necessary. If a directory already exists at the target directory path, the files in that directory are left intact and the files are moved from the original location into the existing target directory; otherwise, a new directory is created. The routine tries to maintain the same permissions as the original files. =head3 C Returns the current octal value for "public" file permissions. =head3 C Returns the current octal value for "data" file permissions. =head3 C Returns the current octal value for "public" directory permissions. =head3 C Returns the current octal value for "data" directory permissions. =head3 C Sets the octal value for "public" file permissions. =head3 C Sets the octal value for "data" file permissions. =head3 C Sets the octal value for "public" directory permissions. =head3 C Sets the octal value for "data" directory permissions. =head2 Notes =head3 About chmod and octal values Be careful when setting the chmod values. Although numeric chmod values might commonly be referred to as decimal values (e.g. 777 for world-writeable/executable, 666 for world-readable/writeable), these are actually octal values: 0777 and 0666 respectively. The values for the chmod getters/setters should likewise be octal values. If your values are held in a string, you can convert them to octal values like this: my $octal = oct '0777'; #converts string '0777' to octal 0777. =head1 AUTHOR & COPYRIGHTS This module and all Big Medium modules are copyright Josh Clark and Global Moxie. All rights reserved. Use of this module and the Big Medium content management system are governed by Global Moxie's software licenses and may not be used outside of the terms and conditions outlined there. For more information, visit the Global Moxie website at L. Big Medium and Global Moxie are service marks of Global Moxie and Josh Clark. All rights reserved. =cut