File Coverage

blib/lib/Data/Sah/Util/Role.pm
Criterion Covered Total %
statement 120 128 93.7
branch 7 22 31.8
condition 8 18 44.4
subroutine 49 53 92.4
pod 4 26 15.3
total 188 247 76.1


line stmt bran cond sub pod time code
1              
2             use 5.010;
3 35     35   445 use strict 'subs', 'vars';
  35         197  
4 35     31   497 use warnings;
  31         79  
  31         653  
5 31     28   162 #use Log::Any '$log';
  28         125  
  28         19973  
6              
7             require Exporter;
8              
9             our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
10             our $DATE = '2022-08-20'; # DATE
11             our $DIST = 'Data-Sah'; # DIST
12             our $VERSION = '0.912'; # VERSION
13              
14             our @ISA = qw(Exporter);
15             our @EXPORT_OK = qw(
16             has_clause has_clause_alias
17             has_func has_func_alias
18             );
19              
20             my ($name, %args) = @_;
21             my $caller = caller;
22 881     881 1 2780 my $into = $args{into} // $caller;
23 881         1337  
24 881   33     2982 my $v = $args{v} // 1;
25             if ($v != 2) {
26 881   50     1425 die "Declaration of clause '$name' still follows version $v ".
27 881 50       1431 "(2 expected), please make sure $caller is the latest version";
28 0         0 }
29              
30             if ($args{code}) {
31             *{"$into\::clause_$name"} = $args{code};
32 881 100       1344 } else {
33 289         309 eval "package $into; use Role::Tiny; ". ## no critic: BuiltinFunctions::ProhibitStringyEval
  289         1371  
34             "requires 'clause_$name';";
35 28     28   165 }
  28     28   68  
  28     28   90  
  28     28   162  
  28     27   85  
  28     27   148  
  28     27   212  
  28     27   904  
  28     27   113  
  28     27   156  
  28     27   77  
  28     27   102  
  28     27   148  
  27     27   688  
  27     27   105  
  27     27   141  
  27     27   57  
  27     27   111  
  27     24   148  
  27     24   62  
  27     17   86  
  27     15   146  
  27     36   73  
  27     12   96  
  27     12   145  
  27     46   58  
  27     18   110  
  27     30   135  
  27     30   94  
  27     24   87  
  27     60   138  
  27     0   58  
  27     0   1012  
  27     72   154  
  27     72   56  
  27     24   83  
  27     24   149  
  27     52   64  
  27     76   85  
  27     60   144  
  27     60   58  
  27     48   88  
  27     120   178  
  27         77  
  27         85  
  27         146  
  27         57  
  27         86  
  27         141  
  27         67  
  27         96  
  27         149  
  27         57  
  27         95  
  27         143  
  24         49  
  24         795  
  24         135  
  24         48  
  24         88  
  17         104  
  17         28  
  17         59  
  15         99  
  15         25  
  15         62  
  592         35456  
36             *{"$into\::clausemeta_$name"} = sub {
37             state $meta = {
38 881         8854 names => [$name],
39             tags => $args{tags},
40             prio => $args{prio} // 50,
41             schema => $args{schema},
42             allow_expr => $args{allow_expr},
43             attrs => $args{attrs} // {},
44             inspect_elem => $args{inspect_elem},
45             subschema => $args{subschema},
46             };
47             $meta;
48 22872   100 22872   39584 };
      100 22580      
49 22872         46675 has_clause_alias($name, $args{alias} , $into);
50 881         7936 has_clause_alias($name, $args{aliases}, $into);
51 881         2865 }
52 881         2189  
53             my ($name, $aliases, $into) = @_;
54             my $caller = caller;
55             $into //= $caller;
56 1803     1803 1 3809 my @aliases = !$aliases ? () :
57 1803         2513 ref($aliases) eq 'ARRAY' ? @$aliases : $aliases;
58 1803   66     4250 my $meta = $into->${\("clausemeta_$name")};
59 1803 50       2868  
    100          
60             for my $alias (@aliases) {
61 1803         1891 push @{ $meta->{names} }, $alias;
  1803         5028  
62             eval ## no critic: BuiltinFunctions::ProhibitStringyEval
63 1803         4160 "package $into;".
64 41         49 "sub clause_$alias { shift->clause_$name(\@_) } ".
  41         90  
65             "sub clausemeta_$alias { shift->clausemeta_$name(\@_) } ";
66 41       0 2668 $@ and die "Can't make clause alias $alias -> $name: $@";
          0    
          0    
          0    
          0    
          0    
          0    
          0    
          0    
          0    
          0    
          0    
          0    
          0    
          0    
          0    
          0    
          0    
          0    
          0    
          0    
          0    
67             }
68             }
69 41 50       231  
70             my ($name, %args) = @_;
71             my $caller = caller;
72             my $into = $args{into} // $caller;
73              
74 0     0 1 0 if ($args{code}) {
75 0         0 *{"$into\::func_$name"} = $args{code};
76 36   0     157 } else {
77             eval "package $into; use Role::Tiny; requires 'func_$name';"; ## no critic: BuiltinFunctions::ProhibitStringyEval
78 36 0       158 }
79 12         43 *{"$into\::funcmeta_$name"} = sub {
  12         46  
80             state $meta = {
81 46         175 names => [$name],
82             args => $args{args},
83 30         121 };
84             $meta;
85             };
86             my @aliases =
87 30     0   118 map { (!$args{$_} ? () :
88 24         105 ref($args{$_}) eq 'ARRAY' ? @{ $args{$_} } : $args{$_}) }
89 18         74 qw/alias aliases/;
90             has_func_alias($name, $args{alias} , $into);
91 60         255 has_func_alias($name, $args{aliases}, $into);
92 0 0       0 }
  0 0       0  
93              
94 72         296 my ($name, $aliases, $into) = @_;
95 72         285 my $caller = caller;
96             $into //= $caller;
97             my @aliases = !$aliases ? () :
98             ref($aliases) eq 'ARRAY' ? @$aliases : $aliases;
99 24     36 1 95 my $meta = $into->${\("funcmeta_$name")};
100 24         98  
101 52   0     200 for my $alias (@aliases) {
102 76 0       289 push @{ $meta->{names} }, $alias;
    0          
103             eval ## no critic: BuiltinFunctions::ProhibitStringyEval
104 60         248 "package $into;".
  60         233  
105             "sub func_$alias { shift->func_$name(\@_) } ".
106 48         193 "sub funcmeta_$alias { shift->funcmeta_$name(\@_) } ";
107 120         498 $@ and die "Can't make func alias $alias -> $name: $@";
  0            
108             }
109 0           }
110              
111             1;
112 0 0         # ABSTRACT: Sah utility routines for roles
113              
114              
115             =pod
116              
117             =encoding UTF-8
118              
119             =head1 NAME
120              
121             Data::Sah::Util::Role - Sah utility routines for roles
122              
123             =head1 VERSION
124              
125             This document describes version 0.912 of Data::Sah::Util::Role (from Perl distribution Data-Sah), released on 2022-08-20.
126              
127             =head1 DESCRIPTION
128              
129             This module provides some utility routines to be used in roles, e.g.
130             C<Data::Sah::Type::*> and C<Data::Sah::FuncSet::*>.
131              
132             =head1 FUNCTIONS
133              
134             =head2 has_clause($name, %opts)
135              
136             Define a clause. Used in type roles (C<Data::Sah::Type::*>). Internally it adds
137             a L<Moo> C<requires> for C<clause_$name>.
138              
139             Options:
140              
141             =over 4
142              
143             =item * v => int
144              
145             Specify clause specification version. Must be 2 (the current version).
146              
147             =item * schema => sah::schema
148              
149             Define schema for clause value.
150              
151             =item * prio => int {min=>0, max=>100, default=>50}
152              
153             Optional. Default is 50. The higher the priority (the lower the number), the
154             earlier the clause will be processed.
155              
156             =item * aliases => \@aliases OR $alias
157              
158             Define aliases. Optional.
159              
160             =item * inspect_elem => bool
161              
162             If set to true, then this means clause inspect the element(s) of the data. This
163             is only relevant for types that has elements (see L<HasElems
164             role|Data::Sah::Type::HasElems>). An example of clause like this is C<has> or
165             C<each_elem>. When the value of C<inspect_elem> is true, a compiler must prepare
166             by coercing the elements of the data, if there are coercion rules applicable.
167              
168             =item * subschema => coderef
169              
170             If set, then declare that the clause value contains a subschema. The coderef
171             must provide a way to get the subschema from
172              
173             =item * code => coderef
174              
175             Optional. Define implementation for the clause. The code will be installed as
176             'clause_$name'.
177              
178             =item * into => str $package
179              
180             By default it is the caller package, but can be set to other package.
181              
182             =back
183              
184             Example:
185              
186             has_clause minimum => (arg => 'int*', aliases => 'min');
187              
188             =head2 has_clause_alias TARGET => ALIAS | [ALIAS1, ...]
189              
190             Specify that clause named ALIAS is an alias for TARGET.
191              
192             You have to define TARGET clause first (see B<has_clause> above).
193              
194             Example:
195              
196             has_clause max_length => ...;
197             has_clause_alias max_length => "max_len";
198              
199             =head2 has_func($name, %opts)
200              
201             Define a Sah function. Used in function set roles (C<Data::Sah::FuncSet::*>).
202             Internally it adds a L<Moo> C<requires> for C<func_$name>.
203              
204             Options:
205              
206             =over 4
207              
208             =item * aliases => \@aliases OR $alias
209              
210             Optional. Declare aliases.
211              
212             =item * code => $code
213              
214             Supply implementation for the function. The code will be installed as
215             'func_$name'.
216              
217             =item * into => $package
218              
219             By default it is the caller package, but can be set to other package.
220              
221             =back
222              
223             Example:
224              
225             has_func abs => (args => 'num');
226              
227             =head2 has_func_alias TARGET => ALIAS | [ALIASES...]
228              
229             Specify that function named ALIAS is an alias for TARGET.
230              
231             You have to specify TARGET function first (see B<has_func> above).
232              
233             Example:
234              
235             has_func_alias 'atan' => 'arctan';
236              
237             =head1 HOMEPAGE
238              
239             Please visit the project's homepage at L<https://metacpan.org/release/Data-Sah>.
240              
241             =head1 SOURCE
242              
243             Source repository is at L<https://github.com/perlancar/perl-Data-Sah>.
244              
245             =head1 AUTHOR
246              
247             perlancar <perlancar@cpan.org>
248              
249             =head1 CONTRIBUTING
250              
251              
252             To contribute, you can send patches by email/via RT, or send pull requests on
253             GitHub.
254              
255             Most of the time, you don't need to build the distribution yourself. You can
256             simply modify the code, then test via:
257              
258             % prove -l
259              
260             If you want to build the distribution (e.g. to try to install it locally on your
261             system), you can install L<Dist::Zilla>,
262             L<Dist::Zilla::PluginBundle::Author::PERLANCAR>,
263             L<Pod::Weaver::PluginBundle::Author::PERLANCAR>, and sometimes one or two other
264             Dist::Zilla- and/or Pod::Weaver plugins. Any additional steps required beyond
265             that are considered a bug and can be reported to me.
266              
267             =head1 COPYRIGHT AND LICENSE
268              
269             This software is copyright (c) 2022, 2021, 2020, 2019, 2018, 2017, 2016, 2015, 2014, 2013, 2012 by perlancar <perlancar@cpan.org>.
270              
271             This is free software; you can redistribute it and/or modify it under
272             the same terms as the Perl 5 programming language system itself.
273              
274             =head1 BUGS
275              
276             Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-Sah>
277              
278             When submitting a bug or request, please include a test-file or a
279             patch to an existing test-file that illustrates the bug or desired
280             feature.
281              
282             =cut