Now There IS An App For That

I had to do something. This was something. So I did this.

This program collects the functions by module in a directory full of modules and checks a code base against it. This tells you which functions you are actually using. Which isn't quite what I wanted, but close.

I can see some additions I could want. Setting the library directory and code directories via Getopt::Long would be the first one. And it doesn't quite tell me what I want to know in all cases. If I use a function in a program that never gets called, it still gives me a result. But this is a place to start.

And because of this, I now know that, within the stack of previously-invented wheels called CPAN, there's a module called Regexp::Common that holds a stack of established regular expressions. I wanted to pull out all comments out of my programs for testing, so that a commented-out function doesn't count.

view plainprint?

1. #!/usr/bin/perl  
2.   
3. use 5.010 ;  
4. use strict ;  
5. use warnings ;  
6.   
7. use Cwd 'abs_path' ;  
8. use Regexp::Common qw /comment/ ;  
9.   
10. use subs qw{  
11.     check_programs  
12.     module_list  
13.   
14.     decomment  
15.   
16.     drop_pm  
17.     get_module_subs  
18.     pull_package_name  
19.     pull_module_name  
20.     pull_sub_name  
21.     } ;  
22.   
23. my $modules     = module_list '/path/to/my/lib' ;  
24. my $directories =  [  
25.     '/code/directory/one',  
26.     '/code/directory/two',  
27.     '/code/directory/three', ] ;  
28.   
29. my $data = check_programs( $directories, $modules ) ;  
30.   
31. for my $mod ( sort keys %$data ) {  
32.     my $module = $data->{ $mod } ;  
33.     say $mod ;  
34.     for my $sub ( sort keys %$module ) {  
35.         my $subroutine = $module->{ $sub } ;  
36.         say join "\t", '',  
37.             ( $subroutine->{ count } ? $subroutine->{ count } : 0 ) ,  
38.             $sub,  
39.             ;  
40.         }  
41.     }  
42.   
43. exit ;  
44.   
45. ########## ######### ######### ######### ######### #########  
46. ########## #########     Subroutines     ######### #########  
47. ########## ######### ######### ######### ######### #########  
48.   
49. #--------- --------- --------- --------- --------- --------- ---------  
50. # The core of the program  
51. sub check_programs {  
52.         my ( $directories, $modules ) = @_ ;  
53.         my $data ;  
54.         for my $program_dir ( @$directories ) {  
55.             my $program_directory = abs_path $program_dir ;  
56.             chdir $program_directory ;  
57.   
58.             #say $program_directory ;  
59.             my @directory = glob '*.cgi *.pl *.pm' ;  
60.   
61.             my $programs ;  
62.             @$programs = map {  
63.                 { $_ => get_program( $_ ) }  
64.                 } @directory ;  
65.             for my $program ( @$programs ) {  
66.                 my $k ;  
67.                 ( $k ) = keys %$program ;  
68.                 my $v = $program->{ $k } ;  
69.   
70.                 #say join "\t", '', $k ;  
71.                 for my $module ( @$modules ) {  
72.                     my $mk ;  
73.                     ( $mk ) = keys %$module ;  
74.                     my $mv = $module->{ $mk } ;  
75.   
76.                     #say join "\t", '', '', $mk ;  
77.                     for my $sub ( @$mv ) {  
78.                         my $result = $v =~ /$sub/ ? 1 : 0 ;  
79.   
80.                         #$result  
81.                         #    and say join "\t", '', '', '', $result, $sub ;  
82.                         $data->{ $mk }->{ $sub }->{ exists } = 1 ;  
83.                         if ( $result ) {  
84.                             $data->{ $mk }->{ $sub }->{ count }++ ;  
85.                             push @{ $data->{ $mk }->{ $sub }->{ used } },  
86.                                 abs_path $k ;  
87.                                 }  
88.                         }  
89.                     }  
90.                 }  
91.             }  
92.         return $data ;  
93.     }  
94.   
95. #--------- --------- --------- --------- --------- --------- ---------  
96. # returns the contents of a filename, if it contains 'perl' in the top  
97. sub get_program {  
98.         my ( $filename ) = @_ ;  
99.         if ( -f $filename ) {  
100.             if ( open my $fh, '<', $filename ) {  
101.                 my @lines =  
102.                     map { decomment $_ } <$fh> ;  
103.   
104.                 #return 0 if $lines[0] !~ m/perl/ ;  
105.                 return join '', @lines ;  
106.                 close $fh ;  
107.                 }  
108.             }  
109.         return 0 ;  
110.     }  
111.   
112. #--------- --------- --------- --------- --------- --------- ---------  
113. # removes Perl comments  
114. sub decomment {  
115.         my ( $code ) = @_ ;  
116.   
117.         #chomp $code ;  
118.         $code =~ s/$RE{comment}{Perl}// ;  
119.         return $code ;  
120.     }  
121.   
122. #--------- --------- --------- --------- --------- --------- ---------  
123. # returns an array ref of module names with an array of subroutines  
124. # the module contains  
125. sub module_list {  
126.         my ( $dir ) = @_ ;  
127.         my $directory = abs_path $dir ;  
128.         chdir $directory ;  
129.   
130.         my $output ;  
131.         my @directory = glob '*.pm' ;  
132.   
133.         @$output = map {  
134.             {  
135.                 ( pull_module_name join '/', $directory, $_ . '.pm' ) =>  
136.                     ( get_module_subs join '/', $directory, $_ . '.pm' )  
137.                     }  
138.             }  
139.             map { drop_pm $_ } @directory ;  
140.   
141.         return $output ;  
142.     }  
143.   
144. #--------- --------- --------- --------- --------- --------- ---------  
145. # returns an array ref to all the functions (minus internal functions  
146. # whose name starts with _) within a given module  
147. sub get_module_subs {  
148.         my ( $mod_path ) = @_ ;  
149.         my @output ;  
150.         if ( -f $mod_path ) {  
151.             if ( open my $fh, '<', $mod_path ) {  
152.                 my @lines = <$fh> ;  
153.                 push @output, grep { !/^_/ }  
154.                     map  { pull_sub_name $_ }  
155.                     grep { /^\s*sub / } @lines ;  
156.                 close $fh ;  
157.                 }  
158.             }  
159.         @output = sort @output ;  
160.         return \@output ;  
161.     }  
162.   
163. #--------- --------- --------- --------- --------- --------- ---------  
164. # return the package name of a module  
165. sub pull_module_name {  
166.         my ( $mod_path ) = @_ ;  
167.         my @output ;  
168.         if ( -f $mod_path ) {  
169.             if ( open my $fh, '<', $mod_path ) {  
170.                 my @lines = <$fh> ;  
171.                 push @output, map { pull_package_name $_ }  
172.                     grep { /^\s*package / } @lines ;  
173.                 close $fh ;  
174.                 }  
175.             }  
176.         return $output[ 0 ] ;  
177.     }  
178.   
179. #--------- --------- --------- --------- --------- --------- ---------  
180. # return the package name of a 'package Package::Name ;' string  
181. sub pull_package_name {  
182.         my ( $in ) = @_ ;  
183.         chomp $in ;  
184.         $in = ( split m{\s*package\s*}, $in )[ 1 ] ;  
185.         $in = ( split m/\s*;\s*/,       $in )[ 0 ] ;  
186.         return $in ;  
187.     }  
188.   
189. #--------- --------- --------- --------- --------- --------- ---------  
190. # return only the subroutine name from a 'sub sub_name { ' string  
191. sub pull_sub_name {  
192.         my ( $in ) = @_ ;  
193.         chomp $in ;  
194.         $in = ( split m{\s*sub\s*}, $in )[ 1 ] ;  
195.         $in = ( split m/\s*{\s*/,   $in )[ 0 ] ;  
196.         return $in ;  
197.     }  
198.   
199. #--------- --------- --------- --------- --------- --------- ---------  
200. # remove '.pm' from end of module file names  
201. sub drop_pm {  
202.         my ( $in ) = @_ ;  
203.         $in =~ s/\.pm$// ;  
204.         return $in ;  
205.     }  

#!/usr/bin/perl

use 5.010 ;
use strict ;
use warnings ;

use Cwd 'abs_path' ;
use Regexp::Common qw /comment/ ;

use subs qw{
    check_programs
    module_list

    decomment

    drop_pm
    get_module_subs
    pull_package_name
    pull_module_name
    pull_sub_name
    } ;

my $modules     = module_list '/path/to/my/lib' ;
my $directories =  [
    '/code/directory/one',
    '/code/directory/two',
    '/code/directory/three', ] ;

my $data = check_programs( $directories, $modules ) ;

for my $mod ( sort keys %$data ) {
    my $module = $data->{ $mod } ;
    say $mod ;
    for my $sub ( sort keys %$module ) {
        my $subroutine = $module->{ $sub } ;
        say join "\t", '',
            ( $subroutine->{ count } ? $subroutine->{ count } : 0 ) ,
            $sub,
            ;
        }
    }

exit ;

########## ######### ######### ######### ######### #########
########## #########     Subroutines     ######### #########
########## ######### ######### ######### ######### #########

#--------- --------- --------- --------- --------- --------- ---------
# The core of the program
sub check_programs {
        my ( $directories, $modules ) = @_ ;
        my $data ;
        for my $program_dir ( @$directories ) {
            my $program_directory = abs_path $program_dir ;
            chdir $program_directory ;

            #say $program_directory ;
            my @directory = glob '*.cgi *.pl *.pm' ;

            my $programs ;
            @$programs = map {
                { $_ => get_program( $_ ) }
                } @directory ;
            for my $program ( @$programs ) {
                my $k ;
                ( $k ) = keys %$program ;
                my $v = $program->{ $k } ;

                #say join "\t", '', $k ;
                for my $module ( @$modules ) {
                    my $mk ;
                    ( $mk ) = keys %$module ;
                    my $mv = $module->{ $mk } ;

                    #say join "\t", '', '', $mk ;
                    for my $sub ( @$mv ) {
                        my $result = $v =~ /$sub/ ? 1 : 0 ;

                        #$result
                        #    and say join "\t", '', '', '', $result, $sub ;
                        $data->{ $mk }->{ $sub }->{ exists } = 1 ;
                        if ( $result ) {
                            $data->{ $mk }->{ $sub }->{ count }++ ;
                            push @{ $data->{ $mk }->{ $sub }->{ used } },
                                abs_path $k ;
                                }
                        }
                    }
                }
            }
        return $data ;
    }

#--------- --------- --------- --------- --------- --------- ---------
# returns the contents of a filename, if it contains 'perl' in the top
sub get_program {
        my ( $filename ) = @_ ;
        if ( -f $filename ) {
            if ( open my $fh, '<', $filename ) {
                my @lines =
                    map { decomment $_ } <$fh> ;

                #return 0 if $lines[0] !~ m/perl/ ;
                return join '', @lines ;
                close $fh ;
                }
            }
        return 0 ;
    }

#--------- --------- --------- --------- --------- --------- ---------
# removes Perl comments
sub decomment {
        my ( $code ) = @_ ;

        #chomp $code ;
        $code =~ s/$RE{comment}{Perl}// ;
        return $code ;
    }

#--------- --------- --------- --------- --------- --------- ---------
# returns an array ref of module names with an array of subroutines
# the module contains
sub module_list {
        my ( $dir ) = @_ ;
        my $directory = abs_path $dir ;
        chdir $directory ;

        my $output ;
        my @directory = glob '*.pm' ;

        @$output = map {
            {
                ( pull_module_name join '/', $directory, $_ . '.pm' ) =>
                    ( get_module_subs join '/', $directory, $_ . '.pm' )
                    }
            }
            map { drop_pm $_ } @directory ;

        return $output ;
    }

#--------- --------- --------- --------- --------- --------- ---------
# returns an array ref to all the functions (minus internal functions
# whose name starts with _) within a given module
sub get_module_subs {
        my ( $mod_path ) = @_ ;
        my @output ;
        if ( -f $mod_path ) {
            if ( open my $fh, '<', $mod_path ) {
                my @lines = <$fh> ;
                push @output, grep { !/^_/ }
                    map  { pull_sub_name $_ }
                    grep { /^\s*sub / } @lines ;
                close $fh ;
                }
            }
        @output = sort @output ;
        return \@output ;
    }

#--------- --------- --------- --------- --------- --------- ---------
# return the package name of a module
sub pull_module_name {
        my ( $mod_path ) = @_ ;
        my @output ;
        if ( -f $mod_path ) {
            if ( open my $fh, '<', $mod_path ) {
                my @lines = <$fh> ;
                push @output, map { pull_package_name $_ }
                    grep { /^\s*package / } @lines ;
                close $fh ;
                }
            }
        return $output[ 0 ] ;
    }

#--------- --------- --------- --------- --------- --------- ---------
# return the package name of a 'package Package::Name ;' string
sub pull_package_name {
        my ( $in ) = @_ ;
        chomp $in ;
        $in = ( split m{\s*package\s*}, $in )[ 1 ] ;
        $in = ( split m/\s*;\s*/,       $in )[ 0 ] ;
        return $in ;
    }

#--------- --------- --------- --------- --------- --------- ---------
# return only the subroutine name from a 'sub sub_name { ' string
sub pull_sub_name {
        my ( $in ) = @_ ;
        chomp $in ;
        $in = ( split m{\s*sub\s*}, $in )[ 1 ] ;
        $in = ( split m/\s*{\s*/,   $in )[ 0 ] ;
        return $in ;
    }

#--------- --------- --------- --------- --------- --------- ---------
# remove '.pm' from end of module file names
sub drop_pm {
        my ( $in ) = @_ ;
        $in =~ s/\.pm$// ;
        return $in ;
    }