Beefy Boxes and Bandwidth Generously Provided by pair Networks
We don't bite newbies here... much
 
PerlMonks  

My Perl Obfuscator

by harangzsolt33 (Chaplain)
on Jan 11, 2024 at 05:46 UTC ( [id://11156860]=obfuscated: print w/replies, xml ) Need Help??

I have written a similar program for JavaScript years ago, and now this is for Perl!

Disclaimer: I'd still call myself a beginner Perl programmer, which means I am not familiar with every trick in the book! But I tried to write a perl program that reads another perl script and breaks it down into basic units such as symbols, strings, numbers, variables, barewords, regex, etc. It changes all the variable names to shortest possible names and then rejoins the code without unnecessary spaces. It knows to update the variable names inside double-quoted strings and backticks and inside regexes also. It removes all comments, pods, and anything that comes after __END__. It removes spaces and line breaks except when they occur inside strings or heredoc. The code becomes about 75% smaller.

What I like to see is that even after it has squeezed the spaces out, I can run the obfuscator on the already obfuscated script, and it doesn't break the code. What I don't understand yet is that it's not supposed to throw away essential parts of the code, yet for some reason if I run the program on itself, it becomes smaller and smaller. If I feed the obfuscated code to the obfuscator again, it becomes a few bytes smaller each time. And the script still runs without errors. I don't understand what's going on. (Edit: I think, I know what's going on. Get rid of the Shuffle() function, and the program will generate the shortest code possible everytime.)

I haven't done a lot of testing, but the program looks okayish. I have run it on two fairly complex scripts, and they still worked after being obfuscated, so that's good news. If you find any bugs, I would appreciate if you could share the problematic script that resulted in the errors, so I know what causes the glitch. Known problems: I know for a fact that I did not write the program to remove comments when they appear inside a multiline regex, so if you have a script with comments inside a multiline regex, I don't know how the obfuscator will handle that!

EDIT: 1/11/2024: Completely eliminated the Shuffle() function as it made the output code larger.
Made some minor changes to the CreateFile() ReadFile() functions suggested by Randal Schwartz. Thanks you!
1/12/2024: Eliminated some unnecessary tests in detecting variables which made the code bloated such as testing for $A[$B] when this can be done in two steps. Also made a decision not to replace variables such as $^A in the code, because it could cause warnings to appear when running the obfuscated code.

Before you run this script, you must change two variables -- $INPUT_FILE and $OUTPUT_FILE which are defined near the beginning of the file.

#!/usr/bin/perl -w # # Zsolt's Perl Compressor & Obfuscator v1 # # This program breaks up a perl script into basic code units # and then changes all the variable names and then puts the # pieces back together with only the minimum number of # spaces needed. # # Written by Zsolt N. Perry in January 2024, Pensacola, Fla. # For questions, bug reports, feature requests, general feedback, # write to Zsolt at zsolt500n@gmail.com or zsnp500@cox.net. # # THIS SOFTWARE IS DISTRIBUTED FOR FREE "AS IS" WITHOUT WARRANTY # OF ANY KIND. PERMISSION IS GRANTED TO ALL PEOPLE EVERYWHERE TO # USE THIS SOFTWARE IN WHOLE OR IN PARTS FOR ANY PURPOSE INCLUDING # COMMERCIAL OR EDUCATIONAL APPLICATIONS, AND TO ALTER IT, LICENSE # IT, REDISTRIBUTE IT, OR SELL IT. THE AUTHOR AND CONTRIBUTORS OF # THIS SOFTWARE SHALL NOT BE HELD LIABLE FOR ANY LOSS RESULTING # FROM THE USE/MISUSE OF THIS SOFTWARE OR ANY DERIVATIVES THEREOF. # #################################################################### use 5.004; $| = 1; # Stop buffering stdout. my $INPUT_FILE = $0; my $OUTPUT_FILE = "Z:\\Test.pl"; my $OBFUSCATE_VARIABLES = 1; my $ALIGN_SUBS = 0; print "\n\nZsolt's Perl Compressor & Obfuscator v1 FREEWARE"; # STEP 1: Read the file plain text. my $FILESIZE = -s $INPUT_FILE; print "\nReading file: $INPUT_FILE ($FILESIZE bytes)"; my $DATA = ReadTheEntireFile($INPUT_FILE); # STEP 2: Get rid of all binary characters from the script: $DATA =~ tr|\r\n\t\x20-\x7E||cd; my $BINCOUNT = $FILESIZE - length($DATA); print "\nBinary characters removed: $BINCOUNT"; # STEP 3: Convert line breaks to Linux format. $DATA =~ s/\r\n/\n/g; # Convert DOS to Linux $DATA =~ tr|\r|\n|; # Convert Mac to Linux my $LINES = $DATA =~ tr|\n|\n|; # Count number of line breaks print "\nNumber of lines: ", ($LINES + 1); # STEP 4: Create a list of obfuscated variable names. # These are special variables which we should not rename: my $SPECIAL_VARIABLES = ' a b _ 0 1 2 3 4 5 6 7 8 9 ENV ARG ARGV ARGVO +UT PID GID EGID UID EUID SUBSEP F INC ISA OSNAME SIG BASETIME MATCH P +REMATCH POSTMATCH OFS NR RS ORS WARNING ERRNO PERLDB LIST_SEPARATOR P +ROCESS_ID PROGRAM_NAME REAL_GROUP_ID EFFECTIVE_GROUP_ID REAL_USER_ID +EFFECTIVE_USER_ID SUBSCRIPT_SEPARATOR OLD_PERL_VERSION SYSTEM_FD_MAX +INPLACE_EDIT PERL_VERSION EXECUTABLE_NAME LAST_PAREN_MATCH LAST_SUBMA +TCH_RESULT LAST_MATCH_END LAST_PAREN_MATCH LAST_MATCH_START LAST_REGE +XP_CODE_RESULT OUTPUT_FIELD_SEPARATOR INPUT_LINE_NUMBER INPUT_RECORD_ +SEPARATOR OUTPUT_RECORD_SEPARATOR OUTPUT_AUTOFLUSH ACCUMULATOR FORMAT +_FORMFEED FORMAT_PAGE_NUMBER FORMAT_LINES_LEFT FORMAT_LINE_BREAK_CHAR +ACTERS FORMAT_LINES_PER_PAGE FORMAT_TOP_NAME FORMAT_NAME EXTENDED_OS_ +ERROR EXCEPTIONS_BEING_CAUGHT OS_ERROR EVAL_ERROR COMPILING DEBUGGING + VERSION '; my @NEWVARS; my $MAXVARS = 2000; if ($OBFUSCATE_VARIABLES) { @NEWVARS = GenerateShortVariableNames($MAX +VARS); } # STEP 5: Analyze the perl script character by character. print "\nProcessing code..."; my @OUTPUT; # Global Output buffer my $C = ''; # Current character as string my $A = 0; # Current character as integer (ASCII code) my $PREV; # Previous character my $PREVWORD = ''; # Previous bareword captured my $PREVSYMB = ''; # Previous symbol captured my $PREVTYPE = ''; # Previous object type captured ( NUM | VAR | STR | + WORD | REGEX | SYM | BLOCK ) my $DEPTH = 0; # Indentation depth my $SPACE = 0; # Was there a whitespace between this and the previ +ous object? ( 0=NO | 1=YES ) my %VARS; # Use this dictionary to rename variables ( $VARS{ +OLDNAME} => "NEWNAME" ) my $PTR = 0; # Global File Pointer for (; $PTR < length($DATA); $PTR++) # MAIN LOOP { $PREV = $C; $C = substr($DATA, $PTR, 1); $A = vec($DATA, $PTR, 8); # Capture whitespace: if ($A == 32 || $A == 9 || $A == 10) { $SPACE = 1; next; } # Track code depth by capturing the brace characters: { } if ($A == 123) { $PREVTYPE = 'BLOCK'; push(@OUTPUT, '{'); $DEPTH++; +next; } if ($A == 125) { $PREVTYPE = 'BLOCK'; push(@OUTPUT, '}'); if ($DEPTH + > 0) { $DEPTH--; } else { print "\nWarning: Missing opening brace.\n +"; } if ($ALIGN_SUBS && $DEPTH == 0) { push(@OUTPUT, "\n"); } next; } # Capture the < sign and see if it's a heredoc: if ($A == 60) { if ($PREVSYMB eq '=' || ($PREVTYPE ne 'VAR' && $PREVTYPE ne 'NUM') +) { my $TEST = substr($DATA, $PTR, 32); if ($TEST =~ m/\<\<\s*['"]{,1}|\<\<[a-zA-Z\_]+/) { CaptureHeredoc() and next; } # False alarm. It was not a heredoc. # Maybe it was just a shift operator. } } # Capture POD documentation if ($C eq '=' && $PREV eq "\n") { CapturePOD() and next; } # Capture regex ( anything that begins with / or =~ or !~ ) if ($A == 47 && ($PREVTYPE eq 'WORD' && index('])}', $PREVSYMB) < 0) + || ($C eq '~' && index('=!', $PREV) >= 0)) { CaptureRegex() and next; } if ($A == 36 || $A == 64 || $A == 37) # Capture variables { # We may see a situation such as print FILEHANDLE $STRING; # where a bareword or variable is immediately followed by # another variable, and we must insert a space between the two # (unless there was no space there in the original script). # However when the word "my" appears before a variable, # these two do not need a space in between. if (index('*+-[{(;,=', $PREVSYMB) < 0) { if ($SPACE && ($PREVTYPE eq 'VAR' && $A == 36) || ($PREVTYPE eq +'WORD' && index(' my our defined undef return ', " $PREVWORD ") < 0)) + { push(@OUTPUT, ' '); } } CaptureVariable() and next; } if ($C eq '#' && $PREV ne '$') # Capture and eliminate comments { CaptureComment(); next; } # Process misc "leftover" symbols: my $MISC = index('[]()<>;,!?=$@%&:+*^|\\\/~-.', $C); if ($MISC >= 0) { if ($SPACE && $C eq '.' && $PREVTYPE eq 'NUM') { push(@OUTPUT, ' ' +); } push(@OUTPUT, $C); $PREVSYMB = $C; $SPACE = 0; next; } if ($A > 47 && $A < 58) # Digits found? { # If the number was preceded by period and then space, # we must not erase that space! Also: If the number # was preceded by a bareword or variable name, we # must not erase the space in front of the number. if (index('<>,:;|[(%/*=+-', $PREVSYMB) < 0) { if ($SPACE && ((index('.', $PREVSYMB) >= 0) || ($PREVTYPE eq 'WO +RD' || $PREVTYPE eq 'VAR'))) { push(@OUTPUT, ' '); } } CaptureNumber(); next; } if ($A == 34 || $A == 39 || $A == 96) # Capture strings { # If there's a variable or even a lonely $ sign by itself, # if it is immediately followed by a space and a string, we # should not eliminate that space in front of the string! if (index('={}[]();,.', $PREVSYMB) < 0) { if ($SPACE && $PREVSYMB eq '$' || $PREVTYPE eq 'STR' || $PREVTYP +E eq 'VAR') { push(@OUTPUT, ' '); } } CaptureString(); next; } # Capture bareword: if ($A == 95 || ($A > 96 && $A < 123) || ($A > 64 && $A < 91)) { if (index('*+-[{(;,=', $PREVSYMB) < 0) { if ($SPACE && ($PREVTYPE eq 'WORD' || $PREVTYPE eq 'VAR' || $PRE +VTYPE eq 'SYM')) { push(@OUTPUT, ' '); } } $SPACE = 1; $PREVSYMB = 'x'; my $WORD = CaptureWord(); if ($A == 113 && index(' qq qw qx qr q ', " $WORD ") >= 0) { $PREV +WORD = $WORD; CaptureQQ(); next; } if ($PREVWORD eq 'sub') { print '.'; } if ($WORD eq '__END__') { pop(@OUTPUT); last; } # We exit here. if ($WORD eq '__DATA__') { $PTR++; CaptureTail(); last; } $PREVWORD = $WORD; next; } } undef %VARS; # Free up some memory. undef $DATA; undef @NEWVARS; # STEP 6: Write output. print "\nSaving file: $OUTPUT_FILE "; CreateFile($OUTPUT_FILE, @OUTPUT); $FILESIZE = -s $OUTPUT_FILE; print "($FILESIZE bytes)\n\n"; exit; ################################################## # Perl | v2024.1.10 # This function captures a regex from start to finish. # # Usage: CaptureRegex() # sub CaptureRegex { my $START = $PTR; my $SEPARATOR = ''; my $OUT = ''; my $TEST = substr($DATA, $PTR, 256); my $LEN = 0; # Identify tr operator: if ($TEST =~ m/^(\~\s*tr\s*)([^\t\n ]{1})/) { $OUT = '~tr'; $LEN += length($1); $SEPARATOR = $2 x 2; } # Identify y operator: elsif ($TEST =~ m/^(\~\s*y\s*)([^\t\n ]{1})/) { $OUT = '~y'; $LEN = + length($1); $SEPARATOR = $2 x 2; } # Identify regex replace: elsif ($TEST =~ m/^(\~\s*s\s*)([^\t\n ]{1})/) { $OUT = '~s'; $LEN = + length($1); $SEPARATOR = $2 x 2; } # Identify regex match: elsif ($TEST =~ m/^(\~\s*m\s*)([^\t\n ]{1})/) { $OUT = '~m'; $LEN = + length($1); $SEPARATOR = $2; } # Identify simple regex match separated by / elsif ($TEST =~ m/^(\~?)(\s*)\//) { $OUT = $1; $LEN = l +ength($OUT . $2); $SEPARATOR = '/'; } else { $PTR = $START; return 0; } # It's not a regex. length($OUT) and push(@OUTPUT, $OUT); $PTR += $LEN; # Skip through the "introduction" $SEPARATOR = GetSeparatorCharacters($SEPARATOR); CapturePattern($SEPARATOR); $PREVTYPE = 'REGEX'; $PREVWORD = ''; $PREVSYMB = 'x'; $SPACE = 0; return 1; } ################################################## # Perl | v2024.1.10 # This function captures a quoted list. # # When calling this function, the $PTR global pointer # must point to the last letter of the word qq qw qx qr or q. # And when this function exits, $PTR will point to the # closing quote character. # # This function correctly captures things like # qr(( )( )); # q/rain\/snow\/water\/vapor/; # qw<\<<faith>\<<hope>\<<love>>; # qq#apple orange kiwi#; # qx\command\; # # Usage: CaptureQQ() # sub CaptureQQ { my $OPENING = substr($DATA, ++$PTR, 1); my $SEPARATOR = GetSeparatorCharacters($OPENING); CapturePattern($SEPARATOR); $PREVTYPE = 'REGEX'; $PREVWORD = ''; $PREVSYMB = 'x'; $SPACE = 0; return 1; } ################################################## # Perl | v2024.1.10 # This function captures a regex pattern or a quoted list. # # When calling this function, the $PTR pointer must be # pointing to the first separator character of the # regex or quoted list. The only argument this function # requires is the list of separator characters. # When processing a simple regex match such as /abc/ # the SEPARATOR should hold a single / character. # If we're processing regex replace such as =~ s(WAS)(IS)gi; # then the SEPARATOR will be '()()' << that's four letters. # When doing $STR =~ tr|||; the SEPARATOR will be '|||' # # Usage: CapturePattern(SEPARATORS) # sub CapturePattern { my $SEPARATOR = shift; my $OPENING = substr($SEPARATOR, 0, 1); my $CLOSING = substr($SEPARATOR, 1, 1); my $GROUPS = (length($SEPARATOR) == 2) ? 1 : 2; my $SAME = $OPENING eq $CLOSING; if ($SAME) { $GROUPS++; $SEPARATOR = $OPENING; } my $BACKSLASH = 0; my $QDEPTH = 0; my $START = $PTR; my $REGEX = ''; for (; $PTR < length($DATA); $PTR++) { my $C = substr($DATA, $PTR, 1); $REGEX .= $C; # Check for embedded variable names in regex if (($C eq '\\' && ($BACKSLASH & 1) == 0) || $C eq '$' || $C eq '@ +') { my $TEST = substr($DATA, $PTR, 500); # Replace embedded variable names in regex: if ($TEST =~ m/^([\$\@]{1}[a-zA-Z\_]{1}[a-zA-Z\_0-9]*)/) { my $VAR = $1; $PTR += length($VAR) - 1; $REGEX .= ReplaceVariable($VAR); } # Replace embedded variable names in regex between \Q and \E elsif ($TEST =~ m/^(Q\s*)([\$\@]{1}[a-zA-Z0-9\_]+)(\s*\\E)/) { my $PREFIX = $1; my $VAR = $2; my $SUFFIX = $3; $PTR += length($PREFIX) + length($VAR) + length($SUFFIX) - 1; $REGEX .= ReplaceVariable($VAR) . "\\E"; } } if (($BACKSLASH & 1) == 0) { if ($SAME) { if ($C eq $SEPARATOR) { $GROUPS--; } } else { if ($C eq $OPENING) { $QDEPTH++; } if ($C eq $CLOSING) { $QDEPTH--; if ($QDEPTH == 0) { $GROUPS-- +; } } } if ($GROUPS == 0) { last; } } if ($C eq '\\') { $BACKSLASH++; } else { $BACKSLASH = 0; } } if ($PTR + 1 == length($DATA)) { print "\nError: Unexpected end of file in the middle of regex or q +uoted list.\n"; return 0; } push(@OUTPUT, $REGEX); return 1; } ################################################## # Perl | v2024.1.10 # This function helps the regex match to correctly # identify the boundaries of a regex pattern by # returning separator characters to look for. # For example, some regex patterns are separated by # the // characters, and some are separated by () # # This function expects one argument which should be # a separator character or multiple separators and # it determines when the closing character needs to # be the same and when it needs to be different. # For example $STR =~ tr|||; << Here the closing # separator is the same as the opening separator. # But that's not true here: $STR =~ s((asd)(dsa))()gi; # # Usage: STRING = GetSeparatorCharacters(STRING) # sub GetSeparatorCharacters { my $SEPARATOR = defined $_[0] ? $_[0] : ''; length($SEPARATOR) or return ''; my $OPENING = substr($SEPARATOR, 0, 1); my $CLOSING = $OPENING; if ($OPENING eq '(') { $CLOSING = ')'; } if ($OPENING eq '[') { $CLOSING = ']'; } if ($OPENING eq '<') { $CLOSING = '>'; } if ($OPENING eq '{') { $CLOSING = '}'; } if ($OPENING eq $CLOSING) { return (length($SEPARATOR) == 1) ? $OPENING x 2 : $OPENING x 3; +} my $PAIR = $OPENING . $CLOSING; return (length($SEPARATOR) == 1) ? $PAIR : $PAIR x 2; } ################################################## # Perl | v2024.1.9 # This function skips through documentations and # moves the $PTR pointer to the letter "t" in the # "=cut" string. # # Usage: CapturePOD() # sub CapturePOD { my $TEST = substr($DATA, $PTR, 64); if ($TEST =~ m/^(\=[a-zA-Z]+)/) { $PTR += length($1); $PTR = index($DATA, "\n=cut", $PTR); if ($PTR > 0) { $PTR += 4; } else { $PTR = length($DATA); } $PREVSYMB = 'x'; $PREVWORD = ''; $SPACE = 1; return 1; } else { return 0; } } ################################################## # Perl | v2024.1.9 # This function captures a number. The $PTR pointer # must point to the first digit of the number. And # when this function exists, $PTR will point to the # last digit of the number. # # The following number formats are recognized # by this function: # 0.123 # 1234567 # 1234.000 # 1234.123456 # 1.234e+5 or 1.234e-5 # 1_000_000_000_000 # 0xA5C9FF07 # 0b01011101 # 0777 # # Note: This function will not capture the period in # front of a decimal when there is no preceding zero # and it will not capture the minus or plus sign in # front of a number. Why? Because this function is # called only when a digit is encountered in the code. # # Usage: CaptureNumber() # sub CaptureNumber { my $TEST = substr($DATA, $PTR, 512); my $NUM = ''; if ($TEST =~ m/([0-9]+)/) { $NUM = $1; } # Simple number: 900 or 077 +7 elsif ($TEST =~ m/(0x[0-9a-fA-F]+)/) { $NUM = $1; } # Hexadecimal nu +mber: 0xC9FF elsif ($TEST =~ m/(0b[01]+)/) { $NUM = $1; } # Binary number: 0b0100 +1011 elsif ($TEST =~ m/([0-9\_]*[0-9]{3})/) { $NUM = $1; } # Big number: +1_000_000_000_000 elsif ($TEST =~ m/([0-9]+\.[0-9]+)/) { $NUM = $1; } # Float: 123.456 +7 elsif ($TEST =~ m/([0-9]+[0-9.]*[eE]{1}[\-\+]{,1}[0-9]+)/) { $NUM = +$1; } # Scientific notation: 1.23456e+19 elsif ($TEST =~ m/([0-9.]+)/) { $NUM = $1; } # Version number: 1.2.3 +.4 or List: 0..123 if (length($NUM)) { $PTR += length($NUM) - 1; push(@OUTPUT, $NUM); } else { print "\nWarning: Unrecognized number.\n"; return 0; } $PREVTYPE = 'NUM'; $PREVSYMB = 'x'; $SPACE = 0; } ################################################## # Perl | v2024.1.9 # This function captures a bareword starting at the # current position $PTR. ($PTR is a global integer, # pointing to characters within $DATA. And $DATA is # a global string variable which contains the # entire file's contents we're processing.) # # A word is a series of characters made up of # letters, digits, and the underscore character. # A word cannot start with digits. A word cannot # contain space, tab, line break, $ # @ : or any # other special characters. # # This function returns the captured word string # and moves the $PTR pointer forward pointing to # the last letter of the word. When calling # this function, the $PTR pointer should point # to the first letter of the word. This function # also updates the value of $PREVTYPE which is a # global string variable that holds the previous # object's type. Its value can be NUMBER, WORD, # STRING, REGEX, etc... The $PREVTYPE value helps # us determine whether we must insert a space between # two objects or not. For example, two barewords # should be separated by a space. # # This function also resets the global $SPACE variable # to zero, which indicates whether two objects were # originally separated by a space or not. If we encounter # a whitespace after this bareword we just capture, then # the value of $SPACE will be set to 1. # # Usage: STRING = CaptureWord() # sub CaptureWord { # First, let's grab a test string that is long enough # to hold all the characters of the word we may find. # Note: The longest perl function name is 252 bytes. my $TEST = substr($DATA, $PTR, 512); my $WORD = ''; if ($TEST =~ m/^([a-zA-Z0-9\_]+)/) { $WORD = $1; if ($ALIGN_SUBS && $WORD eq 'sub') { # Insert a new line character in front of each sub declaration if (@OUTPUT && $OUTPUT[$#OUTPUT] ne "\n") { push(@OUTPUT, "\n"); + } } push(@OUTPUT, $WORD); $PTR += length($WORD) - 1; } $PREVTYPE = 'WORD'; $PREVSYMB = 'x'; $SPACE = 0; return $WORD; } ################################################## # Perl | v2024.1.8 # This function captures a heredoc from start to # finish and sets the $PTR pointer to point to the # new line character that follows the ending pattern # of the heredoc. # # If this function successfully captured a heredoc, # it will return 1. If the text was not a heredoc # but a simple shift operator or less than sign, # then the function returns 0. # # Usage: INTEGER = CaptureHeredoc() # sub CaptureHeredoc { my $TERMINATOR = ''; my $PREFIX = ''; my $START = $PTR; # First we try to identify the terminator pattern. my $TEST = substr($DATA, $PTR, 512); # A heredoc must begin with: # 1) << '_+/Some \'code\' 123'; # 2) << "_+/Some \"code\" 123"; # 3) <<SomeTEXT_123; if ($TEST =~ m/^\<\<([a-zA-Z\_]{1}[a-zA-Z\_0-9]*)/) { $TERMINATOR = $1; $PTR += length($TERMINATOR); push(@OUTPUT, '<<' . $TERMINATOR . ';'); } elsif ($TEST =~ m/^\<\<\s*(['"]{1})/) { my $QT = $1; # Get quotation mark (either ' or ") my $First = index($TEST, $QT); # When the heredoc terminator string is given, it does not # interpolate variable names even if double quotes are used. # The \ character can be used inside the heredoc terminator # string to escape the opening quote character used, # BUT every other instance of backslash will be treated as # literal, even "\n" and "\$" and "\\" will be treated as # literal, meaning that "\\" stands for two # backslash characters, not one! for ($PTR = $First; $PTR < length($DATA); $PTR++) { my $C = substr($DATA, $PTR, 1); # If the character before the quote is not a backslash, # then it's the end of the terminator string: if ($C eq $QT && substr($DATA, $PTR-1, 1) ne "\\") { $TERMINATOR = substr($DATA, $First, $PTR - $First - 1); last; } } push(@OUTPUT, '<<' . $QT . $TERMINATOR . $QT . ';'); } else { return 0; } # This is not a heredoc! # The heredoc string starts after the end of this line: my $EOL = index($DATA, "\n", $PTR); if ($EOL < 0) { $PTR = $START; # Undo everything print "\nError: Unexpected end of file in the middle of heredoc.\n +"; return 0; } $PTR = $EOL + 1; my $End = index($DATA, "\n$TERMINATOR\n", $PTR); if ($End < 0) { print "\nError: Heredoc never ends.\n"; return 1; } my $HEREDOC = substr($DATA, $PTR, $End - $PTR); push(@OUTPUT, $HEREDOC . "\n" . $TERMINATOR . "\n"); $PREVTYPE = 'HEREDOC'; $PREVSYMB = 'x'; $SPACE = 0; return 1; } ################################################## # Perl | v2024.1.4 # This function captures a variable name that starts # with one of these characters: $ @ % # # Variables can appear inside strings or anywhere else. # => To capture variables inside strings, we use the # ReplaceVarNameInsideString() function. # => To capture variables outside of strings, # we use the CaptureVariable() function. # # This function will also replace the variable # with a shorter name. # # Usage: CaptureVariable() # sub CaptureVariable { # Longest perl variable name is 252 bytes, # so we grab a chunk of code that is more than twice as long. # Why? Because we may encounter something like this in the wild: # $A_252_byte_long_variable_name[$Another_252_byte_long_variable_nam +e] my $TEST = substr($DATA, $PTR, 512); my $STR = ''; if ($TEST =~ m/^([\$\@\%\#]{1,2}[a-zA-Z\_]{1}[a-zA-Z0-9\_]*)/) { +$STR = $1; } # $AAA or $$AAA or $#AAA or @AAA elsif ($TEST =~ m/^([\$\@\%]{1}[0-9<>()!?~=:;,.`'%@&#\-\+"\/\]\[\|\\ +]{1})/) { $STR = $1; } # Special variables: $% elsif ($TEST =~ m/^([\$\@\%]{1,2}[a-zA-Z]*[\{\[]{1}[a-zA-Z0-9\_]+[\} +\]]{1})/) { $STR = $1; } # $AAA{BBB} or $AAA[123] elsif ($TEST =~ m/^([\$\@\%]{1,2}\x5E[a-zA-Z0-9\_]+\{[a-zA-Z0-9\_]+\ +})/) { $STR = $1; } # $^AAA{AAA} elsif ($TEST =~ m/^([\$\x5E]{2}[a-zA-Z\_]{1})/) { $STR = $1; } # $^A else { return 0; } # Not a variable? $PTR += length($STR) - 1; push(@OUTPUT, ReplaceVariable($STR)); $PREVTYPE = 'VAR'; $PREVSYMB = 'x'; $SPACE = 0; return 1; } ################################################## # Perl | v2024.1.9 # This function comes up with shorter variable name # for each variable name in the source script # unless that variable name happens to be a special # variable that should not be modified. # # The first argument must contain the name of the # variable preceded by its symbol. The following # variable formats are recognized: $ABC @ABC %ABC # $#ABC $$ABC $@ABC, etc... # # The function returns a new variable name with # the same prefix as the incoming variable. # Example: # $$myText => $$o # @list => @p # %state => %q # # Note: This function does not write to output; # it simply returns a new variable substitute # for an old one. # # Usage: NewName = ReplaceVariable(OldName) # sub ReplaceVariable { my $FULLNAME = shift; # Exit here if we don't want to shorten any variables: $OBFUSCATE_VARIABLES or return $FULLNAME; my $NAME = ''; my $PREFIX = ''; if ($FULLNAME =~ m/^([\$\%\@\#]{1,2})([a-zA-Z0-9\_]+)/) { $PREFIX = $1; $NAME = $2; } if (length($NAME) == 0 || length($PREFIX) == 0) { return $FULLNAME; } # It's not a variable. # Is this old variable name already in our dictionary? if (exists($VARS{$NAME})) { return $PREFIX . $VARS{$NAME}; } # Look it up and return it # Is this variable a special variable that should not be renamed? if (index($SPECIAL_VARIABLES, " $NAME ") >= 0) { return $FULLNAME; } # YES - Return unchanged. # Let's pick a new variable name: my $COUNT = scalar keys %VARS; # Let's see how many variables we us +e rigth now. if (@NEWVARS < $COUNT) # Oops. We ran out of short variable nam +es. { print "\nWarning: Ran out of variable names! Please increase the + value of \$MAXVARS\n"; return $FULLNAME; } my $NEW = $NEWVARS[$COUNT]; # Get new variable name $VARS{$NAME} = $NEW; # Write into our dictionary: old name = +> new name return $PREFIX . $NEW; # Return new variable } ################################################## # Perl | v2024.1.8 # This function captures a variable name inside # a double-quoted string and replaces it with # a shorter variable name. # # The only argument required is the string that # has been captured so far. This function will append # this string with a short variable name and also # increment the global $PTR pointer, so it will # point to the last letter of the variable name. # # Usage: ReplaceVarNameInsideString(STRING) # sub ReplaceVarNameInsideString { my $TEST = substr($DATA, $PTR, 512); # Detect variable names enclosed with braces such as ${ABC} if ($TEST =~ m/^([\$\@\%\#]{1,2})\{([a-zA-Z0-9\_]+)\}/) { my $PREFIX = $1; my $NAME = $2; my $VAR = $PREFIX . $NAME; $PTR += length($VAR) + 1; $NAME = substr(ReplaceVariable($VAR), 1); $_[0] .= $PREFIX . '{' . $NAME . '}'; return 1; } # Detect simple variable names such as $ABC or $$ABC or $#ABC if ($TEST =~ m/^([\$\@\%]{1}\#?[a-zA-Z\_]{1}[a-zA-Z0-9\_]*)/) { my $VAR = $1; $PTR += length($VAR) - 1; $VAR = ReplaceVariable($VAR); $_[0] .= $VAR; return 1; } # Detect special 3-character variables such as $^A and skip through +them if ($TEST =~ m/^(\$\x5E[a-zA-Z\_]{1})/) { my $VAR = $1; $PTR += length($VAR) - 1; $_[0] .= $VAR; return 1; } # Detect special 2-character variable names such as $' or $[ or $3 a +nd skip through them if ($TEST =~ m/^(\x24[0-9\<\>\(\)!?~=:;,.^`'%\@&#\+\_\[\]\|\/\\]{1}) +/) { my $VAR = $1; $PTR++; $_[0] .= $VAR; return 1; } return 0; } ################################################## # Perl | v2024.1.10 # This function captures the end of the script # which begins with the word __DATA__. # # Usage: CaptureTail() # sub CaptureTail { pop(@OUTPUT); push(@OUTPUT, "\n__DATA__"); push(@OUTPUT, substr($DATA, $PTR)); return 1; } ################################################## # Perl | v2024.1.5 # This function captures a comment. The $PTR pointer # must point to the # character when calling this # function. The $PTR pointer will point to the \n # character when this function exits. # # Usage: CaptureComment() # sub CaptureComment { my $End = index($DATA, "\n", $PTR); # Find end of line if ($End < 0) { $PTR = length($DATA); return 1; # End of File } my $COMMENT = substr($DATA, $PTR, $End - $PTR); $PTR = $End; # We delete all comments except the first line. if (@OUTPUT == 0 && $COMMENT =~ m/^\#\!\//) { push(@OUTPUT, $COMMENT . "\n"); } $PREVWORD = ''; $PREVSYMB = 'x'; $SPACE = 1; return 1; } ################################################## # Perl | v2024.1.8 # This function captures a literal string within the # script and outputs one block of string enclosed with # quotation marks or backticks. This function also # increments the global $PTR pointer, so when this # function returns, $PTR will point to the # string's closing quote character. # # Usage: CaptureString() # sub CaptureString { # Grab first character of string which is the quotation mark: my $QT = substr($DATA, $PTR, 1); my $STRING = $QT; my $BACKSLASH = 0; # Count number of consecutive \\ characters for ($PTR++; $PTR < length($DATA); $PTR++) { my $C = substr($DATA, $PTR, 1); # Get next character # Fix line break within a string. If a string stretches across # multiple lines, we'll merge it into a single line and add # "\n" characters where needed. if ($C eq "\n") { # If the line ends with a lonely backslash character, # then we just put "n" after it, but otherwise we add "\n" $STRING .= ($BACKSLASH & 1) ? 'n' : '\\n'; $BACKSLASH = 0; next; } # We also replace variable names inside strings. # First we must verify three things: # 1) The mention of a variable must occur within double-quoted s +tring or backticks # 2) The number of preceding consecutive backslash characters mu +st be an even number # 3) The mention of a variable must begin with one of these char +acters: $ @ if (($QT eq '"' || $QT eq '`') && ($BACKSLASH & 1) == 0 && index(' +$@', $C) >= 0) { ReplaceVarNameInsideString($STRING) and next; } $STRING .= $C; # Add this character # We reach the end of string when the current character # matches the opening quote character: if ($C eq $QT) { if (($BACKSLASH & 1) == 0) { # Under normal circumstances, we exit here. push(@OUTPUT, $STRING); $PREVTYPE = 'STR'; $PREVSYMB = 'x'; $SPACE = 0; return 1; } } # Keep count of consecutive \\ characters: if ($C eq '\\') { $BACKSLASH++; } else { $BACKSLASH = 0; } } # If the string was never terminated, then we exit here. push(@OUTPUT, $STRING); print "\nWarning: Unterminated string constant.\n"; return 1; } ################################################## # Perl | v2024.1.8 # This function generates N number of short variable # names and returns the list. These names will be # used to replace longer variable names in the script. # # Usage: LIST = GenerateShortVariableNames(N) # sub GenerateShortVariableNames { my $COUNT = shift; my @VARLIST = ('a'..'z', 'A'..'Z', '_', 0..9); my $S = join('', @VARLIST); my $END2 = length($S); my $END1 = $END2 - 10; my $NAME; @VARLIST = (); for (my $i = 0; $i < $END1; $i++) { $NAME = substr($S, $i, 1); if (index($SPECIAL_VARIABLES, " $NAME ") >= 0) { next; } # Skip push(@VARLIST, $NAME); if (@VARLIST >= $COUNT) { return @VARLIST; } } for (my $i = 0; $i < $END1; $i++) { for (my $j = 0; $j < $END2; $j++) { $NAME = substr($S, $i, 1) . substr($S, $j, 1); if (index($SPECIAL_VARIABLES, " $NAME ") >= 0) { next; } # Skip push(@VARLIST, $NAME); if (@VARLIST >= $COUNT) { return @VARLIST; } } } for (my $i = 0; $i < $END1; $i++) { for (my $j = 0; $j < $END2; $i++) { for (my $k = 0; $k < $END2; $j++) { $NAME = substr($S, $i, 1) . substr($S, $j, 1) . substr($S, $k, + 1); if (index($SPECIAL_VARIABLES, " $NAME ") >= 0) { next; } # Ski +p push(@VARLIST, $NAME); if (@VARLIST >= $COUNT) { return @VARLIST; } } } } return @VARLIST; } ################################################## # File | v2024.1.9 # This function reads an entire file in binary mode # using the sysopen() and sysread() functions. # # Usage: STRING = ReadTheEntireFile(FILENAME) # sub ReadTheEntireFile { my $F = defined $_[0] ? $_[0] : ''; $F =~ tr`<>*?\"\|\x00-\x1F``d; # Remove illegal characters. length($F) or return ''; # Missing file name? -f $F or return ''; # Make sure file exists and is a plain file. my $SIZE = -s $F; # Get file size. $SIZE or return ''; # Return zero bytes. my $BUF = ''; # Read buffer local *FILE; sysopen(FILE, $F, 0) or return ''; # Open file for read only. my $L = sysread(FILE, $BUF, $SIZE); # Read the entire file close FILE; return $BUF; } ################################################## # File | v2023.12.27 # This function creates a file in binary mode and # writes some content into it. If the file has # already existed, the old content will be deleted # and replaced with the new content. # Returns 1 on success or 0 if something went wrong. # # This function can have two or more arguments. # The first argument must be the file name, followed # by string(s) to be written to the file in binary # mode starting at the beginning of the file. # # Usage: STATUS = CreateFile(FILENAME, [STRINGS...]) # sub CreateFile { defined $_[0] or return 0; my $F = shift; # Remove illegal characters from file name: $F =~ tr`<>*?\"\|\x00-\x1F``d; length($F) or return 0; # No file name? local *FILE; open(FILE, ">$F") or return 0; # Create the file. binmode FILE; foreach (@_) { defined $_ and length($_) and print FILE $_; } close FILE; -f $F or return 0; # It's a plain file? return 1; } ##################################################

This is what this program does when it is told to obfuscate itself:

#!/usr/bin/perl -w use 5.004;$|=1;my$c=$0;my$d="Z:\\Test.pl";my$e=1;my$f=0;print"\n\nZsol +t's Perl Compressor & Obfuscator v1 FREEWARE";my$g=-s $c;print"\nRead +ing file: $c ($g bytes)";my$h=ReadTheEntireFile($c); $h=~tr|\r\n\t\x +20-\x7E||cd;my$i=$g-length($h);print"\nBinary characters removed: $i" +;$h=~s/\r\n/\n/g; $h=~tr|\r|\n|;my$j=$h=~tr|\n|\n|;print"\nNumber of +lines: ",($j+1);my$k=' a b _ 0 1 2 3 4 5 6 7 8 9 ENV ARG ARGV ARGVOUT + PID GID EGID UID EUID SUBSEP F INC ISA OSNAME SIG BASETIME MATCH PRE +MATCH POSTMATCH OFS NR RS ORS WARNING ERRNO PERLDB LIST_SEPARATOR PRO +CESS_ID PROGRAM_NAME REAL_GROUP_ID EFFECTIVE_GROUP_ID REAL_USER_ID EF +FECTIVE_USER_ID SUBSCRIPT_SEPARATOR OLD_PERL_VERSION SYSTEM_FD_MAX IN +PLACE_EDIT PERL_VERSION EXECUTABLE_NAME LAST_PAREN_MATCH LAST_SUBMATC +H_RESULT LAST_MATCH_END LAST_PAREN_MATCH LAST_MATCH_START LAST_REGEXP +_CODE_RESULT OUTPUT_FIELD_SEPARATOR INPUT_LINE_NUMBER INPUT_RECORD_SE +PARATOR OUTPUT_RECORD_SEPARATOR OUTPUT_AUTOFLUSH ACCUMULATOR FORMAT_F +ORMFEED FORMAT_PAGE_NUMBER FORMAT_LINES_LEFT FORMAT_LINE_BREAK_CHARAC +TERS FORMAT_LINES_PER_PAGE FORMAT_TOP_NAME FORMAT_NAME EXTENDED_OS_ER +ROR EXCEPTIONS_BEING_CAUGHT OS_ERROR EVAL_ERROR COMPILING DEBUGGING V +ERSION ';my@l;my$m=2000;if($e){@l=GenerateShortVariableNames($m);}pri +nt"\nProcessing code...";my@n; my$o='';my$p=0;my$q; my$r='';my$s='';m +y$t='';my$u=0;my$v=0;my%w; my$x=0;for(;$x< length($h);$x++){$q=$o;$o= +substr($h,$x,1);$p=vec($h,$x,8);if($p==32||$p==9||$p==10){$v=1;next;} +if($p==123){$t='BLOCK';push(@n,'{');$u++;next;}if($p==125){$t='BLOCK' +;push(@n,'}');if($u>0){$u--;}else{print"\nWarning: Missing opening br +ace.\n";}if($f&& $u==0){push(@n,"\n");}next;}if($p==60){if($s eq'='|| +($t ne'VAR'&&$t ne'NUM')){my$y=substr($h,$x,32);if($y=~m/\<\<\s*['"]{ +,1}|\<\<[a-zA-Z\_]+/){CaptureHeredoc() and next;}}}if($o eq'='&&$q eq +"\n"){CapturePOD() and next;}if($p==47&&($t eq'WORD'&&index('])}',$s) +<0)||($o eq'~'&&index('=!',$q)>=0)){CaptureRegex() and next;}if($p==3 +6||$p==64||$p==37){if(index('*+-[{(;,=',$s)<0){if($v&&($t eq'VAR'&&$p +==36)||($t eq'WORD'&&index(' my our defined undef return '," $r ")<0) +){push(@n,' ');}}CaptureVariable() and next;}if($o eq'#'&&$q ne'$'){C +aptureComment();next;}my$z=index('[]()<>;,!?=$@%&:+*^|\\\/~-.',$o);if +($z>=0){if($v&& $o eq'.'&&$t eq'NUM'){push(@n,' ');}push(@n,$o);$s=$o +;$v=0;next;}if($p>47&&$p<58){if(index('<>,:;|[(%/*=+-',$s)<0){if($v&& +((index('.',$s)>=0)||($t eq'WORD'||$t eq'VAR'))){push(@n,' ');}}Captu +reNumber();next;}if($p==34||$p==39||$p==96){if(index('={}[]();,.',$s) +<0){if($v&& $s eq'$'||$t eq'STR'||$t eq'VAR'){push(@n,' ');}}CaptureS +tring();next;}if($p==95||($p>96&&$p<123)||($p>64&&$p<91)){if(index('* ++-[{(;,=',$s)<0){if($v&&($t eq'WORD'||$t eq'VAR'||$t eq'SYM')){push(@ +n,' ');}}$v=1;$s='x';my$A=CaptureWord();if($p==113&&index(' qq qw qx +qr q '," $A ")>=0){$r=$A;CaptureQQ();next;}if($r eq'sub'){print'.';}i +f($A eq'__END__'){pop(@n);last;}if($A eq'__DATA__'){$x++;CaptureTail( +);last;}$r=$A;next;}}undef%w; undef$h;undef@l; print"\nSaving file: $ +d ";CreateFile($d,@n);$g=-s $d;print"($g bytes)\n\n";exit; sub Captu +reRegex{my$B=$x;my$C='';my$D='';my$y=substr($h,$x,256);my$E=0;if($y=~ +m/^(\~\s*tr\s*)([^\t\n ]{1})/){$D='~tr';$E=length($1);$C=$2 x 2;}elsi +f($y=~m/^(\~\s*y\s*)([^\t\n ]{1})/){$D='~y';$E=length($1);$C=$2 x 2;} +elsif($y=~m/^(\~\s*s\s*)([^\t\n ]{1})/){$D='~s';$E=length($1);$C=$2 x + 2;}elsif($y=~m/^(\~\s*m\s*)([^\t\n ]{1})/){$D='~m';$E=length($1);$C= +$2;}elsif($y=~m/^(\~?)(\s*)\//){$D=$1;$E=length($D. $2);$C='/';}else{ +$x=$B;return 0;}length($D) and push(@n,$D);$x+=$E; $C=GetSeparatorCha +racters($C);CapturePattern($C);$t='REGEX';$r='';$s='x';$v=0;return 1; +}sub CaptureQQ{my$G=substr($h,++$x,1);my$C=GetSeparatorCharacters($G) +;CapturePattern($C);$t='REGEX';$r='';$s='x';$v=0;return 1;}sub Captur +ePattern{my$C=shift;my$G=substr($C,0,1);my$H=substr($C,1,1);my$I=(len +gth($C)==2)?1:2;my$J=$G eq $H;if($J){$I++;$C=$G;}my$K=0;my$L=0;my$B=$ +x;my$M='';for(;$x< length($h);$x++){my$o=substr($h,$x,1);$M.=$o; if(( +$o eq'\\'&&($K& 1)==0)||$o eq'$'||$o eq'@'){my$y=substr($h,$x,500);if +($y=~m/^([\$\@]{1}[a-zA-Z\_]{1}[a-zA-Z\_0-9]*)/){my$N=$1;$x+=length($ +N)-1;$M.=ReplaceVariable($N);}elsif($y=~m/^(Q\s*)([\$\@]{1}[a-zA-Z0-9 +\_]+)(\s*\\E)/){my$O=$1;my$N=$2;my$P=$3;$x+=length($O)+length($N)+len +gth($P)-1;$M.=ReplaceVariable($N)."\\E";}}if(($K& 1)==0){if($J){if($o + eq $C){$I--;}}else{if($o eq $G){$L++;}if($o eq $H){$L--;if($L==0){$I +--;}}}if($I==0){last;}}if($o eq'\\'){$K++;}else{$K=0;}}if($x+1==lengt +h($h)){print"\nError: Unexpected end of file in the middle of regex o +r quoted list.\n";return 0;}push(@n,$M);return 1;}sub GetSeparatorCha +racters{my$C=defined$_[0]?$_[0]:'';length($C) or return'';my$G=substr +($C,0,1);my$H=$G;if($G eq'('){$H=')';}if($G eq'['){$H=']';}if($G eq'< +'){$H='>';}if($G eq'{'){$H='}';}if($G eq $H){return(length($C)==1)?$G + x 2:$G x 3;}my$Q=$G. $H;return(length($C)==1)?$Q: $Q x 2;}sub Captur +ePOD{my$y=substr($h,$x,64);if($y=~m/^(\=[a-zA-Z]+)/){$x+=length($1);$ +x=index($h,"\n=cut",$x);if($x>0){$x+=4;}else{$x=length($h);}$s='x';$r +='';$v=1;return 1;}else{return 0;}}sub CaptureNumber{my$y=substr($h,$ +x,512);my$R='';if($y=~m/([0-9]+)/){$R=$1;}elsif($y=~m/(0x[0-9a-fA-F]+ +)/){$R=$1;}elsif($y=~m/(0b[01]+)/){$R=$1;}elsif($y=~m/([0-9\_]*[0-9]{ +3})/){$R=$1;}elsif($y=~m/([0-9]+\.[0-9]+)/){$R=$1;}elsif($y=~m/([0-9] ++[0-9.]*[eE]{1}[\-\+]{,1}[0-9]+)/){$R=$1;}elsif($y=~m/([0-9.]+)/){$R= +$1;}if(length($R)){$x+=length($R)-1;push(@n,$R);}else{print"\nWarning +: Unrecognized number.\n";return 0;}$t='NUM';$s='x';$v=0;}sub Capture +Word{my$y=substr($h,$x,512);my$A='';if($y=~m/^([a-zA-Z0-9\_]+)/){$A=$ +1;if($f&& $A eq'sub'){if(@n&& $n[$#n] ne"\n"){push(@n,"\n");}}push(@n +,$A);$x+=length($A)-1;}$t='WORD';$s='x';$v=0;return$A;}sub CaptureHer +edoc{my$S='';my$O='';my$B=$x; my$y=substr($h,$x,512);if($y=~m/^\<\<([ +a-zA-Z\_]{1}[a-zA-Z\_0-9]*)/){$S=$1;$x+=length($S);push(@n,'<<'.$S.'; +');}elsif($y=~m/^\<\<\s*(['"]{1})/){my$T=$1; my$U=index($y,$T); for($ +x=$U;$x< length($h);$x++){my$o=substr($h,$x,1);if($o eq $T&& substr($ +h,$x-1,1)ne"\\"){$S=substr($h,$U,$x-$U-1);last;}}push(@n,'<<'.$T. $S. + $T.';');}else{return 0;}my$V=index($h,"\n",$x);if($V<0){$x=$B; print +"\nError: Unexpected end of file in the middle of heredoc.\n";return +0;}$x=$V+1;my$W=index($h,"\n$S\n",$x);if($W<0){print"\nError: Heredoc + never ends.\n";return 1;}my$X=substr($h,$x,$W-$x);push(@n,$X."\n".$S +."\n");$t='HEREDOC';$s='x';$v=0;return 1;}sub CaptureVariable{my$y=su +bstr($h,$x,512);my$Y='';if($y=~m/^([\$\@\%\#]{1,2}[a-zA-Z\_]{1}[a-zA- +Z0-9\_]*)/){$Y=$1;}elsif($y=~m/^([\$\@\%]{1}[0-9<>()!?~=:;,.`'%@&#\-\ ++"\/\]\[\|\\]{1})/){$Y=$1;}elsif($y=~m/^([\$\@\%]{1,2}[a-zA-Z]*[\{\[] +{1}[a-zA-Z0-9\_]+[\}\]]{1})/){$Y=$1;}elsif($y=~m/^([\$\@\%]{1,2}\x5E[ +a-zA-Z0-9\_]+\{[a-zA-Z0-9\_]+\})/){$Y=$1;}elsif($y=~m/^([\$\x5E]{2}[a +-zA-Z\_]{1})/){$Y=$1;}else{return 0;}$x+=length($Y)-1;push(@n,Replace +Variable($Y));$t='VAR';$s='x';$v=0;return 1;}sub ReplaceVariable{my$Z +=shift; $e or return$Z;my$aa='';my$O='';if($Z=~m/^([\$\%\@\#]{1,2})([ +a-zA-Z0-9\_]+)/){$O=$1;$aa=$2;}if(length($aa)==0||length($O)==0){retu +rn$Z;}if(exists($w{$aa})){return$O. $w{$aa};}if(index($k," $aa ")>=0) +{return$Z;}my$ab=scalar keys %w; if(@l< $ab){print"\nWarning: Ran out + of variable names! Please increase the value of \$MAXVARS\n";return$ +Z;}my$ac=$l[$ab]; $w{$aa}=$ac; return$O. $ac;}sub ReplaceVarNameInsid +eString{my$y=substr($h,$x,512);if($y=~m/^([\$\@\%\#]{1,2})\{([a-zA-Z0 +-9\_]+)\}/){my$O=$1;my$aa=$2;my$N=$O. $aa;$x+=length($N)+1;$aa=substr +(ReplaceVariable($N),1);$_[0] .=$O.'{'.$aa.'}';return 1;}if($y=~m/^([ +\$\@\%]{1}\#?[a-zA-Z\_]{1}[a-zA-Z0-9\_]*)/){my$N=$1;$x+=length($N)-1; +$N=ReplaceVariable($N);$_[0] .=$N;return 1;}if($y=~m/^(\$\x5E[a-zA-Z\ +_]{1})/){my$N=$1;$x+=length($N)-1;$_[0] .=$N;return 1;}if($y=~m/^(\x2 +4[0-9\<\>\(\)!?~=:;,.^`'%\@&#\+\_\[\]\|\/\\]{1})/){my$N=$1;$x++;$_[0] + .=$N;return 1;}return 0;}sub CaptureTail{pop(@n);push(@n,"\n__DATA__ +");push(@n,substr($h,$x));return 1;}sub CaptureComment{my$W=index($h, +"\n",$x); if($W<0){$x=length($h);return 1;}my$ad=substr($h,$x,$W-$x); +$x=$W; if(@n==0&&$ad=~m/^\#\!\//){push(@n,$ad."\n");}$r='';$s='x';$v= +1;return 1;}sub CaptureString{my$T=substr($h,$x,1);my$ae=$T;my$K=0;fo +r($x++;$x< length($h);$x++){my$o=substr($h,$x,1);if($o eq"\n"){$ae.=( +$K& 1)?'n': '\\n';$K=0;next;}if(($T eq'"'||$T eq'`')&&($K& 1)==0&&ind +ex('$@',$o)>=0){ReplaceVarNameInsideString($ae) and next;}$ae.=$o; if +($o eq $T){if(($K& 1)==0){push(@n,$ae);$t='STR';$s='x';$v=0;return 1; +}}if($o eq'\\'){$K++;}else{$K=0;}}push(@n,$ae);print"\nWarning: Unter +minated string constant.\n";return 1;}sub GenerateShortVariableNames{ +my$ab=shift;my@af=('a'..'z','A'..'Z','_',0..9);my$ag=join('',@af);my$ +ah=length($ag);my$ai=$ah-10;my$aa;@af=();for(my$aj=0;$aj< $ai;$aj++){ +$aa=substr($ag,$aj,1);if(index($k," $aa ")>=0){next;}push(@af,$aa);if +(@af>=$ab){return@af;}}for(my$aj=0;$aj< $ai;$aj++){for(my$ak=0;$ak< $ +ah;$ak++){$aa=substr($ag,$aj,1) .substr($ag,$ak,1);if(index($k," $aa +")>=0){next;}push(@af,$aa);if(@af>=$ab){return@af;}}}for(my$aj=0;$aj< + $ai;$aj++){for(my$ak=0;$ak< $ah;$aj++){for(my$al=0;$al< $ah;$ak++){$ +aa=substr($ag,$aj,1) .substr($ag,$ak,1) .substr($ag,$al,1);if(index($ +k," $aa ")>=0){next;}push(@af,$aa);if(@af>=$ab){return@af;}}}}return@ +af;}sub ReadTheEntireFile{my$F=defined$_[0]?$_[0]:'';$F=~tr`<>*?\"\|\ +x00-\x1F``d; length($F) or return'';-f $F or return'';my$am=-s $F; $a +m or return'';my$an='';local*FILE;sysopen(FILE,$F,0)or return'';my$ao +=sysread(FILE,$an,$am); close FILE;return$an;}sub CreateFile{defined$ +_[0]or return 0;my$F=shift; $F=~tr`<>*?\"\|\x00-\x1F``d;length($F) or + return 0;local*FILE;open(FILE,">$F")or return 0;binmode FILE;foreach +(@_){defined$_ and length($_) and print FILE $_;}close FILE;-f $F or +return 0;return 1;}

Replies are listed 'Best First'.
Re: My Perl Obfuscator
by jwkrahn (Abbot) on Jan 12, 2024 at 00:47 UTC
    -e $F or return 0; # File exists? -f $F or return 0; # It's a plain file?

    You don't need both tests because if -f $F is true then -e $F has to be true.

    $ mkdir test $ mkdir test/file1.txt $ touch test/file2.txt $ perl -le'print "abcdefg"' > test/file3.txt $ perl -le'print "\x90\x91\x92\x93\x94\x95\x96"' > test/file4.txt $ perl -e'for my $file ( @ARGV ) { print "$file: "; if ( -e $file ) { +print "EXISTS " } if ( -f $file ) { print "PLAIN " } print "\n" }' te +st/file* test/file1.txt: EXISTS test/file2.txt: EXISTS PLAIN test/file3.txt: EXISTS PLAIN test/file4.txt: EXISTS PLAIN
    Naked blocks are fun! -- Randal L. Schwartz, Perl hacker
      Oh, I didn't realize that. Thank you!!
Re: My Perl Obfuscator
by jwkrahn (Abbot) on Jan 12, 2024 at 01:16 UTC
    sub ReadTheEntireFile { my $F = defined $_[0] ? $_[0] : ''; $F =~ tr`<>*?\"\|\x00-\x1F``d; # Remove illegal characters. length($F) or return ''; # Missing file name? -e $F and -f $F or return ''; # Make sure file exists. my $SIZE = -s $F; # Get file size. $SIZE or return ''; # Return zero bytes. my $BUF = ''; # Read buffer local *FILE; sysopen(FILE, $F, 0) or return ''; # Open file for read only. my $L = sysread(FILE, $BUF, $SIZE); # Read the entire file close FILE; return $BUF; }

    Again, you don't need both file tests to know if a file exists.

    $L contains the amount of data returned from the file. You should compare that value to $SIZE to verify that the entire file has been returned.

    Naked blocks are fun! -- Randal L. Schwartz, Perl hacker
Re: My Perl Obfuscator
by jwkrahn (Abbot) on Jan 12, 2024 at 03:27 UTC
    sub ReplaceVarNameInsideString ... # Detect special 2-letter variable names such as $' or $[ or $3 if ($TEST =~ m/^(\$[0-9\<\>\(\)!?~=:;,.`'%@&#\+\_\[\]\|\/\\]{1})/) {

    Did you intend to include the variable @& in that regular expression?

    Neither $' nor $[ nor $3 contain any "letters" and they are all single character variable names (the sigil does not count as part of the name.)

    Also, you don't include single control character names like $^A, $^B, $^C, etc.

    Naked blocks are fun! -- Randal L. Schwartz, Perl hacker
      Sorry, I meant characters, not letters. Lol

      "Did you intend to include the variable @& in that regular expression?"

      No, it's not included in there. This regex is looking for something that starts with $ and is followed by one of the characters in the list. And @ and & happen to be in the list. But if a variable starts with @, it won't match. But now that I carefully looked at this part of the code, I noticed that if a character appears to be a variable but is not, then it gets eliminated from the double-quoted string instead of being left alone unchanged. I fixed that.

      Today I tried to modify the code to replace variables like $^A, but this caused warnings to appear when running the obfuscated code, because for some reason $^A is treated almost like $a or $b (I have never used these variables ever and don't even understand what they are for) but they apparently don't need to be declared. But if I come up with a new variable such as $XX and start using it in place of $^A, then perl is going to say wait a minute, you didn't declare $XX anywhere in the code, you just started using it.

        $^A is already obfuscated, so no need to obfuscate them twice ;-)
        For using their unobfuscated form, you have to use English; and you can look them up in perlvar (including $a and $b)
Re: My Perl Obfuscator
by bliako (Monsignor) on Jan 11, 2024 at 11:37 UTC

    nice! judging from the result you produced.

    Can I suggest Getopt::Long if you haven't already planned for it. And string obfuscation (which is tricky if it contains variables to be interpolated). Anyway, cool!

Re: My Perl Obfuscator
by jwkrahn (Abbot) on Jan 11, 2024 at 21:03 UTC
    sub ReadTheEntireFile { my $F = defined $_[0] ? $_[0] : ''; $F =~ tr`<>*?\"\|\x00-\x1F``d; # Remove illegal characters. ... sub CreateFile { defined $_[0] or return 0; my $F = shift; # Remove illegal characters from file name: $F =~ tr`<>*?\"\|\x00-\x1F``d;
    $ perl -le' my $x = join "", map chr, 0 .. 255; ( my $y = $x ) =~ tr`<>*?\"\|\x00-\x1F``d; use Data::Dumper; $Data::Dumper::Useqq = 1; print Dumper $_ for $x, $y; ' $VAR1 = "\0\1\2\3\4\5\6\a\b\t\n\13\f\r\16\17\20\21\22\23\24\25\26\27\3 +0\31\32\e\34\35\36\37 !\"#\$%&'()*+,-./0123456789:;<=>?\@ABCDEFGHIJKL +MNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~\177\200\201\202\2 +03\204\205\206\207\210\211\212\213\214\215\216\217\220\221\222\223\22 +4\225\226\227\230\231\232\233\234\235\236\237\240\241\242\243\244\245 +\246\247\250\251\252\253\254\255\256\257\260\261\262\263\264\265\266\ +267\270\271\272\273\274\275\276\277\300\301\302\303\304\305\306\307\3 +10\311\312\313\314\315\316\317\320\321\322\323\324\325\326\327\330\33 +1\332\333\334\335\336\337\340\341\342\343\344\345\346\347\350\351\352 +\353\354\355\356\357\360\361\362\363\364\365\366\367\370\371\372\373\ +374\375\376\377"; $VAR1 = " !#\$%&'()+,-./0123456789:;=\@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^ +_`abcdefghijklmnopqrstuvwxyz{}~\177\200\201\202\203\204\205\206\207\2 +10\211\212\213\214\215\216\217\220\221\222\223\224\225\226\227\230\23 +1\232\233\234\235\236\237\240\241\242\243\244\245\246\247\250\251\252 +\253\254\255\256\257\260\261\262\263\264\265\266\267\270\271\272\273\ +274\275\276\277\300\301\302\303\304\305\306\307\310\311\312\313\314\3 +15\316\317\320\321\322\323\324\325\326\327\330\331\332\333\334\335\33 +6\337\340\341\342\343\344\345\346\347\350\351\352\353\354\355\356\357 +\360\361\362\363\364\365\366\367\370\371\372\373\374\375\376\377";

    Your code removes control characters and certain punctuation but does not remove non-ASCII characters. Is this intentional?

    Naked blocks are fun! -- Randal L. Schwartz, Perl hacker
      "Your code removes control characters and certain punctuation but does not remove non-ASCII characters. Is this intentional?"

      Well, I really didn't have to include that line, but I did anyway just to be consistent. If I'm going to disallow certain characters in a file name when reading, then I would do the same for creating a file just to be consistent. The reason I chose to ban these characters is because they may be used for bad purposes when reading a file, and they're illegal anyway if you look at the file system specs. The NTFS and FAT file systems disallow creating files with characters 0x00-0x1F and you also can't have files that include: > < * ? | " but it's ok to have a file which contains characters from the extended ASCII chart (0x80-0xFF).

Re: My Perl Obfuscator
by jwkrahn (Abbot) on Jan 11, 2024 at 21:11 UTC
    sub Shuffle { for (my $i = 0; $i < @_; $i++) { my $R = int(rand(@_)); @_[$R, $i] = @_[$i, $R]; } return 0; }

    See perldoc -q shuffle for a better shuffle algorithm

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

      It's almost the same algorithm. The only difference is that the OP's always picks an item from the complete set, whereas Fisher-Yates picks from the set of unassigned items. I don't know if that affects the fairness of the algorithm. It's easy to see that F-Y is fair, but it's hard to see if the OP's is or not. [Upd: After some experimentation, I believe the OP's algorithm isn't fair, and is thus buggy.]

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: obfuscated [id://11156860]
Approved by Discipulus
help
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others perusing the Monastery: (2)
As of 2024-04-20 13:23 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found