← Index
NYTProf Performance Profile   « line view »
For /usr/local/libexec/sympa/task_manager-debug.pl
  Run on Tue Jun 1 22:32:51 2021
Reported on Tue Jun 1 22:35:05 2021

Filename/usr/local/lib/perl5/site_perl/Specio/Constraint/Role/CanType.pm
StatementsExecuted 0 statements in 0s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sSpecio::Constraint::Role::CanType::::BEGIN@10Specio::Constraint::Role::CanType::BEGIN@10
0000s0sSpecio::Constraint::Role::CanType::::BEGIN@12Specio::Constraint::Role::CanType::BEGIN@12
0000s0sSpecio::Constraint::Role::CanType::::BEGIN@14Specio::Constraint::Role::CanType::BEGIN@14
0000s0sSpecio::Constraint::Role::CanType::::BEGIN@3Specio::Constraint::Role::CanType::BEGIN@3
0000s0sSpecio::Constraint::Role::CanType::::BEGIN@4Specio::Constraint::Role::CanType::BEGIN@4
0000s0sSpecio::Constraint::Role::CanType::::BEGIN@8Specio::Constraint::Role::CanType::BEGIN@8
0000s0sSpecio::Constraint::Role::CanType::::BEGIN@9Specio::Constraint::Role::CanType::BEGIN@9
0000s0sSpecio::Constraint::Role::CanType::::CORE:matchSpecio::Constraint::Role::CanType::CORE:match (opcode)
0000s0sSpecio::Constraint::Role::CanType::::CORE:sortSpecio::Constraint::Role::CanType::CORE:sort (opcode)
0000s0sSpecio::Constraint::Role::CanType::::__ANON__Specio::Constraint::Role::CanType::__ANON__ (xsub)
0000s0sSpecio::Constraint::Role::CanType::::__ANON__[:111]Specio::Constraint::Role::CanType::__ANON__[:111]
0000s0sSpecio::Constraint::Role::CanType::::__ANON__[:114]Specio::Constraint::Role::CanType::__ANON__[:114]
0000s0sSpecio::Constraint::Role::CanType::::_attrsSpecio::Constraint::Role::CanType::_attrs
0000s0sSpecio::Constraint::Role::CanType::::_word_listSpecio::Constraint::Role::CanType::_word_list
0000s0sSpecio::Constraint::Role::CanType::::_wrap_message_generatorSpecio::Constraint::Role::CanType::_wrap_message_generator
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1package Specio::Constraint::Role::CanType;
2
3use strict;
4use warnings;
5
6our $VERSION = '0.47';
7
8use Scalar::Util qw( blessed );
9use Specio::PartialDump qw( partial_dump );
10use Storable qw( dclone );
11
12use Role::Tiny;
13
14use Specio::Constraint::Role::Interface;
15with 'Specio::Constraint::Role::Interface';
16
17{
18 ## no critic (Subroutines::ProtectPrivateSubs)
19 my $attrs = dclone( Specio::Constraint::Role::Interface::_attrs() );
20 ## use critic
21
22 for my $name (qw( parent _inline_generator )) {
23 $attrs->{$name}{init_arg} = undef;
24 $attrs->{$name}{builder}
25 = $name =~ /^_/ ? '_build' . $name : '_build_' . $name;
26 }
27
28 $attrs->{methods} = {
29 isa => 'ArrayRef',
30 required => 1,
31 };
32
33 ## no critic (Subroutines::ProhibitUnusedPrivateSubroutines)
34 sub _attrs {
35 return $attrs;
36 }
37}
38
39## no critic (Subroutines::ProhibitUnusedPrivateSubroutines)
40sub _wrap_message_generator {
41 my $self = shift;
42 my $generator = shift;
43
44 my $type = ( split /::/, blessed $self)[-1];
45 my @methods = @{ $self->methods };
46 my $all_word_list = _word_list(@methods);
47 my $allow_classes = $self->_allow_classes;
48
49 unless ( defined $generator ) {
50 $generator = sub {
51 shift;
52 my $value = shift;
53
54 return
55 "An undef will never pass an $type check (wants $all_word_list)"
56 unless defined $value;
57
58 my $class = blessed $value;
59 if ( !defined $class ) {
60
61 # If we got here we know that blessed returned undef, so if
62 # it's a ref then it must not be blessed.
63 if ( ref $value ) {
64 my $dump = partial_dump($value);
65 return
66 "An unblessed reference ($dump) will never pass an $type check (wants $all_word_list)";
67 }
68
69 # If it's defined and not an unblessed ref it must be a
70 # string. If we allow classes (vs just objects) then it might
71 # be a valid class name. But an empty string is never a valid
72 # class name. We cannot call q{}->can.
73 return
74 "An empty string will never pass an $type check (wants $all_word_list)"
75 unless length $value;
76
77 if ( ref \$value eq 'GLOB' ) {
78 return
79 "A glob will never pass an $type check (wants $all_word_list)";
80 }
81
82 if (
83 $value =~ /\A
84 \s*
85 -?[0-9]+(?:\.[0-9]+)?
86 (?:[Ee][\-+]?[0-9]+)?
87 \s*
88 \z/xs
89 ) {
90 return
91 "A number ($value) will never pass an $type check (wants $all_word_list)";
92 }
93
94 $class = $value if $allow_classes;
95
96 # At this point we either have undef or a non-empty string in
97 # $class.
98 unless ( defined $class ) {
99 my $dump = partial_dump($value);
100 return
101 "A plain scalar ($dump) will never pass an $type check (wants $all_word_list)";
102 }
103 }
104
105 my @missing = grep { !$value->can($_) } @methods;
106
107 my $noun = @missing == 1 ? 'method' : 'methods';
108 my $list = _word_list( map {qq['$_']} @missing );
109
110 return "The $class class is missing the $list $noun";
111 };
112 }
113
114 return sub { $generator->( undef, @_ ) };
115}
116## use critic
117
118sub _word_list {
119 my @items = sort { $a cmp $b } @_;
120
121 return $items[0] if @items == 1;
122 return join ' and ', @items if @items == 2;
123
124 my $final = pop @items;
125 my $list = join ', ', @items;
126 $list .= ', and ' . $final;
127
128 return $list;
129}
130
1311;
132
133# ABSTRACT: Provides a common implementation for Specio::Constraint::AnyCan and Specio::Constraint::ObjectCan
134
135__END__