Multi-Dispatch
1 match

 view release on metacpan or  search on metacpan

lib/Multi/Dispatch.pm  view on Meta::CPAN 

                                prec      => q{$params->{precedence}},
                                sig       => $params->{sig},
                                level     => '$params->{level}',
                                min       => $params->{min_args},
                                max       => $params->{max_args},
                                ID        => $multi_ID,
                                inception => do { no warnings 'once'; ++\$Multi::Dispatch::inception},
                                code      => $declarator $common { no warnings 'redefine'; $code return sub { local *next::variant; *next::variant = pop; local *__ANON__ = q{$name}; <BODY> } },
                            }, $add_role_variants,
                };
            }
        }

        my $implementation = qq{
            \@{\$Multi::Dispatch::impl{$name}{$target_package}}
                = Multi::Dispatch::_AtoIsort( $existing_variants, $new_variants );
            $update_derived_classes
        };

        my $redispatches = $body =~ /\b next::variant \b/x ? 1 : 0;
        my $dispatcher_code = _build_dispatcher_sub( debug      => $^H{'Multi::Dispatch debug'},
                                                     verbose    => $^H{'Multi::Dispatch verbose'},
                                                     name       => $name,
                                                     keyword    => $keyword,
                                                     as_sub     => $redispatches,
                                                     invocant   => $invocant,
                                                   );

        # Do we need to clone an existing dispatcher sub that was imported from elsewhere???
        my $clone_multi = q{};
        if ($keyword eq 'multi' && !$autofrom) {
            no strict 'refs';
            no warnings 'once';
            my $qualified_name = $caller_package.'::'.$name;
            if (*{$qualified_name}{CODE}) {
                my $info = $Multi::Dispatch::dispatcher_info_for{*{$qualified_name}{CODE}};
                if ($info && $info->{package} ne $caller_package) {
                    $clone_multi = "multi $name :autofrom($info->{package}); BEGIN { no warnings;"
                                 . "\$Multi::Dispatch::closed{'$keyword'}{'$name'}{$target_package}=0;}";
                }
            }
        }

        # Some components are unnecessary under :export...
        my $BEGIN = q{BEGIN};
        my $ISOLATION_TEST = qq{
                if (\$Multi::Dispatch::closed{'$keyword'}{'$name'}{$target_package}) {
                    package Multi::Dispatch::Warning;
                    warn "Isolated variant of $keyword $name()"
                        if warnings::enabled('Multi::Dispatch::noncontiguous');
                }
                else {
                    \$Multi::Dispatch::closed{'$keyword'}{'$name'}{$target_package} = $noncontiguous;
                }
        };
        if ($export) {
            $BEGIN = $ISOLATION_TEST = q{};
        }

        my $annotator = $^H{'Multi::Dispatch annotate'}
                            ? q{ UNITCHECK { Multi::Dispatch::_annotate(__PACKAGE__, __FILE__) } }
                            : q{};

        my $installer = qq{
            $BEGIN {
                no strict 'refs';
                $ISOLATION_TEST
                my \$redefining = $redispatches;
                if (*$target_name {CODE}) {
                    my \$info = \$Multi::Dispatch::dispatcher_info_for{*$target_name {CODE}};
                    if (!\$info) {
                        \$redefining = 1;
                        package Multi::Dispatch::Warning;
                        warn 'Subroutine $name() redefined as $keyword $name()'
                            if warnings::enabled('redefine');
                    }
                    elsif (\$info->{keyword} ne '$keyword') {
                        die qq{Can't declare a \$info->{keyword} and a $keyword of the same name ("$name") in a single package};
                    }
                    elsif (\$info->{package} ne $target_package ) {
                        \$redefining = 1;
                        package Multi::Dispatch::Warning;
                        warn ucfirst "\$info->{keyword} $name() [imported from \$info->{package}] redefined as $keyword $name()"
                            if ('$frommodule' ne \$info->{package})
                            && warnings::enabled('redefine');
                    }
                }
                else {
                    \$redefining = 1;
                }
                if (\$redefining) {
                    no warnings 'redefine';
                    my \$impl = $declarator $common {
                                my \@variants = \@{\$Multi::Dispatch::impl{'$name'}{$target_package}//[]};
                                $dispatcher_code;
                             };
                    *$target_name = \$impl;
                    \$Multi::Dispatch::dispatcher_info_for{\$impl} = {
                        keyword => '$keyword',
                        package => $target_package,
                    };
                }
                $annotator
                $implementation
            }
        } =~ s/\n//gr
          =~ s/<BODY>/_fix_state_vars($body)/egr;

        # Install that code (and adjust the line numbering)...
        ${$src_ref} = $clone_multi . $installer . "\n#line $endline\n" . ${$src_ref};
    };
}

# Export the two new keywords...
sub import {
  my $package = shift;

  if (grep /\A-?debug\Z/, @_)         { $^H{'Multi::Dispatch verbose'}  = 1;
                                        $^H{'Multi::Dispatch debug'}    = 1; }
  if (grep /\A-?verbose\Z/, @_)       { $^H{'Multi::Dispatch verbose'}  = 1; }
  if (grep /\A-?annotate\Z/, @_)      { $^H{'Multi::Dispatch annotate'} = 1; }



( run in 0.856 second using v1.01-cache-2.11-cpan-39bf76dae61 )