The Perl and Raku Conference 2025: Greenville, South Carolina - June 27-29 Learn more

SCHOEJO / Sub-ParamLoader-0.03 / lib / Sub / ParamLoader.pm 

            

              
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
—
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151

              
package Sub::ParamLoader;
use 5.008007;
our $VERSION = 0.01;
use strict;
no strict 'subs';
use Tie::Hash::KeysMask;
sub new
{
    sub splitmask
    {
        my $mask = shift;
        $mask ? (ref($mask) eq 'ARRY' ? @$mask : ($mask)) : ();
    };
    my $class = shift;
    my %arg = @_;
    my $defo = exists $arg{'D'} ? delete $arg{'D'} : [];
    my @M = exists $arg{'M'} ? splitmask delete $arg{'M'} : ();
    bless [[@$defo],[@M]],$class;
}
sub load
{
    my $self = shift;
    my $hr = @{$self->[1]} ? Tie::Hash::KeysMask->newHASH (@{$self->[1]}) : {};
    %$hr = (@{$self->[0]},@_);
    $hr;
}
1;
__END__
=head1 NAME
Sub::ParamLoader
- Map named argument list into a hash modified according to a rule
=head1 SYNOPSIS
    use Sub::ParamLoader;
    my $pl = Sub::ParamLoader -> new ('D'=>[...],'M'=>...);
    #   parameters specify the rule described below
    my $HashObject = $pl->load(...,key=>value,..); # store named items
    # access as usual with hash
    my $v = $HashObject->{key};
    my @V = delete @$HashObject{..,key,..};
=head1 DESCRIPTION
Arguments of the constructor, keyed by 'D','M', are optional.
Giving a closer view they look like
        'D' => [...,Name(i)=>DefVal(i),...]
        'M' => $mask                      where  $mask = sub {...}
        'M' => [ $mask, P(1),...P(m) ]    or           = \&fmask
The arguments and specifications are exactly as in L<Sub::ParamFrame>
by correspondence of operations :
        Sub::ParamFrame          Sub::ParamLoader
        -----------------------------------------------
        pfrule                   new
        pfload                   load
This class provides base functionality for C<Sub::ParamFrame> which only adds
a final improvement step for subroutine arguments.
Regarding methods C<new & load>, as contents overlap, please refer to the
description of C<pfrule & pfload> in L<Sub::ParamFrame>.
Note that in C<Sub::ParamFrame> C<pfrule> calls
C<Sub::ParamLoader-E<gt>new(...)> storing the created object to
C<$register{$subname}>, C<pfload> invokes C<$register{$subname}-E<gt>load>.
=head1 DEPENDENCIES
This module requires these other modules and libraries:
 C<Tie::Hash::KeysMask>
=head1 EXAMPLE
    use Sub::ParamLoader;
    my @DoW = qw(Monday Tuesday Wednesday Thursday Friday Saturday Sunday);
    my %DW2Dic =  ######### Abbreviations mapping #############
    qw(su sunday mo monday tu tuesday we wednesday th thursday fr friday sa saturday);
    my $pl = Sub::ParamLoader->new #============== RULE ============#
    (             #------------------ KEYMASK--'M'------------------#
        'M' =>    # match any prefix-string of a week-day-name with legth
            sub   # not less than 2, ignoring case of characters
            {
                my $ik = shift;                 my $ikl = lc $ik;
                my $ikl2 = substr $ikl,0,2;     my $res = $DW2Dic{$ikl2};
                return undef unless
                ( defined $res)  && ($ikl eq substr($res,0,length $ikl));
                $res;
            },
        'D' => [qw(SUN VII MON I TUE II WED III)] ### DEFAULTS ###
    );
    my $hob = $pl->load qw(We iii Thur iv Fr v  Satur vi Sun vii);
    #        overrides defauts 'wednesday'=>'III','sunday'=>'VII'   #
    sub bar; sub kvTabPrint;  ######## show variants of access #######
    print bar 7;
    kvTabPrint $hob, @DoW;
    kvTabPrint $hob, qw (mo tu we th fr sa su);
    kvTabPrint $hob, qw (MONDY1 TUE WEDNESD THI FRI SAT suN);
    kvTabPrint $hob, qw (Mond TUE We th Fridy1 saturn sUn);
    ###################### output printing matters ####################
    sub lf() {qq(\n)}
    sub bar
    {
        sub seg() {'-'x10}   sub segv() {seg.'+'}
        my $n = (shift)-1;   (segv x $n).seg.lf;
    }
    sub kvTabPrint ######## output a hash arguments-values table #####
    {
        my $href = shift;
        my $kline = join ' |', map sprintf('%9s',$_),@_;
        my $vline = join ' |', map sprintf('%9s',$href->{$_}||'?'),@_;
        print $kline,lf,$vline,lf,bar(scalar @_);
    }
    ###################################################################
=head4 Output of last call of kvTabPrint:
 ---------+----------+----------+----------+----------+----------+----------
     Mond |      TUE |       We |       th |   Fridy1 |   saturn |      sUn
        I |       II |      iii |       iv |        ? |        ? |      vii
 ---------+----------+----------+----------+----------+----------+----------
=head1 AUTHOR
Josef SchE<ouml>nbrunner E<lt>j.schoenbrunner@onemail.atE<gt>
=head1 COPYRIGHT AND LICENSE
Copyright (c) 2005  by Josef SchE<ouml>nbrunner
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.7 or,
at your option, any later version of Perl 5 you may have available.
=cut