source: trunk/gsdl/perllib/plugins/SRCPlug.pm@ 1917

###########################################################################
#
# SRCPlug.pm -- source code plugin
#
# A component of the Greenstone digital library software
# from the New Zealand Digital Library Project at the 
# University of Waikato, New Zealand.
#
# Copyright (C) 1999 New Zealand Digital Library Project
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
###########################################################################
# John McPherson Nov 2000
# originally based on TEXTPlug

# filename is currently used for Title ( optionally minus some prefix )

# Current languages:
#   text: READMEs/Makefiles
#   C/C++   (currently extracts #include statements and C++ class decls)
#   Perl    (currently only done as text)
#   Shell   (currently only done as text)


package SRCPlug;

use BasPlug;
use parsargv;

sub BEGIN {
    @ISA = ('BasPlug');
}


sub print_usage {
    print STDERR "\n  usage: plugin SRCPlug [options]\n";
    print STDERR "Try to import C and C++ source code. Adds \"class\"";
    print STDERR " metadata.\n\n";
    print STDERR "  options:\n";
    print STDERR "  -remove_prefix <pattern>   Remove this leading pattern from the filename\n";
    print STDERR "                             (eg -remove_prefix /tmp/XX/src/). The default is to\n";
    print STDERR "                             remove the whole path from the filename.\n";
    print STDERR "\n";
}

sub new {
    my ($class) = @_;
    my $self = new BasPlug ($class, @_);

    if (!parsargv::parse(\@_,
             q^remove_prefix/(\S+)/^, \$self->{'remove_prefix'},
             "allow_extra_options"
             )
    ) {
        print STDERR "\nIncorrect options passed to SRCPlug, ";
        print STDERR "check your collect.cfg configuration file\n";
        &print_usage();
        die "\n";
    }
    return bless $self, $class;
}

sub get_default_block_exp {
    my $self = shift (@_);

    return q^(?i)\.(o|obj|a|so|dll)$^;
}

sub get_default_process_exp {
    my $self = shift (@_);

#    return q^(?i)\.te?xt$^;
    return q^(Makefile.*|README.*|(?i)\.(c|cc|cpp|C|h|hpp|pl|pm|sh))$^;
}



# do plugin specific processing of doc_obj
sub process {
    my $self = shift (@_);
    my ($textref, $pluginfo, $base_dir, $file, $metadata, $doc_obj) = @_;
    my $outhandle = $self->{'outhandle'};
    
    print $outhandle "SRCPlug: processing $file\n" 
    if $self->{'verbosity'} > 1;
    
    my $cursection = $doc_obj->get_top_section();

    my $filetype="text";  # Makefiles, READMEs, ...
    if ($file =~ /\.(cc|h|cpp|C)$/) {$filetype="C++";} # assume all .h files...
    elsif ($file =~ /\.c$/)         {$filetype="C";}
    elsif ($file =~ /\.p(l|m)$/)    {$filetype="perl";}
    elsif ($file =~ /\.sh$/)        {$filetype="sh";}

    # modify '<' and '>' for GML... (even though inside <pre> tags!!)
    $$textref =~ s/</&lt;/g;
    $$textref =~ s/>/&gt;/g;
    $$textref =~ s/_/&#95;/g;
    # try _escape_text($text) from doc.pm....


    # use filename (minus any prefix) as the title.
    my $title;
    if ($self->{'remove_prefix' ne ""}) {
    ($title = $file) =~ s/^$self->{'remove_prefix'}//;
    } else {
    ($title = $file) =~ s@^.*(/|\\)@@; # remove pathname by default
    }
    $doc_obj->add_utf8_metadata ($cursection, "Title", $title);
    $doc_obj->add_utf8_metadata ($cursection, "filename", $file);

    # class information from .h and .cc and .C and .cpp files
    if ($filetype eq "C++") 
    {
    process_c_plus_plus($textref,$pluginfo, $base_dir, 
                   $file, $metadata, $doc_obj);
    } elsif ($filetype eq "C")
    {
    get_includes_metadata($textref, $doc_obj);
    }


     # default operation...
     # insert preformat tags and add text to document object
    $doc_obj->add_utf8_text($cursection, "<pre>\n$$textref\n</pre>");
    
    return 1;
}




sub get_includes_metadata {
    my ($textref, $doc_obj) = @_;
    
    my $topsection = $doc_obj->get_top_section();

    # Get '#include' directives for metadata
    if ($$textref =~ /\#\W?include\b/) {
    my $includes=$$textref;

    # remove commented lines
    $includes =~ s@/\*.*?\*/@@sg; # treat string as single line
    # ? means match smallest instead of longest !!!
    $includes =~ s@//.*$@@mg; # treat string as multiple lines

    # remove non- include lines (well, lines without a '#')
    $includes =~ s/^[^\#]*$//mg;

    # lines don't always start '#include "'.... we have to allow (eg)
    # '#  include ...'
    # '  #include ...'
    while ($includes =~ /\#\W?include/) {
        $includes =~ s/^.*?include.*?(\"|&lt;)(.*)(\"|&gt;).*$//m;
        # $1 is now the filename between the "s.
        my $include=$2;
        # remove leading pathname
        $include =~ s@^.*(/|\\)@@;

        my $incs_done=$doc_obj->get_metadata($section, "includes");
        foreach my $elem (@$incs_done) {
        if ("$elem" eq "$include") {goto header_done;}
        }
        $doc_obj->add_utf8_metadata($topsection, "includes", $include);
      header_done:
    }
    }
}



sub process_c_plus_plus {
    my ($textref, $pluginfo, $base_dir, $file, $metadata, $doc_obj) = @_;

    my $topsection = $doc_obj->get_top_section();


    # Check for include metadata
    get_includes_metadata($textref, $doc_obj);



    # Get class declarations (but not forward declarations...) as metadata
    if ($$textref =~ /\bclass\b/ ) {
    my $classnames=$$textref;
    
    # remove commented lines
    $classnames =~ s@/\*.*?\*/@@sg;
    $classnames =~ s@//.*$@@mg;
    while ($classnames =~ /\bclass\b/) {

        # delete all lines up to the next "class"
        while ($classnames !~ /^[^\n]*\bclass\b[^\n]*\n/)
        {$classnames =~ s/.*\n//;}
        
#       $classnames =~ s/^([^c][^l])*(.)?$//mg; # delete unneccessary lines

        # get the line including the next "class" and remove it from
        # our tmp text.
        $classnames =~ s/^(.*\bclass\b.*)$//m;

        # don't index if merely a reference/fwd decl. of another class
        if ($1 !~ /(friend\Wclass)|(class\W\w+\W?\;)|(\/\/.*class)/) {
        # $1 is still the whole line - eg:
        # "class StaffSystem: public BaseStaffSystem"
        my $wholeline=$1;
        my $classname=$1;
        $classname =~ s/.*class\W(\w+).*/$1/;
        my $classes=$doc_obj->get_metadata($section, "class");
        foreach my $elem (@$classes) {
            if ("$elem" eq "$classname") {goto class_done;}
        }
        $doc_obj->add_utf8_metadata($topsection, "class", $classname);
          class_done:
        $doc_obj->add_utf8_metadata($topsection, "classdecl", $wholeline);
        }
    }
    } # end of "class"

    return 1;
}

1;