From e8f996f64cf59b4650e3d92377647f66b3053a2d Mon Sep 17 00:00:00 2001 From: b Date: Thu, 4 Jan 2024 12:53:27 +0000 Subject: [PATCH] filesystem encoding aware system functions --- botm_common.pm | 179 +++++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 165 insertions(+), 14 deletions(-) diff --git a/botm_common.pm b/botm_common.pm index 1bdac0c..3cb1c7f 100644 --- 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; } } -- 2.30.2