view release on metacpan or  search on metacpan

lib/Sub/Multi/Tiny.pm  view on Meta::CPAN

        _hlog { "Making $multi_package attr M" } 2;
        eval(_make_M($multi_package));
        die $@ if $@;
    }

    # Set up $subname() in $multi_package, which will be aliased to the
    # dispatcher.
    if(eval { no strict 'refs'; defined &{"$multi_package\::$subname"} }) {
        die "Cannot redefine $subname in $multi_package";
    } else {
        _hlog { "Making $multi_package\::$subname stub" } 2;
        do { no strict 'refs'; *{"$multi_package\::$subname"} = sub {} };
    }
} #import()

# Parse the argument list to the attribute handler
sub _parse_arglist {
    my ($spec, $funcname) = @_;
    _croak "Need a parameter spec for $funcname" unless $spec;
    _hlog { "Parsing args for $funcname: $spec" } 2;

    return Sub::Multi::Tiny::SigParse::Parse($spec);
} #_parse_arglist

# Create the source for the M attribute handler for a given package
sub _make_M {
    my $multi_package = shift;
    my $P = __PACKAGE__;
    my $code = _line_mark_string
        "package $multi_package;\n";

    # TODO See if making M an :ATTR(..., BEGIN) permits us to remove the
    # requirement to list all the parameters in the `use S::M::T` line

    $code .= _line_mark_string <<'EOT';
use Attribute::Handlers;
use Sub::Multi::Tiny::Util qw(_hlog);
##use Data::Dumper;

sub M :ATTR(CODE,RAWDATA) {
    _hlog { require Data::Dumper;
            'In ', __PACKAGE__, "::M: \n",
            Data::Dumper->Dump([\@_], ['attr_args']) } 2;

    my ($package, $symbol, $referent, $attr, $data, $phase,
        $filename, $linenum) = @_;
    my $funcname = "$package\::" . *{$symbol}{NAME};

    _hlog {     # Code from Attribute::Handlers, license perl_5
        ref($referent),
        $funcname,
        "($referent)", "was just declared",
        "and ascribed the ${attr} attribute",
        "with data ($data)",
        "in phase $phase",
        "in file $filename at line $linenum"
    } 2;
EOT

    # Trap out-of-sequence calls.  Currently you can't create a new multisub
    # via eval at runtime.  TODO use UNITCHECK instead to permit doing so?
    $code .= _line_mark_string <<EOT;
    die 'Dispatchers already created - please file a bug report'
        if $P\::_dispatchers_created();

    my \$multi_def = \$_multisubs{'$multi_package'};
EOT

    # Parse and validate the args
    $code .= _line_mark_string <<EOT;
    my \$hrSig = $P\::_parse_arglist(\$data, \$funcname);
    $P\::_check_and_inflate_sig(\$hrSig, \$multi_def,
        \$funcname, \$package, \$filename, \$linenum);
EOT

    $code .= _line_mark_string <<'EOT';
EOT

    # Save the implementation's info for use when making the dispatcher.
    $code .= _line_mark_string <<'EOT';
    my $info = {
        code => $referent,
        args => $hrSig->{parms},    # TODO remove eventually
        sig => $hrSig,

        # For error messages
        filename => $filename,
        linenum => $linenum,
        candidate_name => $funcname
    };
    push @{$multi_def->{impls}}, $info;

} #M
EOT

    _hlog { "M code:\n$code\n" } 2;
    return $code;
} #_make_M

# Validate a signature and convert text to usable objects
sub _check_and_inflate_sig {
    my ($signature, $multi_def, $funcname, $package, $filename, $linenum) = @_;
    my ($saw_positional, $saw_named);

    my $args = $signature->{parms};
    my $temp;
    foreach (@$args) {

        # Is the argument valid in this package?
        my $name = $_->{name};
        unless($multi_def->{possible_params}->{$name}) {
            die "Argument $name is not listed on the 'use Sub::Multi::Tiny' line (used by $funcname at $filename\:$linenum";
        }

        # Is the argument out of order?
        die "Positional arguments must precede named arguments"
            if $saw_named && !$_->{named};

        # Inflate type constraint, if any
        if($_->{type}) {
            _hlog { In => $package, "evaluating type '$_->{type}'" };