Beefy Boxes and Bandwidth Generously Provided by pair Networks
XP is just a number
PerlMonks - Shoots Holes in Files

by BlueSquare23 (Novice)
on Jan 29, 2024 at 23:27 UTC ( [id://11157349]=CUFP: print w/replies, xml ) Need Help??

Shoots Holes in Files

    Cyber weapon! For home defense purposes only!

Have you ever had a file you just wanted to blast with a shotgun? Now you can!

Can play audio files via aplay or mpv (tested on Ubuntu). Or use -quiet to run with no sound effects.

#!/usr/bin/env perl # This script shoots holes in files. # Written by John R., Nov. 2023 use strict; use warnings; use lib "$ENV{HOME}/perl5/lib/perl5"; use Getopt::Long; use File::Slurp qw(read_file); use File::JSON::Slurper qw(read_json write_json); use File::Touch 0.12; use IPC::Cmd 'run_forked'; use String::ShellQuote; use Data::Dumper; use JSON; # Change as needed. Tested and should work with `aplay` and `mpv` on U +buntu. my $AUDIO_PLAYER = '/usr/bin/mpv'; sub usage { my $err_msg = shift; print "$err_msg\n" if $err_msg; print <<~EOF; Name: - Shoots holes in files Usage: [options] Options (required, at least one): -target File you want to shoot holes in -reload Reload magazine file -check Check the mag Options (optional): -help Print this help menu -type [double|pump] Shotgun type -load [bird|buck|slug] Type of ammunition -shots [int] Number of shots to fire or load -quiet Mute sound effect -debug Debug mode, takes no action -verbose Verbose mode, more verbose output Defaults: -type double -load bird EOF exit; } my $MAG_FILE = 'mag.txt'; my %O = ( debug => 0, verbose => 1, type => 'double', load => 'bird', ); GetOptions(\%O, 'help', 'debug', 'verbose!', 'target=s', 'type=s', 'load=s', 'shots=i', 'reload', 'check', 'quiet', ) or usage(); $O{verbose}++ if $O{debug}; $O{verbose} = 0 if $O{quiet}; # Sanity checks. usage() if $O{help}; usage("Missing required argument!") unless $O{target} or $O{reload} or + $O{check}; usage("Invalid shotgun type!") unless($O{type} =~ /double|pump/); usage("Invalid ammo type!") unless($O{load} =~ /bird|buck|slug/); unless (-e $MAG_FILE) { print "Mag file not found, reloading...\n" if $O{verbose}; touch($MAG_FILE); reload(); } reload() if $O{reload}; check() if $O{check}; exit unless $O{target}; die("Target file does not exits!") unless -e $O{target}; die("Target file must be plain text!") unless -f $O{target}; die("Target file must be under 1 GB!") if -s $O{target} > (1024 * 1024 +); my $MAG = read_json($MAG_FILE) or die("Problem reading mag file!"); unless ($MAG->{$O{type}}) { print "Mag for $O{type} not loaded, you'll need to reload!\n"; exit; } if ($MAG->{$O{type}}->{num_rounds} == 0) { print "Mag empty, you'll need to reload!\n"; exit; } while ($MAG->{$O{type}}->{num_rounds} > 0) { shoot(); $MAG->{$O{type}}->{num_rounds}--; write_json($MAG_FILE, $MAG); } exit; ## Subroutines sub reload { my $num_rounds = 2; $num_rounds = 5 if $O{type} eq 'pump'; $num_rounds = $O{shots} if $O{shots} and $O{shots} < $num_rounds; my %load = ( 'num_rounds' => $num_rounds, 'load' => $O{load}, ); my %full_load = ($O{type} => \%load); write_json($MAG_FILE, \%full_load); unless ($O{quiet}) { for (my $i = 0; $i < $num_rounds; $i++) { print "Loading shot $i\n" if $O{verbose}; run_forked(join(" ", $AUDIO_PLAYER, "$O{type}_reload.wav") +); } } print "Shotgun reloaded!\n"; check() if $O{verbose}; } sub shoot { return if $O{debug}; my @lines = read_file($O{target}); # We're only going to work in this space. my $height = @lines; my $width = 80; my $v_buffer = int rand($height); my $h_buffer = int rand($width); my $v_spread = 7; my $h_spread = 13; my $r = int rand(3); for (my $v=0; $v < $v_spread; $v++) { my $v_offset = $v_buffer + $v; last if $v_offset >= $height; my @line = split '', $lines[$v_offset]; for (my $h=0; $h < $h_spread; $h++) { my $h_offset = $h_buffer + $h; # Belt and suspenders. last if $h_offset >= @line; last if $line[$h_offset] eq "\n"; if ($O{load} eq 'buck') { my %pattern0 = (0=>[6,7], 1=>[1,2,6,7], 2=>[1,2,11,12], 3=>[6,7,11,12], 4=>[1,2,6,7], 5=>[1,2,9,10], 6=>[9,10]); my %pattern1 = (0=>[1,2,9,10], 1=>[1,2,9,10], 2=>[5,6], 3=>[1,5,6,10,11], 4=>[1,2,10,11], 5=>[6,7], 6=>[6,7]); my %pattern2 = (0=>[5,6,7], 1=>[1,2,6,10,11], 2=>[1,2,10,11], 3=>[5,6,7], 4=>[1,2,6], 5=>[1,2,10], 6=>[9,10]); my %buck = (0 => \%pattern0, 1 => \%pattern1, 2 => \%pattern2); $line[$h_offset] = " " if grep {$_ == $h} @{$buck{$r}- +>{$v}}; } elsif ($O{load} eq 'slug') { my %pattern0 = (0=>[5,6,7], 1=>[5,6]); my %pattern1 = (0=>[5,6], 1=>[5,6,7]); my %pattern2 = (0=>[5,6], 1=>[4,5,6]); my %slug = (0 => \%pattern0, 1 => \%pattern1, 2 => \%pattern2); $line[$h_offset] = " " if grep {$_ == $h} @{$slug{$r}- +>{$v}}; } else { my %pattern0 = (0=>[6], 1=>[3,9], 2=>[6], 3=>[3], 4=>[1,6,10], 5=>[4], 6=>[0,7]); my %pattern1 = (0=>[6], 1=>[3,9], 2=>[6,11], 3=>[3,7,9], 4=>[6,10], 5=>[4,9], 6=>[7,11]); my %pattern2 = (0=>[6,9], 1=>[2,4,7], 2=>[5,9], 3=>[1,7], 4=>[6], 5=>[3,6,9], 6=>[5]); my %bird = (0 => \%pattern0, 1 => \%pattern1, 2 => \%pattern2); $line[$h_offset] = " " if grep {$_ == $h} @{$bird{$r}- +>{$v}}; } $lines[$v_offset] = join('', @line); } } open my $fh, '>', $O{target} or die("Unable to open target file!") +; foreach (@lines) { print $fh $_; } close $fh; # For dramatic effect. print "POW!\n" and return if $O{quiet}; run_forked(join(" ", $AUDIO_PLAYER, "$O{type}.wav")); print "POW!\n"; run_forked(join(" ", $AUDIO_PLAYER, "shot.wav")); } sub check { $MAG = read_json($MAG_FILE) or die("Problem reading mag file!"); print JSON->new->ascii->pretty->encode($MAG); }

Source on My Github Video of Script in Action

Replies are listed 'Best First'.
Re: - Shoots Holes in Files
by harangzsolt33 (Chaplain) on Jan 30, 2024 at 01:12 UTC
    Excuse me. I have a question regarding this line:

    die("Target file must be plain text!") unless -f $O{target};

    I thought that -f tests if a file is a plain file. In other words if it's not a directory or some other weird thing that you might encounter in a Linux file system. I was also told that -f tests if a file exists. If it doesn't, it returns false. If it's a directory, it returns false. If it's a real file that has byte contents, whether it's binary or plain text, it will return true. Am I correct?

      harangzsolt33, further to ++Fletch's spot-on reply, just a bit more detail, in case you find it useful.

      From perldoc -X file test, note that the -T/-B file test operators (to tell if a file is an ASCII or UTF-8 text file or not) is done via a heuristic guess as follows:

      The first block or so of the file is examined to see if it is valid UTF-8 that includes non-ASCII characters. If so, it's a -T file. Otherwise, that same portion of the file is examined for odd characters such as strange control codes or characters with the high bit set. If more than a third of the characters are strange, it's a -B file; otherwise it's a -T file.

      Also, any file containing a zero byte in the examined portion is considered a binary file. (If executed within the scope of a use locale which includes LC_CTYPE, odd characters are anything that isn't a printable nor space in the current locale.) If -T or -B is used on a filehandle, the current IO buffer is examined rather than the first block. Both -T and -B return true on an empty file, or a file at EOF when testing a filehandle. Because you have to read a file to do the -T test, on most occasions you want to use a -f against the file first, as in: next unless -f $file && -T $file.

      See also:

      References added later

      • perlfaq5 - Files and Formats (perldoc)
      • perldata - Perl data types (perldoc)
      • functions - Built-in functions (perldoc) - see "Functions for filehandles, files, or directories" and "Input and output functions"


      <Ed McMahon voice>YOU ARE CORRECT SIR!</Ed McMahon voice>

      -T FH says whether a file is "text" and -B FH says whether a file is "binary".

      Naked blocks are fun! -- Randal L. Schwartz, Perl hacker

      One could RTFM (-X) and also experiment to find out . . .

      The cake is a lie.
      The cake is a lie.
      The cake is a lie.

      Good catch! Yeah I guess since I left && -T $O{target} off of that plain text check line, you can technically use this to shoot binaries as well. Works great too, completely destroys them!
      cp /usr/bin/ls . ./ls double_reload.wav ls mag.txt pump.wav reload.wav sh +ot.wav wall.txt ./ -reload -type pump -load buck -verbose -target ls Loading shot 0 Loading shot 1 Loading shot 2 Loading shot 3 Loading shot 4 Shotgun reloaded! { "pump" : { "num_rounds" : 5, "load" : "buck" } } POW! POW! POW! POW! POW! diff ls /usr/bin/ls Binary files ls and /usr/bin/ls differ ./ls Segmentation fault (core dumped)
      Unfortunately, of course the pattern is not exactly visible in the same way as shooting a -T (ASCII or UTF-8) plain text file. But the destructive capabilities are still there!

Log In?

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: CUFP [id://11157349]
Approved by LanX
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others making s'mores by the fire in the courtyard of the Monastery: (3)
As of 2024-06-18 19:18 GMT
Find Nodes?
    Voting Booth?

    No recent polls found

    erzuuli‥ 🛈The London Perl and Raku Workshop takes place on 26th Oct 2024. If your company depends on Perl, please consider sponsoring and/or attending.