123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184 |
- #!/usr/bin/perl
- # Author: Daniel "Trizen" Șuteu
- # License: GPLv3
- # Date: 04 January 2015
- # Website: https://github.com/trizen
- #
- ## Analyze your Perl code and see whether you are or not a true Perl hacker!
- #
- # More info about this script:
- # https://trizenx.blogspot.com/2015/01/perl-code-analyzer.html
- use utf8;
- use 5.010;
- use strict;
- use warnings;
- use IPC::Open2 qw(open2);
- use Encode qw(encode_utf8 decode_utf8);
- use Getopt::Long qw(GetOptions);
- use Algorithm::Diff qw(LCS_length);
- use Perl::Tokenizer qw(perl_tokens);
- my $strict_level = 1;
- my %ignored_types;
- sub help {
- my ($code) = @_;
- print <<"HELP";
- usage: $0 [options] [file] [...]
- options:
- --strict [level] : sets the strictness level (default: $strict_level)
- Valid strict levels:
- >= 1 : ignores strings, PODs, comments, spaces and semicolons
- >= 2 : ignores round parentheses
- >= 3 : ignores here-documents, (q|qq|qw|qx) quoted strings
- >= 4 : ignores hex and binary literal numbers
- If level=0, any stricture will be disabled.
- HELP
- exit($code // 0);
- }
- GetOptions('strict=i' => \$strict_level,
- 'help|h' => sub { help(0) },)
- or die("Error in command line arguments\n");
- @ARGV || help(2);
- if ($strict_level >= 1) {
- @ignored_types{
- qw(
- pod
- data
- comment
- vertical_space
- horizontal_space
- other_space
- semicolon
- double_quoted_string
- single_quoted_string
- )
- } = ();
- }
- if ($strict_level >= 2) {
- @ignored_types{
- qw(
- parenthesis_open
- parenthesis_close
- )
- } = ();
- }
- if ($strict_level >= 3) {
- @ignored_types{
- qw(
- heredoc
- heredoc_beg
- q_string
- qq_string
- qw_string
- qx_string
- )
- } = ();
- }
- if ($strict_level >= 4) {
- @ignored_types{
- qw(
- hex_number
- binary_number
- )
- } = ();
- }
- sub deparse {
- my ($code) = @_;
- local (*CHLD_IN, *CHLD_OUT);
- my $pid = open2(\*CHLD_OUT, \*CHLD_IN, $^X, '-MO=Deparse', '-T');
- print CHLD_IN encode_utf8($code);
- close(CHLD_IN);
- my $deparsed = do {
- local $/;
- decode_utf8(<CHLD_OUT>);
- };
- waitpid($pid, 0);
- my $child_exit_status = $? >> 8;
- if ($child_exit_status != 0) {
- die "B::Deparse failed with code: $child_exit_status\n";
- }
- return $deparsed;
- }
- sub get_tokens {
- my ($code) = @_;
- my @tokens;
- perl_tokens {
- my ($token) = @_;
- if (not exists $ignored_types{$token}) {
- push @tokens, $token;
- }
- }
- $code;
- return @tokens;
- }
- foreach my $script (@ARGV) {
- print STDERR "=> Analyzing: $script\n";
- my $code = do {
- open my $fh, '<:utf8', $script;
- local $/;
- <$fh>;
- };
- my $d_code = eval { deparse($code) };
- $@ && do { warn $@; next };
- my @types = get_tokens($code);
- my @d_types = get_tokens($d_code);
- if (@types == 0 or @d_types == 0) {
- warn "This script seems to be empty! Skipping...\n";
- next;
- }
- my $len = LCS_length(\@types, \@d_types) - abs(@types - @d_types);
- my $score = (100 - ($len / @types * 100));
- if ($score >= 60) {
- printf("WOW!!! We have here a score of %.2f! This is obfuscation, isn't it?\n", $score);
- }
- elsif ($score >= 40) {
- printf("Outstanding! This code seems to be written by a true legend! Score: %.2f\n", $score);
- }
- elsif ($score >= 20) {
- printf("Amazing! This code is very unique! Score: %.2f\n", $score);
- }
- elsif ($score >= 15) {
- printf("Excellent! This code is written by a true Perl hacker. Score: %.2f\n", $score);
- }
- elsif ($score >= 10) {
- printf("Awesome! This code is written by a Perl expert. Score: %.2f\n", $score);
- }
- elsif ($score >= 5) {
- printf("Just OK! We have a score of %.2f! This is production code, isn't it?\n", $score);
- }
- else {
- printf("What is this? I guess it is some baby Perl code, isn't it? Score: %.2f\n", $score);
- }
- }
|