Acme::Comment - Acme::Comment documentation

    use Acme::Comment type=>'C++', own_line=>1;

    /*
    if (ref $mod) {
        $bar->{do}->blat(msg => 'blarg');
        eval {

    i'm sooo sick of this time for some coffee

    */

    // I prefer beer.  --sqrn

    /* This is my real comment.
    */
    $foo = 1;

    /* comment */

package Acme::Comment;

use strict;
use Filter::Simple;

BEGIN {
    use vars qw($VERSION);
    $VERSION    =   '1.04';
}

my $TypeCount = 0;
my $Type = 'C';
my $Conf;

{   no warnings;
    $Conf = {
        C   => {
            own_line    => 1,
            start       => quotemeta '/*',
            end         => quotemeta '*/',
            one_line    => 0,
        },
        HTML    => {
            own_line    => 1,
            start       => quotemeta '<!--',
            end         => quotemeta '-->',
            one_line    => 0,
        },
        RUBY    => {
            own_line    => 1,
            start       => quotemeta '=begin',
            end         => quotemeta '=end',
            one_line    => 0,
            single      => '#',
        },
        JAVA    => {
            own_line    => 1,
            start       => quotemeta '/*',
            end         => quotemeta '*/',
            one_line    => 0,
            single      => quotemeta '//',
        },
        PASCAL  => {
            own_line    => 1,
            start       => quotemeta '(*',
            end         => quotemeta '*)',
            one_line    => 0,
        },

        ALGOL  => {
            own_line    => 1,
            start       => quotemeta "'comment'",
            end         => quotemeta ';',
            one_line    => 0,
        },

        HUGO    => {
            own_line    => 1,
            start       => quotemeta '!\\',
            end         => quotemeta '\!',
            one_line    => 0,
            single      => '!(?!\\\\)',
        },

        BASIC   =>  {
            single      =>  q['],
        },
        PILOT   =>  {
            single      => quotemeta '\/\/',
        },
        BLUE   =>  {
            single      => '(?:==)|(?:--)',
        },

        INTERCAL    => {
            single  => '(?:\(\d+\)\s*)?DO NOTE THAT',
        },
        FORTRAN     => {
            single  => quotemeta '!',
        },
        PERL        => {
            single      => quotemeta q[#],
        },
        ALAN        => {
            single      => "--",
        },
        ORTHOGONAL  => {
            single      => quotemeta ";",
        },
        FOCAL  => {
            single      => "comment",
        },
        LATEX  => {
            single      => quotemeta "%",
        },
        FOXBASE => {
            single      => '(?:\*)|(?:&&)',
        }
    };


    ### the comment styles for ADA and Basic are the same ###
    for my $type(qw|ADA|)                               { $Conf->{$type} = $Conf->{'BASIC'} }

    for my $type(qw|POSTSCRIPT|)                        { $Conf->{$type} = $Conf->{'LATEX'} }

    for my $type(qw|ADVSYS LISP SCHEME|)                { $Conf->{$type} = $Conf->{'ORTHOGONAL'} }

    for my $type(qw|EIFFEL HASKELL|)                    { $Conf->{$type} = $Conf->{'ALAN'} }

    for my $type(qw|BETA BLISS JOY VAR'AQ|)             { $Conf->{$type} = $Conf->{'PASCAL'} }

    for my $type(qw|B PL/I CHILL|)                      { $Conf->{$type} = $Conf->{'C'} }

    for my $type(qw|C++ PHP C# CLEAN ELASTIC GUILE|)    { $Conf->{$type} = $Conf->{'JAVA'} }

    for my $type(qw|PYTHON PARROT AWK UNLAMBDA E ICON|) { $Conf->{$type} = $Conf->{'PERL'} }
}

sub import {
    my $package = shift;
    my %args    = @_;

    if(@_%2){
        die "Incomplete set of arguments to $package\n"
    }

    ### see if there are any arguments, if not, we default to the C comment style ###
    if( keys %args ) {

        ### check if the user requested a certain type of comments ###
        if( $args{type} ) {

            ### and check if it even exists ###
            if( $Conf->{ uc $args{type} } ) {
                $Type = uc $args{type};

                $Conf->{$Type}->{own_line} = $args{own_line} if defined $args{own_line};
                $Conf->{$Type}->{one_line} = $args{one_line} if defined $args{one_line};

            ### otherwise die with an error ###
            } else {
                die "Requested an unsupported type $args{type} for Acme::Comment\n";
            }

        ### otherwise, define a new type for the user ###
        } else {
            $Type = ++$TypeCount;

            unless( (defined $args{start} and defined $args{end}) or defined $args{single} ) {
                die "You need to specify both start and end tags OR a single line comment!\n";
            } else {
                if( defined $args{start} and defined $args{end} and $args{start} eq $args{end} ) {
                    die "Start and end tags must be different!\n";
                }

                $Conf->{$TypeCount}->{start}    = quotemeta($args{start})  if defined $args{start};
                $Conf->{$TypeCount}->{end}      = quotemeta($args{end})    if defined $args{end};
                $Conf->{$TypeCount}->{single}   = quotemeta($args{single}) if defined $args{single}
            }

            $Conf->{$TypeCount}->{own_line} = defined $args{own_line}
                                                ? $args{own_line}
                                                : 1;

            $Conf->{$TypeCount}->{one_line} = defined $args{one_line}
                                                ? $args{one_line}
                                                : 0;

        }

    ### no arguments, Let's take the default C comment style ###
    }
}

sub parse {

    #use Data::Dumper;
    #print scalar @_;
    #die Dumper \@_;

    my $str = shift;

    my $start   = $Conf->{$Type}->{start}     if $Conf->{$Type}->{start};
    my $end     = $Conf->{$Type}->{end}       if $Conf->{$Type}->{end};
    my $single  = $Conf->{$Type}->{single}    if $Conf->{$Type}->{single};

    my ($rdel,$ldel);
    my ($roneline, $loneline);

    if( $start && $end ) {
        ### having the comments on their own line is recommended
        ### to avoid ambiguity -kane
        $roneline = '\s*' . $end . '\s*$';
        $loneline = '^\s*' . $start . '\s*';

        if( $Conf->{$Type}->{own_line} ){
            $rdel = '^' . $roneline;
            $ldel = $loneline . '$';
        } else {
            $rdel = $roneline;
            $ldel = $loneline;
        }
    }

    ### loop counter ###
    my $i;

    ### tag counter ###
    my $counter;

    ### line number of the last found comment open ###
    my $lastopen;

    ### return value container ###
    my @return;

    for my $line (split/\n/, $str) {
        ### increase line counter ###
        $i++;

        ### if there is a single line comment available ##
        if($single) {
            if( $line =~ m|^\s*$single| ) {
    	        push @return, "";
    	    	next;
	        }
        }

        ### check if we have multiline comment options ###
        if($roneline && $loneline) {
            ### check if we are allowed to have comments on one line
            ### and if so, see if they match
            if( $Conf->{$Type}->{one_line} ) {
                if( $line =~ /$loneline.*?$roneline/) {
		            push @return, "";
                    next;
                }
            }

            ### if we find an opening tag, add to the counter
            ### and mark the line number
            if( $line =~ /$ldel/ ) {
                $lastopen = $i;
                $counter++;
		        push @return, "";
                next;

            ### if we find a closing tag, decreate the counter
            ### if counter was already at zero, there's a syntax error
            } elsif ( $line =~  /$rdel/ ) {
                unless($counter) {
                    die "Missing opening comment for closing comment on line $i\n";
                }
                $counter--;
		        push @return, "";
                next;
            }
        }

        ### if we have a counter, we're still inside a comment
        ### so dont add it then.. if the line is just whitespace
        ### we might as well ingore it too
        unless($counter or $line =~ /^\s*$/) {
            push @return, $line ;
            next;
        } else {
		    push @return, "";
		    next;
	    }
    }

    ### if we have a counter left after parsing all the lines
    ### we must have an opening tag (or more) that dont have a closing tag
    if($counter){ die "No closing bracket found for opening comment at line $lastopen\n" }

    ### Filter::Simple demands we return $_ ###
    $_ = join "\n", @return;

    return $_;
}

sub _gimme_conf { return $Conf };

FILTER_ONLY executable => sub { parse($_); };


1;