File Coverage

blib/lib/Acme/MetaSyntactic.pm

Criterion	Covered	Total	%
statement	117	119	98.3
branch	29	30	96.6
condition	2	2	100.0
subroutine	21	22	95.4
pod	7	7	100.0
total	176	180	97.7

package Acme::MetaSyntactic;
$Acme::MetaSyntactic::VERSION = '1.014';
use strict;
use warnings;
use Carp;
use File::Basename;
use File::Spec;
use File::Glob;

# some class data
our $Theme = 'foo'; # default theme
our %META;

# private class method
sub _find_themes {
    my ( $class, @dirs ) = @_;
    return
        map  @$_,
        grep { $_->[0] !~ /^[A-Z]/ }    # remove the non-theme subclasses
        map  { [ ( fileparse( $_, qr/\.pm$/ ) )[0] => $_ ] }
        map  { File::Glob::bsd_glob( File::Spec->catfile( $_, qw( Acme MetaSyntactic *.pm ) ) ) } @dirs;
}

# fetch the list of standard themes
$META{$_} = 0 for keys %{ { __PACKAGE__->_find_themes(@INC) } };

# the functions actually hide an instance
my $meta = Acme::MetaSyntactic->new( $Theme );

# END OF INITIALISATION

# support for use Acme::MetaSyntactic 'foo'
# that automatically loads the required classes
sub import {
    my $class = shift;

    my @themes = ( grep { $_ eq ':all' } @_ )
      ? ( 'foo', grep { !/^(?:foo|:all)$/ } keys %META ) # 'foo' is still first
      : @_;

    $Theme = $themes[0] if @themes;
    $meta = Acme::MetaSyntactic->new( $Theme );

    # export the metaname() function
    no strict 'refs';
    my $callpkg = caller;
    *{"$callpkg\::metaname"} = \&metaname;    # standard theme

    # load the classes in @themes
    for my $theme( @themes ) {
        eval "require Acme::MetaSyntactic::$theme; import Acme::MetaSyntactic::$theme;";
        croak $@ if $@;
        *{"$callpkg\::meta$theme"} = sub { $meta->name( $theme, @_ ) };
    }
}

sub new {
    my ( $class, @args ) = ( @_ );
    my $theme;
    $theme = shift @args if @args % 2;
    $theme = $Theme unless $theme; # same default everywhere

    # defer croaking until name() is actually called
    bless { theme => $theme, args => { @args }, meta => {} }, $class;
}

# CLASS METHODS
sub add_theme {
    my $class  = shift;
    my %themes = @_;

    for my $theme ( keys %themes ) {
        croak "The theme $theme already exists!" if exists $META{$theme};
        my @badnames = grep { !/^[a-z_]\w*$/i } @{$themes{$theme}};
        croak "Invalid names (@badnames) for theme $theme"
          if @badnames;

        my $code = << "EOC";
package Acme::MetaSyntactic::$theme;
use strict;
use Acme::MetaSyntactic::List;
our \@ISA = qw( Acme::MetaSyntactic::List );
our \@List = qw( @{$themes{$theme}} );
1;
EOC
        eval $code;
        $META{$theme} = 1; # loaded

        # export the metatheme() function
        no strict 'refs';
        my $callpkg = caller;
        *{"$callpkg\::meta$theme"} = sub { $meta->name( $theme, @_ ) };
    }
}

# load the content of __DATA__ into a structure
# this class method is used by the other Acme::MetaSyntactic classes
sub load_data {
    my ($class, $theme ) = @_;
    my $data = {};

    my $fh;
    { no strict 'refs'; $fh = *{"$theme\::DATA"}{IO}; }

    my $item;
    my @items;
    $$item = "";

    {
        local $_;
        while (<$fh>) {
            /^#\s*(\w+.*)$/ && do {
                push @items, $item;
                $item = $data;
                my $last;
                my @keys = split m!\s+|\s*/\s*!, $1;
                $last = $item, $item = $item->{$_} ||= {} for @keys;
                $item = \( $last->{ $keys[-1] } = "" );
                next;
            };
            s/#.*//;    # remove end-of-line comments
            $$item .= $_;
        }
    }

    # avoid leaving all the DATA handles open
    close $fh;

    # clean up the items
    for( @items, $item ) {
        $$_ =~ s/\A\s*//;
        $$_ =~ s/\s*\z//;
        $$_ =~ s/\s+/ /g;
    }
    return $data;
}

# main function
sub metaname { $meta->name( @_ ) };

# corresponding method
sub name {
    my $self = shift;
    my ( $theme, $count );

    if (@_) {
        ( $theme, $count ) = @_;
        ( $theme, $count ) = ( $self->{theme}, $theme )
          if $theme =~ /^(?:0|[1-9]\d*)$/;
    }
    else {
        ( $theme, $count ) = ( $self->{theme}, 1 );
    }

    if( ! exists $self->{meta}{$theme} ) {
        my ( $Theme, $category ) = split /\//, $theme, 2;
        if( ! $META{$Theme} ) {
            eval "require Acme::MetaSyntactic::$Theme;";
            croak "Metasyntactic list $Theme does not exist!" if $@;
            $META{$theme} = 1; # loaded
        }
        $self->{meta}{$theme}
            = "Acme::MetaSyntactic::$Theme"->new( %{ $self->{args} },
            ( category => $category )x!! $category );
    }

    $self->{meta}{$theme}->name( $count );
}

# other methods
sub themes { wantarray ? ( sort keys %META ) : scalar keys %META }
sub has_theme { $_[1] ? exists $META{$_[1]} : 0 }

1;

__END__