File Coverage

blib/lib/File/Comments.pm

Criterion	Covered	Total	%
statement	116	164	70.7
branch	23	58	39.6
condition	5	6	83.3
subroutine	23	25	92.0
pod	5	11	45.4
total	172	264	65.1

###########################################
# File::Comments -- 2005, Mike Schilli
###########################################

###########################################
package File::Comments;
###########################################

use strict;
use warnings;
use Log::Log4perl qw(:easy);
use Sysadm::Install qw(:all);
use File::Basename;
use Module::Pluggable
  require     => 1,
  #search_path => [qw(File::Comments::Plugin)],
  ;

our $VERSION = "0.08";

###########################################
sub new {
###########################################
    my($class, %options) = @_;

    my $self = {

        cold_calls     => 1,
        default_plugin => undef,

        suffixes   => {},
        bases      => {},
        plugins    => [],
        %options,
    };

    bless $self, $class;

        # Init plugins
    $self->init();

    return $self;
}

###########################################
sub init {
###########################################
    my($self) = @_;

    $self->{plugins} = [];

    for($self->plugins()) {
        DEBUG "Initializing plugin $_";
        my $plugin = $_->new(mothership => $self);
        push @{$self->{plugins}}, $plugin;
    }
}

###########################################
sub find_plugin {
###########################################
    my($self) = @_;

        # Is there a suffix handler defined?
    if(defined $self->{target}->{suffix} and
       exists $self->{suffixes}->{$self->{target}->{suffix}}) {

        DEBUG "Searching for plugin handling suffix $self->{target}->{suffix}";

        for my $plugin (@{$self->{suffixes}->{$self->{target}->{suffix}}}) {
            DEBUG "Checking if ", ref $plugin,
                  " is applicable for suffix ",
                  "'$self->{target}->{suffix}'";
            if($plugin->applicable($self->{target})) {
                DEBUG ref($plugin), " accepted";
                return $plugin;
            } else {
                DEBUG ref($plugin), " rejected";
            }
        }
    }

        # Is there a base handler defined?
    if(defined $self->{target}->{file_base} and
       exists $self->{bases}->{$self->{target}->{file_base}}) {

        DEBUG "Searching for plugin handling base $self->{target}->{file_base}";

        for my $plugin (@{$self->{bases}->{$self->{target}->{file_base}}}) {
            DEBUG "Checking if ", ref $plugin,
                  " is applicable for base ",
                  "'$self->{target}->{file_base}'";
            if($plugin->applicable($self->{target})) {
                DEBUG ref($plugin), " accepted";
                return $plugin;
            } else {
                DEBUG ref($plugin), " rejected";
            }
        }
    }

        # Hmm ... no volunteers yet.
    return undef unless $self->{cold_calls};

        # Go from door to door and check if some plugin wants to
        # handle it. Set the 'cold_call' flag to let the plugin know
        # about our desparate move.
    for my $plugin (@{$self->{plugins}}) {
         DEBUG "Checking if ", ref $plugin, " is applicable for ",
               "file '$self->{target}->{path}' (cold call)";
        if($plugin->applicable($self->{target}, 1)) {
            DEBUG "Cold call accepted";
            return $plugin;
        } else {
            DEBUG "Cold call rejected";
        }
    }

    return undef;
}

###########################################
sub guess_type {
###########################################
    my($self, $target) = @_;

    if(ref $target) {
        $self->{target} = $target;
    } else {
        $self->{target} = File::Comments::Target->new(path => $target);
    }

    my $plugin = $self->find_plugin();

    if(! defined $plugin) {
        ERROR "No plugin found to handle $target";
        return undef;
    }

    return $plugin->type();
}

###########################################
sub comments {
###########################################
    my($self, $target) = @_;

    return  $_[0]->dispatch($target, "comments");
}

###########################################
sub stripped {
###########################################
    my($self, $target) = @_;

    return  $_[0]->dispatch($target, "stripped");
}

###########################################
sub dispatch {
###########################################
    my($self, $target, $function) = @_;

    if(ref $target) {
        $self->{target} = $target;
    } else {
        $self->{target} = File::Comments::Target->new(path => $target);
    }

    my $plugin = $self->find_plugin();

    if(! defined $plugin) {
        if($self->{default_plugin}) {
            $plugin = $self->{default_plugin};
        } else {
            ERROR "Type of $target couldn't be determined";
                # Just return and empty list
            return undef;
        }
    }

    DEBUG "Calling ", ref $plugin,
          " to handle $self->{target}->{path}";

    return $plugin->$function($self->{target});
}

###########################################
sub register_suffix {
###########################################
    my($self, $suffix, $plugin_obj) = @_;

    DEBUG "Registering ", ref $plugin_obj,
          " as a handler for suffix $suffix";

        # Could be more than one, line them up
    push @{$self->{suffixes}->{$suffix}}, $plugin_obj;
}

###########################################
sub suffix_registered {
###########################################
    my($self, $suffix) = @_;

    return exists $self->{suffixes}->{$suffix};
}

###########################################
sub register_base {
###########################################
    my($self, $base, $plugin_obj) = @_;

    DEBUG "Registering ", ref $plugin_obj,
          " as a handler for base $base";

        # Could be more than one, line them up
    push @{$self->{bases}->{$base}}, $plugin_obj;
}

##################################################
# Poor man's Class::Struct
##################################################
sub make_accessor {
##################################################
    my($package, $name) = @_;

    no strict qw(refs);

    my $code = <
        *{"$package\\::$name"} = sub {
            my(\$self, \$value) = \@_;

            if(defined \$value) {
                \$self->{$name} = \$value;
            }
            if(exists \$self->{$name}) {
                return (\$self->{$name});
            } else {
                return "";
            }
        }
EOT
    if(! defined *{"$package\::$name"}) {
        eval $code or die "$@";
    }
}

###########################################
package File::Comments::Target;
###########################################
use Sysadm::Install qw(:all);
use File::Basename;
use Log::Log4perl qw(:easy);

###########################################
sub new {
###########################################
    my($class, %options) = @_;

    my $self = {
        path       => undef,
        dir        => undef,
        file_name  => undef,
        file_base  => undef,
        content    => undef,
        suffix     => undef,
        %options,
    };

    bless $self, $class;

    $self->load($self->{path}, $self->{content});

    return $self;
}

###########################################
sub load {
###########################################
    my($self, $path, $content) = @_;

    $self->{content}   = $content unless $content;
    $self->{path}      = $path;
    $self->{content}   = slurp $path unless defined $self->{content};

    $self->{file_name} = basename($path);

    $self->{dir}       = dirname($path);
    $self->{suffix}    = undef;
    $self->{file_base} = $self->{file_name};

    if(index($self->{file_name}, ".") >= 0) {
        ($self->{file_base}, $self->{suffix}) =
            ($self->{file_name} =~ m#(.+)(\.[^.]*$)#);
    }

    DEBUG "Loaded file path=", def($path),
          " name=",            def($self->{file_name}),
          " dir=",             def($self->{dir}),
          " suffix=",          def($self->{suffix}),
          " base=",            def($self->{file_base});
}

###########################################
sub def {
###########################################
    return $_[0] if defined $_[0];
    return "**undef**";
}

File::Comments::make_accessor("File::Comments::Target", $_)
   for qw(path file_name file_base content suffix dir);

1;

__END__