view release on metacpan or  search on metacpan

bin/cloc  view on Meta::CPAN

sub rm_blanks {                              # {{{1
    my ($ra_in    ,
        $language ,
        $rh_EOL_continuation_re) = @_;
    print "-> rm_blanks(language=$language)\n" if $opt_v > 2;
#print "rm_blanks: language = [$language]\n";
    my @out = ();
    if ($language eq "COBOL") {
        @out = remove_cobol_blanks($ra_in);
    } else {
        # removes blank lines
        if (defined $rh_EOL_continuation_re->{$language}) {
            @out = remove_matches_2re($ra_in, '^\s*$',
                                      $rh_EOL_continuation_re->{$language});
        } else {
            @out = remove_matches($ra_in, '^\s*$');
        }
    }

    print "<- rm_blanks(language=$language)\n" if $opt_v > 2;
    return @out;
} # 1}}}
sub rm_comments {                            # {{{1
    my ($ra_lines , # in, must be free of blank lines
        $language , # in
        $file     , # in (some language counters, eg Haskell, need
                    #     access to the original file)
        $rh_EOL_continuation_re , # in
        $raa_Errors , # out
       ) = @_;
    print "-> rm_comments(file=$file)\n" if $opt_v > 2;
    my @routines       = @{$Filters_by_Language{$language}};
    my @lines          = @{$ra_lines};
    my @original_lines = @{$ra_lines};

    if (!scalar @original_lines) {
        return @lines;
    }

    foreach my $call_string (@routines) {
        my $subroutine = $call_string->[0];
        if (! defined &{$subroutine}) {
            warn "rm_comments undefined subroutine $subroutine for $file\n";
            next;
        }
        print "rm_comments file=$file sub=$subroutine\n" if $opt_v > 1;
        my @args  = @{$call_string};
        shift @args; # drop the subroutine name
        if (@args and $args[0] eq '>filename<') {
            shift   @args;
            unshift @args, $file;
        }
#use Data::Dumper;
#print "\ncall_string=", Dumper($call_string);
#print "args=\n";
#print Dumper(\@args);
#print "lines before=\n";
#print Dumper(\@lines);

        # Unusual inputs, namely /* within strings without
        # a corresponding */ can cause huge delays so put a timer on this.
        my $max_duration_sec = scalar(@lines)/1000.0; # est lines per second
           $max_duration_sec = 1.0 if $max_duration_sec < 1;
#print "max_duration_sec=$max_duration_sec\n";
        eval {
            local $SIG{ALRM} = sub { die "alarm\n" };
            alarm $max_duration_sec;
            no strict 'refs';
            @lines = &{$subroutine}(\@lines, @args);   # apply filter...
            alarm 0;
        };
        if ($@) {
            # timed out
            die unless $@ eq "alarm\n";
            push @{$raa_Errors},
                [ $Error_Codes{'Line count, exceeded timeout'}, $file ];
            if ($opt_v) {
                warn "rm_comments($subroutine): exceeded timeout for $file--ignoring\n";
            }
            next;
        }

#print "lines after=\n";
#print Dumper(\@lines);

        print_lines($file, "After $subroutine(@args)", \@lines)
            if $opt_print_filter_stages;
        # then remove blank lines which are created by comment removal
        if (defined $rh_EOL_continuation_re->{$language}) {
            @lines = remove_matches_2re(\@lines, '^\s*$',
                                        $rh_EOL_continuation_re->{$language});
        } else {
            @lines = remove_matches(\@lines, '^\s*$');
        }

        print_lines($file, "post $subroutine(@args) blank cleanup:", \@lines)
            if $opt_print_filter_stages;
    }
    # Exception for scripting languages:  treat the first #! line as code.
    # Will need to add it back in if it was removed earlier.
    if (defined $Script_Language{$language} and
        $original_lines[0] =~ /^#!/ and
        (scalar(@lines) == 0 or
         $lines[0] ne $original_lines[0])) {
        unshift @lines, $original_lines[0];  # add the first line back
    }

    foreach (@lines) { chomp }   # make sure no spurious newlines were added

    print "<- rm_comments\n" if $opt_v > 2;
    return @lines;
} # 1}}}
sub remove_f77_comments {                    # {{{1
    my ($ra_lines, ) = @_;
    print "-> remove_f77_comments\n" if $opt_v > 2;

    my @save_lines = ();
    foreach (@{$ra_lines}) {
        next if m{^[*cC]};
        next if m{^\s*!};
        push @save_lines, $_;