|
| 1 | +#!/usr/bin/env perl |
| 2 | +# VFS-wrapper for MS-DOS IMG files using mtools |
| 3 | +# |
| 4 | +# Written by twojstaryzdomu (twojstaryzdomu@users.noreply.github.com), 2021 |
| 5 | +# |
| 6 | + |
| 7 | +my ( $cmd, $archive, @args ) = @ARGV; |
| 8 | +die "$archive does not exist\n" unless -f "$archive"; |
| 9 | +my $size_kb = ( -s $archive ) / 1024; |
| 10 | +my $drive = 'b'; |
| 11 | + |
| 12 | +my $actions = { |
| 13 | + list => "mdir -f -i \'$archive\'", |
| 14 | + copyout => "mcopy -m -n -o -p -i \'$archive\'", |
| 15 | + copyin => "mcopy -m -n -o -p -i \'$archive\'", |
| 16 | + rm => "mdel -i \'$archive\'", |
| 17 | + mkdir => "mmd -i \'$archive\'", |
| 18 | + rmdir => "mrd -i \'$archive\'", |
| 19 | + run => "dosbox -noautoexec -c \'IMGMOUNT -size $size_kb $drive: \'$archive\'\' -c '$drive:\' -c", |
| 20 | + test => "logger \'$archive\'" |
| 21 | +}; |
| 22 | + |
| 23 | +my $regex_list = qr"^(\S+)\s+(\S*)\s+(\S+)\s+(\d{4})-(\d{2})-(\d{2})\s+(\d{1,2}):(\d{1,2})(?:\s*)(\S+)*\s*$"; |
| 24 | + |
| 25 | +sub print_debug { |
| 26 | + print "@_\n" if exists $ENV{DEBUG}; |
| 27 | +} |
| 28 | + |
| 29 | +sub run_cmd { |
| 30 | + my $cmd = shift; |
| 31 | + my @output = ( do { open( my $line, "$cmd | " ) or die "$0: Can't run $cmd"; <$line>; } ); |
| 32 | + print_debug "run_cmd $cmd"; |
| 33 | + return \@output; |
| 34 | +} |
| 35 | + |
| 36 | +sub check_mtools { |
| 37 | + my $cmd = shift; |
| 38 | + my ( $tool ) = $actions->{ $cmd } =~ /^(\w+)/; |
| 39 | + foreach ( split( ":", $ENV{PATH} ) ) { |
| 40 | + return 1 if -e "$_/$tool" |
| 41 | + } |
| 42 | + return; |
| 43 | +} |
| 44 | + |
| 45 | +sub default_handler { |
| 46 | + my ( $cmd, $archive, @args ) = ( @_ ); |
| 47 | + print_debug "default_handler: @args"; |
| 48 | + if ( $cmd eq 'copyin' ) { |
| 49 | + if ( my ( $name, $ext ) = $args[0] =~ /(\w+)\.(\w+)$/ ) { |
| 50 | + die "filename $name.$ext too long to copy to $archive\n" if ( length( $name ) > 8 || length( $ext ) > 3 ); |
| 51 | + } |
| 52 | + $args[0] = "::$args[0]"; |
| 53 | + @args = reverse @args; |
| 54 | + } |
| 55 | + elsif ( $cmd eq 'copyout' ) { |
| 56 | + $args[0] = "::$args[0]"; |
| 57 | + } |
| 58 | + my $output = run_cmd "$actions->{ $cmd } @args"; |
| 59 | + if ( $cmd eq 'list' ) { |
| 60 | + my $exec = check_mtools( run ) |
| 61 | + ? 'rwxr-xr-x' |
| 62 | + : 'rw-r--r--'; |
| 63 | + foreach ( @{ $output } ) { |
| 64 | + chomp; |
| 65 | + next if /^$/; |
| 66 | + if ( my ( $name, $ext, $size, $year, $mon, $day, $hours, $mins, $longname ) = $_ =~ /$regex_list/ ) { |
| 67 | + print_debug "list: name = $name, ext = $ext, size = $size, year = $year, mon = $mon, day = $day, hours = $hours, mins = $mins, longname = $longname"; |
| 68 | + next if ( $name eq '.' || $name eq '..' ); |
| 69 | + my $perms = ( $size ne '<DIR>' |
| 70 | + ? '-' |
| 71 | + : 'd' ) |
| 72 | + . ( ( $ext eq 'exe' || $ext eq 'com' || $ext eq 'bat' ) |
| 73 | + ? $exec |
| 74 | + : 'rw-r--r--' ); |
| 75 | + my $path = $longname |
| 76 | + ? "$args[0]/$longname" |
| 77 | + : uc( "$args[0]/$name" . ( $ext ? ".$ext" : "" ) ); |
| 78 | + $secs = defined $secs ? $secs : "00"; |
| 79 | + printf "%-10s 1 %-8d %-8d %8s %s/%s/%s %s:%s:%s %s", $perms, $<, |
| 80 | + $(, $size ne '<DIR>' ? $size : 0, $mon, $day, $year, $hours, $mins, $secs, $path |
| 81 | + . "\n"; |
| 82 | + default_handler( $cmd, $archive, $path ) if ( $size eq '<DIR>' ); |
| 83 | + } |
| 84 | + else { |
| 85 | + print_debug "list: skipped: $_"; |
| 86 | + } |
| 87 | + } |
| 88 | + } |
| 89 | +} |
| 90 | + |
| 91 | +print_debug "$0: cmd = $cmd; archive = $archive; args = @args"; |
| 92 | +die "Cannot find command $cmd, are mtools installed?\n" unless check_mtools( $cmd ); |
| 93 | +exists $actions->{ $cmd } ? default_handler( $cmd, $archive, @args ) |
| 94 | + : die "mode $cmd not available\n"; |
0 commit comments