filesystem encoding aware system functions

diff --git a/botm_common.pm b/botm_common.pm
index 1bdac0ccac244d64879d23b855800b825bf99880..3cb1c7f3a6e540b9804cea2f6df4c97636751f14 100644 (file)
--- a/botm_common.pm
+++ b/botm_common.pm
@@ -22,10 +22,11 @@ use feature 'state';
 
 use Encode::Locale;
 use Encode ('encode', 'decode');
+use File::Copy;
 
 use Exporter;
 
-our $VERSION     = '1.0.25';
+our $VERSION     = '1.0.26';
 our @ISA         = qw(Exporter);
 our @EXPORT      = ();
 our @EXPORT_OK   = (
@@ -36,7 +37,11 @@ our @EXPORT_OK   = (
        'split_url', 'join_url', 'merge_url',
        'html_entity_encode_dec', 'html_entity_encode_hex', 'html_entity_encode_name', 'html_entity_decode',
        'join_path', 'dir_path', 'make_temp_path',
-       'system_encoded', 'exec_encoded'
+       'system_encoded', 'exec_encoded',
+       'opendir_encoded', 'readdir_decoded',
+       '_x_encoded', 'stat_encoded',
+       'unlink_encoded', 'rename_encoded', 'copy_encoded',
+       'open_encoded'
 );
 
 
@@ -120,32 +125,178 @@ sub make_temp_path {
 ##  ENCODING + SYSTEM FUNCTIONS  ##
 ###################################
 
+# exec
+
 sub system_encoded {
        (my $cmd, my @arg) = @_;
-       my @newarg;
+       my @new_arg;
        
-       my $newcmd = encode('locale_fs', $cmd);
+       my $new_cmd = encode('locale_fs', $cmd);
        
        foreach my $a (@arg) {
-               push @newarg, encode('locale', $a);
+               push @new_arg, encode('locale', $a);
        }
        
-       return system {$newcmd} @newarg;
+       return system {$new_cmd} @new_arg;
 }
 
 sub exec_encoded {
        (my $cmd, my @arg) = @_;
-       my @newarg;
+       my @new_arg;
        
-       my $newcmd = encode('locale_fs', $cmd);
+       my $new_cmd = encode('locale_fs', $cmd);
        
        foreach my $a (@arg) {
-               push @newarg, encode('locale', $a);
+               push @new_arg, encode('locale', $a);
        }
        
-       return exec $newcmd, @newarg;
+       return exec $new_cmd, @new_arg;
+}
+
+# dir
+
+sub opendir_encoded {
+       return opendir($_[0], encode('locale_fs', $_[1]));
 }
 
+sub readdir_decoded {
+       return decode('locale_fs', readdir $_[0]);
+}
+
+# file
+
+sub _x_encoded {
+       (my $x, my $expr) = @_;
+       $expr = encode('locale_fs', $expr);
+       if ($x eq '-r') {
+               return -r $expr; # File is readable by effective uid/gid.
+       }
+       elsif ($x eq '-w') {
+               return -w $expr; # File is writable by effective uid/gid.
+       }
+       elsif ($x eq '-x') {
+               return -x $expr; # File is executable by effective uid/gid.
+       }
+       elsif ($x eq '-o') {
+               return -o $expr; # File is owned by effective uid.
+       }
+       elsif ($x eq '-R') {
+               return -R $expr; # File is readable by real uid/gid.
+       }
+       elsif ($x eq '-W') {
+               return -W $expr; # File is writable by real uid/gid.
+       }
+       elsif ($x eq '-O') {
+               return -O $expr; # File is executable by real uid/gid.
+       }
+       elsif ($x eq '-O') {
+               return -O $expr; # File is owned by real uid.
+       }
+       elsif ($x eq '-e') {
+               return -e $expr; # File exists.
+       }
+       elsif ($x eq '-z') {
+               return -z $expr; # File has zero size (is empty).
+       }
+       elsif ($x eq '-s') {
+               return -s $expr; # File has nonzero size (returns size in bytes).
+       }
+       elsif ($x eq '-f') {
+               return -f $expr; # File is a plain file.
+       }
+       elsif ($x eq '-d') {
+               return -d $expr; # File is a directory.
+       }
+       elsif ($x eq '-l') {
+               return -l $expr; # File is a symbolic link (false if symlinks aren't supported by the file system).
+       }
+       elsif ($x eq '-p') {
+               return -p $expr; # File is a named pipe (FIFO), or Filehandle is a pipe.
+       }
+       elsif ($x eq '-S') {
+               return -S $expr; # File is a socket.
+       }
+       elsif ($x eq '-b') {
+               return -b $expr; # File is a block special file.
+       }
+       elsif ($x eq '-c') {
+               return -c $expr; # File is a character special file.
+       }
+       elsif ($x eq '-t') {
+               return -t $expr; # Filehandle is opened to a tty.
+       }
+       elsif ($x eq '-u') {
+               return -u $expr; # File has setuid bit set.
+       }
+       elsif ($x eq '-g') {
+               return -g $expr; # File has setgid bit set.
+       }
+       elsif ($x eq '-k') {
+               return -k $expr; # File has sticky bit set.
+       }
+       elsif ($x eq '-T') {
+               return -T $expr; # File is an ASCII or UTF-8 text file (heuristic guess).
+       }
+       elsif ($x eq '-B') {
+               return -B $expr; # File is a "binary" file (opposite of -T).
+       }
+       elsif ($x eq '-M') {
+               return -M $expr; # Script start time minus file modification time, in days.
+       }
+       elsif ($x eq '-A') {
+               return -A $expr; # Same for access time.
+       }
+       elsif ($x eq '-C') {
+               return -C $expr; # Same for inode change time (Unix, may differ for other platforms)
+       }
+       else {
+               return 0;
+       }
+}
+
+sub stat_encoded {
+       return stat(encode('locale_fs', $_[0]));
+}
+
+sub unlink_encoded {
+       my @list;
+       foreach my $f (@_) { 
+               push @list, encode('locale_fs', $f);
+       }
+       return unlink @list;
+}
+
+sub rename_encoded {
+       return rename(encode('locale_fs', $_[0]), encode('locale_fs', $_[1]));
+}
+
+sub copy_encoded {
+       return copy(encode('locale_fs', $_[0]), encode('locale_fs', $_[1]));
+}
+
+sub open_encoded {
+       my $len = scalar @_;
+       
+       if ($len == 0) { # ???
+       return 0;
+       }
+       elsif ($len == 1) { # open FILEHANDLE
+               return open($_[0]);
+       }
+       elsif ($len == 2) { # open FILEHANDLE,EXPR
+               return open($_[0], encode('locale_fs', $_[1]));
+       }
+       elsif ($len == 3) { # open FILEHANDLE,MODE,EXPR
+               return open($_[0], $_[1], encode('locale_fs', $_[2]));
+       }
+       else { # open FILEHANDLE,MODE,EXPR,LIST
+               my @list;
+               for (my $i=3; $i<=$len; $i+=1) {
+                       push @list, encode('locale', $_[$i]);
+               }
+               return open($_[0], $_[1], encode('locale_fs', $_[2]), @list);
+       }
+}
 
 
 ##################
@@ -221,7 +372,7 @@ sub read_data_file {
                }
        }
        else {
-               unless (open ($fh, "<:encoding($encoding)", encode('locale_fs', $file))) {
+               unless (open_encoded($fh, "<:encoding($encoding)", $file)) {
                        return %data;
                }
        }
@@ -310,7 +461,7 @@ sub write_data_file {
                }
        }
        else {
-               unless (open ($fh, ">:encoding($encoding)", encode('locale_fs', $file))) {
+               unless (open_encoded($fh, ">:encoding($encoding)", $file)) {
                        return 0;
                }
        }
@@ -361,7 +512,7 @@ sub write_postdata_file {
                }
        }
        else {
-               unless (open ($fh, ">:encoding($encoding_file)", encode('locale_fs', $file))) {
+               unless (open_encoded($fh, ">:encoding($encoding_file)", $file)) {
                        return 0;
                }
        }
@@ -429,7 +580,7 @@ sub read_header_file {
                }
        }
        else {
-               unless (open ($fh, "<:encoding($encoding)", encode('locale_fs', $file))) {
+               unless (open_encoded($fh, "<:encoding($encoding)", $file)) {
                        return %data;
                }
        }