File Coverage

blib/lib/here/declare.pm

Criterion	Covered	Total	%
statement	71	74	95.9
branch	24	38	63.1
condition	12	20	60.0
subroutine	13	13	100.0
pod	0	1	0.0
total	120	146	82.1

package here::declare;
    use warnings;
    use strict;
    use lib '..';
    use here::install;
    BEGIN {*croak = *here::croak}

    our ($name, $value, $glob);

    sub process_pairs {
        my %args = @_;
        exists $args{$_} or croak "needs $_" for qw(validate transform);
        sub (&@) {
            my $to_source = $args{to_source} || shift;
            my $run = sub {
                if (@_ == 1) {
                   (local $value = $_[0])
                        =~ s/^ \s* (\(? [^)=]+ \)?) \s* = \s* (?=\S)//x
                            or croak 'argument must look like: ... = ...';
                    local $name = $1;
                    local $glob = my $error = 'here::declare::error::flag';
                    (my $perl = $to_source->())
                        =~ /$error/ and croak 'not supported with the single argument syntax';
                    return $perl
                }
                if ($_[0] =~ /^\s* \( ([^)=]+) \) \s*$/x) {
                    my $names = $1;
                    my $re = $names =~ /,/ ? qr/,/ : qr/\s+/;
                    splice @_, 0, 1, [grep {s/^\s+|\s+$//; 1} split $re => $names]
                }
                if (ref $_[0] eq 'ARRAY' and @_ > 2 || ref $_[1] ne 'ARRAY') {
                    @_ = ($_[0], [@_[1 .. $#_]])
                }
                if (@_ == 2 and ref $_[0] eq 'ARRAY'
                            and ref $_[1] eq 'ARRAY') {
                    @_ = map {
                        $_[0][$_] => $_[1][$_]
                    } 0 .. $#{$_[0]}
                }
                @_ % 2 and croak 'even length list expected';
                map {
                   (local $name = $_[$_]) =~ s/^-?(\w)/\$$1/;
                    local ($value, $glob) = ($_[$_+1], substr $name, 1);
                    $args{validate}->();
                    $value = $args{transform}->();
                    $to_source->()
                } map 2*$_ => 0 .. $#_/2
            };
            @_ ? &$run : $run
        }
    }

    BEGIN {
        my %valid = (
            '$' => sub {},
            '@' => sub {ref $value eq 'ARRAY' ? () : "an ARRAY ref"},
            '%' => sub {ref $value eq 'HASH'  ? () : "a HASH ref"},
        );
        *lexical = process_pairs
            validate  => sub {
                $name =~ /^(.)/;
                croak "$name must be set with $_"
                    for ($valid{$1} or croak "type not supported: $name")->()
            },
            transform => sub {
                my $code = here::store($value);
                $name =~ /^([\@\%])/ ? $1."{$code}" : $code
            };

        *const = process_pairs
            validate  => sub {
                $name =~ /^\$/ or croak "const sets scalar variables";
                ref $value    and croak "const values can be numbers or strings, not references";
            },
            transform => sub {
                require Data::Dumper;
                Data::Dumper->new([$value])->Terse(1)->Indent(0)->Dump
            };
    }

    my %can = (
        const  => const {"our $name; BEGIN {*$glob = \\$value}"},
        const2 => const {"sub $glob () {$value} our $name; BEGIN {*$glob = \\$glob}"},
    );
    for my $type (qw(my our state)) {
        $can{$type} = lexical {"$type $name; BEGIN {$name = $value}"}
    }

    my %done;
    sub import {
        shift;
        for (@_ ? @_ : keys %can) {
            $can{lc $_} or map {croak "pragma keys: $_; subroutine keys: \U$_"}
                                join ', ' => sort keys %can;
            if (/[A-Z]/) {
                no strict 'refs';
                *{(caller).'::'.$_} = $can{lc $_};
            }
            else {
                $done{$_}++ and next;
                here::install::->import($_ => $can{$_})
            }
        }
    }

    sub unimport {
        shift;
        for (@_ ? @_ : keys %done) {
            delete $done{$_};
            here::install::->unimport($_)
        }
    }

    our $VERSION = '0.03';


=head1 NAME

here::declare - easily declare compile time variables

=head1 VERSION

version 0.03

=head1 SYNOPSIS

    use here::declare;

    use const qw($ONE 1 $TWO 2);

    use my [qw(x y z)] => [$ONE + $TWO, 4, 5];

    use our '@foo' => [$x, $y, $z];

is equivalent to:

    our ($ONE, $TWO);
    BEGIN {
        *ONE = \'1';
        *TWO = \'2';
    }

    my ($x, $y, $z);
    BEGIN {
        ($x, $y, $z) = ($ONE + $TWO, 4, 5);
    }

    our @foo;
    BEGIN {
        @foo = ($x, $y, $z);
    }

without all that tedious typing.

=head1 USE STATEMENTS

all aspects of C< here::declare > must normally be imported using C< use ...; >
statements.

without arguments, an initial C< use here::declare; > line creates all five
pseudo-modules (C< my our state const const2 >).  if you only want some, pass a
list of those.

in the following examples, the C< use my > declaration will be used.  its usage
is equivalent to C< use our > and C< use state >.

=head2 a single argument with C< = >

=over 4

    use my '$x = 1';
    use my '($y, $z) = (2, 3)';

this is the simplest transform, which given an argument matching C< foo = bar >
gets rewritten as:

    my foo; BEGIN {foo = bar}

so the above becomes:

    my $x; BEGIN {$x = 1}
    my ($y, $z); BEGIN {($y, $z) = (2, 3)}

while this version looks the closest to perl's native variable declarations, it
is unable to pass arguments that can not easily be written in a string.

=back

=head2 list of name/value pairs

=over 4

    use my '$say' => sub {print @_, $/};

    use my '@array' => [1, 2, 3], '%hash' => {a => 1, b => 2};

here an arbitrarily long list of name/value pairs is passed to the declarator.

if the name is a C< $scalar > then the corresponding value will be copied into
the newly created variable at compile time.  it is safe to pass any type of
scalar as a value, and it will not be stringified.  C< bareword > and
C< -bareword > names will be interpreted as C< $bareword > which can cut down
on the number of quotes you need to write (C<< use my say => sub {...}; >>)

if the name is an C< @array > or C< %hash > the corresponding values must be
C< ARRAY > or C< HASH > references, which will be dereferenced and copied into
the new variables.

so the above becomes:

    my $say;   BEGIN {$say   =   here::fetch(1)}
    my @array; BEGIN {@array = @{here::fetch(2)}}
    my %hash;  BEGIN {%hash  = %{here::fetch(3)}}

where C< here::fetch > is a subroutine that returns the values passed into the
declarator, which gets around needing to serialize the values.

=back

=head2 [array of names] => list or array of values

=over 4

    use my [qw($x $y $z)] => 1, 2, 3;

    use my [qw($foo @bar %baz)] => ['FOO', [qw(B A R)], {b => 'az'}];

this usage is exactly like the list of name/value pairs usage except the names
and values are passed in separately. the names must be an array reference. the
values can be an array reference or a list.

as a syntactic shortcut, the above two lines could also be written:

    use my '($x, $y, $z)' => 1, 2, 3;

    use my '($foo, @bar, %baz)' => 'FOO', [qw(B A R)], {b => 'az'};

which of course expands to something equivalent to:

    my ($x, $y, $z);
    BEGIN {$x = 1; $y = 2; $z = 3}

    my ($foo, @bar, %baz);
    BEGIN {$foo = 'FOO'; @bar = qw(B A R); %baz = (b => 'az')}

ignoring the complexities of C< here::fetch >

=back

=head2 const and const2

=over 4

    use const '$FOO' => 'BAR';

    use const2 DEBUG => 1;

which expands to:

    our $FOO; BEGIN {*FOO = \'BAR'}

    sub DEBUG () {1} our $DEBUG; BEGIN {*DEBUG = \DEBUG}

these declarations only accept C< $scalar >, C< bareword > or C< -bareword >
names (interchangeably), but otherwise the usage is similar to C< use my ... >

the single argument syntax is not supported with these two declarations.

=back

=head2 cleanup

=over 4

you can remove the pseudo-modules manually:

    no here::declare;

or let the declaration fall out of scope if L is installed:

    {
        use here::declare;
        use my ...; # works
    }
    use my ...; # error

=back

=head1 EXPORT

if you don't like the installation of pseudo-modules, you can pass
C< use here::declare > a list of any of the pseudo-module names each containing
at least one upper case character.  this will cause that name to be exported
into your namespace as a subroutine.

    use here::declare 'MY';

    use here MY [qw($x $y)] => [0, 0];

=head1 SEE ALSO

C< here::declare > is built on top of the L< here > framework.

in writing this module, I was pushed by p5p to make the interface a bit closer
to the native C< my > and C< our > keywords.  I did this with L
in L.  C is certainly closer in usage to the
keywords, but the dependency on C might prevent installation for
some people.  in addition, this module (despite using C) is
a little safer to use than C since the C statement required
by this module more clearly delineates the scope of its actions.

=head1 AUTHOR

Eric Strom, C<<  >>

=head1 BUGS

please report any bugs or feature requests to C, or
through the web interface at L.
I will be notified, and then you'll automatically be notified of progress on
your bug as I make changes.

=head1 LICENSE AND COPYRIGHT

copyright 2011 Eric Strom.

this program is free software; you can redistribute it and/or modify it under
the terms of either: the GNU General Public License as published by the Free
Software Foundation; or the Artistic License.

see http://dev.perl.org/licenses/ for more information.

=cut

1