Skip to content

Commit 5bcb9c4

Browse files
tobyinktobyink
authored
Merge pull request #182 from tobyink/feature/argsobject-methods
Handy methods for Type::Params $arg objects
2 parents 64da034 + a3ef6d9 commit 5bcb9c4

File tree

4 files changed

+286
-0
lines changed

4 files changed

+286
-0
lines changed

‎lib/Type/Params.pm‎

Lines changed: 38 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -615,6 +615,44 @@ function as a single parameter object:
615615
say add_numbers( num1 => 2, num2 => 3 ); # says 5
616616
say add_numbers( { num1 => 2, num2 => 3 } ); # also says 5
617617
618+
Since Type::Params 2.009_000 the C<< $arg >> object has methods called
619+
C<< __TO_LIST__ >>, C<< __TO_ARRAYREF__ >>, and C<< __TO_HASHREF__ >>.
620+
621+
signature_for add_numbers => ( named => [ num1 => Num, num2 => Num ] );
622+
sub add_numbers ( $arg ) {
623+
my ( $num1, $num2 ) = $arg->__TO_LIST__;
624+
return $num1 + $num2;
625+
}
626+
627+
signature_for add_numbers => ( named => [ num1 => Num, num2 => Num ] );
628+
sub add_numbers ( $arg ) {
629+
my $nums = $arg->__TO_ARRAYREF__;
630+
return $nums->[0] + $nums->[1];
631+
}
632+
633+
signature_for add_numbers => ( named => [ num1 => Num, num2 => Num ] );
634+
sub add_numbers ( $arg ) {
635+
my $nums = $arg->__TO_HASHREF__;
636+
return $nums->{num1} + $nums->{num2};
637+
}
638+
639+
Each of these can be given an optional arrayref indicating which fields to
640+
return.
641+
642+
signature_for add_numbers => ( named => [ num1 => Num, num2 => Num ] );
643+
sub add_numbers ( $arg ) {
644+
my ( $num2, $num1 ) = $arg->__TO_LIST__( [ qw/ num2 num1 / ] );
645+
return $num1 + $num2;
646+
}
647+
648+
The arrayref accepts aliases (see C<alias>) but methods may throw an
649+
exception if the arrayref contains unknown field names. (See
650+
C<strictness> to control whether an exception is thrown.)
651+
652+
These methods start and end with double underscores to reduce the chance
653+
that they'll conflict with the name of a named parameter, however they are
654+
considered part of the public, supported API.
655+
618656
=head4 C<< named_to_list >> B<< ArrayRef|Bool >>
619657
620658
The C<named_to_list> option is ignored for signatures using positional

‎lib/Type/Params/Signature.pm‎

Lines changed: 82 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1088,6 +1088,8 @@ sub make_class_xs {
10881088
replace => 1,
10891089
%$attr,
10901090
);
1091+
1092+
$self->make_extra_methods;
10911093
}
10921094

10931095
sub make_class_pp {
@@ -1098,6 +1100,8 @@ sub make_class_pp {
10981100
local $@;
10991101
eval( $code ) or die( $@ );
11001102
};
1103+
1104+
$self->make_extra_methods;
11011105
}
11021106

11031107
sub make_class_pp_code {
@@ -1140,6 +1144,84 @@ sub make_class_pp_code {
11401144
return $coderef->code;
11411145
}
11421146

1147+
sub make_extra_methods {
1148+
my $self = shift;
1149+
1150+
my @parameters = @{ $self->parameters };
1151+
if ( $self->has_slurpy ) {
1152+
push @parameters, $self->slurpy;
1153+
}
1154+
1155+
my $coderef = $self->_new_code_accumulator;
1156+
$coderef->add_line( '{' );
1157+
$coderef->{indent} = "\t";
1158+
$coderef->add_line( sprintf( 'package %s;', $self->bless ) );
1159+
$coderef->add_line( 'use strict;' );
1160+
$coderef->add_line( 'no warnings;' );
1161+
1162+
$coderef->add_line( 'my @FIELDS = (' );
1163+
for my $p ( @parameters ) {
1164+
$coderef->add_line( "\t" . B::perlstring( $p->name ) . "," )
1165+
}
1166+
$coderef->add_line( ');' );
1167+
1168+
my @enum;
1169+
$coderef->add_line( 'my %FIELDS = (' );
1170+
for my $p ( @parameters ) {
1171+
$coderef->add_line( "\t" . B::perlstring( $p->name ) . " => " . B::perlstring( $p->name ) . "," );
1172+
for my $p2 ( $p->_all_aliases($self) ) {
1173+
$coderef->add_line( "\t" . B::perlstring( $p2 ) . " => " . B::perlstring( $p->name ) . "," );
1174+
}
1175+
push @enum, $p->name, $p->_all_aliases($self);
1176+
}
1177+
$coderef->add_line( ');' );
1178+
my $enum = ArrayRef[ Enum[ @enum ] ];
1179+
1180+
$coderef->add_line( 'sub __TO_LIST__ {' );
1181+
$coderef->add_line( "\t" . 'my ( $arg, $fields ) = @_;' );
1182+
$coderef->add_line( "\t" . 'return map $arg->{$_}, @FIELDS if not defined $fields;' );
1183+
if ( ( defined $self->strictness and $self->strictness eq 1 ) or not $self->has_strictness ){
1184+
$coderef->add_line( "\t" . $enum->inline_assert( '$fields' ) );
1185+
}
1186+
elsif ( $self->strictness ) {
1187+
$coderef->add_line( "\t" . sprintf( 'if ( %s ) { %s }', $self->strictness, $enum->inline_assert( '$fields' ) ) );
1188+
}
1189+
$coderef->add_line( "\t" . 'return map $arg->{$FIELDS{$_}}, @$fields;' );
1190+
$coderef->add_line( '}' );
1191+
1192+
$coderef->add_line( 'sub __TO_ARRAYREF__ {' );
1193+
$coderef->add_line( "\t" . 'my ( $arg, $fields ) = @_;' );
1194+
$coderef->add_line( "\t" . 'return [ map $arg->{$_}, @FIELDS ] if not defined $fields;' );
1195+
if ( ( defined $self->strictness and $self->strictness eq 1 ) or not $self->has_strictness ){
1196+
$coderef->add_line( "\t" . $enum->inline_assert( '$fields' ) );
1197+
}
1198+
elsif ( $self->strictness ) {
1199+
$coderef->add_line( "\t" . sprintf( 'if ( %s ) { %s }', $self->strictness, $enum->inline_assert( '$fields' ) ) );
1200+
}
1201+
$coderef->add_line( "\t" . 'return [ map $arg->{$FIELDS{$_}}, @$fields ];' );
1202+
$coderef->add_line( '}' );
1203+
1204+
$coderef->add_line( 'sub __TO_HASHREF__ {' );
1205+
$coderef->add_line( "\t" . 'my ( $arg, $fields ) = @_;' );
1206+
$coderef->add_line( "\t" . 'return +{ map { ; $_ => $arg->{$_} } @FIELDS } if not defined $fields;' );
1207+
if ( ( defined $self->strictness and $self->strictness eq 1 ) or not $self->has_strictness ){
1208+
$coderef->add_line( "\t" . $enum->inline_assert( '$fields' ) );
1209+
}
1210+
elsif ( $self->strictness ) {
1211+
$coderef->add_line( "\t" . sprintf( 'if ( %s ) { %s }', $self->strictness, $enum->inline_assert( '$fields' ) ) );
1212+
}
1213+
$coderef->add_line( "\t" . 'return +{ map { ; $_ => $arg->{$FIELDS{$_}} } @$fields };' );
1214+
$coderef->add_line( '}' );
1215+
1216+
$coderef->add_line( '1;' );
1217+
$coderef->{indent} = "";
1218+
$coderef->add_line( '}' );
1219+
1220+
my $code = $coderef->code;
1221+
local $@;
1222+
eval( $code ) or die( $@ );
1223+
}
1224+
11431225
sub return_wanted {
11441226
my $self = shift;
11451227
my $coderef = $self->coderef;

‎lib/Types/Standard.pm‎

Lines changed: 12 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1355,6 +1355,10 @@ length can be given:
13551355
13561356
Other customers also bought: B<< ArrayLike >> from L<Types::TypeTiny>.
13571357
1358+
Notice: future versions of Types::Standard are likely to introduce
1359+
coercions to B<ArrayRef> from B<< HasMethods['__TO_ARRAYREF__'] >> and
1360+
from B<ArrayLike>.
1361+
13581362
=item *
13591363
13601364
B<< HashRef[`a] >>
@@ -1369,6 +1373,10 @@ constrain the hash values.
13691373
13701374
Other customers also bought: B<< HashLike >> from L<Types::TypeTiny>.
13711375
1376+
Notice: future versions of Types::Standard are likely to introduce
1377+
coercions to B<HashRef> from B<< HasMethods['__TO_HASHREF__'] >> and
1378+
from B<HashLike>.
1379+
13721380
=item *
13731381
13741382
B<< CodeRef >>
@@ -1377,6 +1385,10 @@ A value where C<< ref($value) eq "CODE" >>.
13771385
13781386
Other customers also bought: B<< CodeLike >> from L<Types::TypeTiny>.
13791387
1388+
Notice: future versions of Types::Standard are likely to introduce
1389+
coercions to B<CodeRef> from B<< HasMethods['__TO_CODEREF__'] >> and
1390+
from B<CodeLike>.
1391+
13801392
=item *
13811393
13821394
B<< RegexpRef >>

‎t/20-modules/Type-Params/v2-named-methods.t‎

Lines changed: 154 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,154 @@
1+
=pod
2+
3+
=encoding utf-8
4+
5+
=head1 PURPOSE
6+
7+
Named parameter tests for modern Type::Params v2 API.
8+
9+
=head1 AUTHOR
10+
11+
Toby Inkster E<lt>tobyink@cpan.orgE<gt>.
12+
13+
=head1 COPYRIGHT AND LICENCE
14+
15+
This software is copyright (c) 2022-2025 by Toby Inkster.
16+
17+
This is free software; you can redistribute it and/or modify it under
18+
the same terms as the Perl 5 programming language system itself.
19+
20+
=cut
21+
22+
use strict;
23+
use warnings;
24+
25+
use Test::More;
26+
use Test::Fatal;
27+
use Test::TypeTiny;
28+
29+
use Types::Common -all;
30+
31+
our @ARGS;
32+
33+
signature_for [ qw/ get_list get_arrayref get_hashref / ] => (
34+
named => [
35+
foo => Int, { alias => 'fool' },
36+
bar => Optional[Int],
37+
],
38+
);
39+
40+
sub get_list {
41+
shift->__TO_LIST__( @ARGS );
42+
}
43+
44+
subtest '__TO_LIST__' => sub {
45+
46+
is_deeply(
47+
[ get_list( foo => 66, bar => 99 ) ],
48+
[ 66, 99 ],
49+
);
50+
51+
local @ARGS = ( [ qw/ foo foo bar foo / ] );
52+
is_deeply(
53+
[ get_list( foo => 66, bar => 99 ) ],
54+
[ 66, 66, 99, 66 ],
55+
);
56+
57+
local @ARGS = ( [ qw/ foo / ] );
58+
is_deeply(
59+
[ get_list( foo => 66, bar => 99 ) ],
60+
[ 66 ],
61+
);
62+
63+
local @ARGS = ( [ qw/ bar fool / ] );
64+
is_deeply(
65+
[ get_list( foo => 66, bar => 99 ) ],
66+
[ 99, 66 ],
67+
);
68+
69+
local @ARGS = ( [ qw/ BAR / ] );
70+
isnt(
71+
exception { get_list( foo => 66, bar => 99 ) },
72+
undef,
73+
);
74+
};
75+
76+
sub get_arrayref {
77+
shift->__TO_ARRAYREF__( @ARGS );
78+
}
79+
80+
subtest '__TO_ARRAYREF__' => sub {
81+
82+
is_deeply(
83+
get_arrayref( foo => 66, bar => 99 ),
84+
[ 66, 99 ],
85+
);
86+
87+
local @ARGS = ( [ qw/ foo foo bar foo / ] );
88+
is_deeply(
89+
get_arrayref( foo => 66, bar => 99 ),
90+
[ 66, 66, 99, 66 ],
91+
);
92+
93+
local @ARGS = ( [ qw/ foo / ] );
94+
is_deeply(
95+
get_arrayref( foo => 66, bar => 99 ),
96+
[ 66 ],
97+
);
98+
99+
local @ARGS = ( [ qw/ bar fool / ] );
100+
is_deeply(
101+
get_arrayref( foo => 66, bar => 99 ),
102+
[ 99, 66 ],
103+
);
104+
105+
local @ARGS = ( [ qw/ BAR / ] );
106+
isnt(
107+
exception { get_arrayref( foo => 66, bar => 99 ) },
108+
undef,
109+
);
110+
};
111+
112+
sub get_hashref {
113+
shift->__TO_HASHREF__( @ARGS );
114+
}
115+
116+
subtest '__TO_HASHREF__' => sub {
117+
118+
is_deeply(
119+
get_hashref( foo => 66, bar => 99 ),
120+
{ foo => 66, bar => 99 },
121+
);
122+
123+
local @ARGS = ( [ qw/ foo foo bar foo / ] );
124+
is_deeply(
125+
get_hashref( foo => 66, bar => 99 ),
126+
{ foo => 66, bar => 99 },
127+
);
128+
129+
local @ARGS = ( [ qw/ foo / ] );
130+
is_deeply(
131+
get_hashref( foo => 66, bar => 99 ),
132+
{ foo => 66 },
133+
);
134+
135+
local @ARGS = ( [ qw/ bar fool / ] );
136+
is_deeply(
137+
get_hashref( foo => 66, bar => 99 ),
138+
{ fool => 66, bar => 99 },
139+
);
140+
141+
local @ARGS = ( [ qw/ bar fool foo / ] );
142+
is_deeply(
143+
get_hashref( foo => 66, bar => 99 ),
144+
{ foo => 66, fool => 66, bar => 99 },
145+
);
146+
147+
local @ARGS = ( [ qw/ BAR / ] );
148+
isnt(
149+
exception { get_hashref( foo => 66, bar => 99 ) },
150+
undef,
151+
);
152+
};
153+
154+
done_testing;

0 commit comments

Comments
 (0)