view release on metacpan or  search on metacpan

lib/Acme/MetaSyntactic.pm  view on Meta::CPAN

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 .= $_;
        }
    }