File Coverage

File:blib/lib/Simo.pm
Coverage:84.9%

linestmtbrancondsubpodtimecode
1package Simo;
2
12
12
12
0
0
0
use strict;
3
12
12
11
0
0
0
use warnings;
4
11
12
11
0
0
0
use Carp;
5
6our $VERSION = '0.05_05';
7
8sub import{
9
24
0
    my $caller_pkg = caller;
10
11    {
12        # export function
13
11
11
11
24
0
0
0
0
        no strict 'refs';
14
24
24
0
0
        *{ "${caller_pkg}::ac" } = \&Simo::ac;
15
16        # caller inherit Simo
17
24
24
0
0
        push @{ "${caller_pkg}::ISA" }, __PACKAGE__;
18    }
19
20    # auto strict and warnings
21
24
0
    strict->import;
22
24
0
    warnings->import;
23}
24
25sub new{
26
26
1
0
    my ( $proto, @args ) = @_;
27
28    # check args
29
26
1
0
0
    @args = %{ $args[0] } if ref $args[0] eq 'HASH';
30
26
0
    croak 'key-value pairs must be passed to new method' if @args % 2;
31
32    # bless
33
25
0
    my $self = {};
34
25
10000
    my $pkg = ref $proto || $proto;
35
25
0
    bless $self, $pkg;
36
37    # set args
38
25
0
    while( my ( $attr, $val ) = splice( @args, 0, 2 ) ){
39
8
0
        croak "Invalid key '$attr' is passed to ${pkg}::new" unless $self->can( $attr );
40
11
11
11
10000
0
0
        no strict 'refs';
41
7
0
        $self->$attr( $val );
42    }
43
24
0
    return $self;
44}
45
46# accessor option
47our $AC_OPT = {};
48our %VALID_AC_OPT = map{ $_ => 1 } qw( default constrain filter trigger set_hook get_hook hash_force read_only );
49
50# create accessor
51sub ac(@){
52    # Simo process
53
40
1
20001
    my ( $self, $attr, @vals ) = _SIMO_process( @_ );
54
55    # call accessor
56
36
0
    $self->$attr( @vals );
57}
58
59# Simo process. register accessor option and create accessor.
60sub _SIMO_process{
61    # accessor info
62
40
0
    my ( $self, $attr, $pkg, @vals ) = _SIMO_get_ac_info();
63
64    # check and rearrange accessor option;
65
40
10001
    my $ac_opt = {};
66
67
40
0
    $ac_opt->{ default } = shift if @_ % 2;
68
40
0
    my $hook_options_exist = {};
69
70
40
0
    while( my( $key, $val ) = splice( @_, 0, 2 ) ){
71
36
0
        croak "$key of ${pkg}::$attr is invalid accessor option"
72            unless $VALID_AC_OPT{ $key };
73
74
35
0
        carp "${pkg}::$attr : $@"
75            unless _SIMO_check_hook_options_order( $key, $hook_options_exist );
76
77
35
0
        $ac_opt->{ $key } = $val;
78    }
79
80    # register accessor option
81
39
0
    $AC_OPT->{ $pkg }{ $attr } = $ac_opt;
82
83    # create accessor
84    {
85
11
11
11
39
0
0
0
0
        no warnings 'redefine';
86
39
0
        my $code = _SIMO_create_accessor( $pkg, $attr );
87
36
5
5
5
2
2
3
9
9
5
9
9
5
4
8
3
3
3
2
2
1
1
0
1
1
1
0
2
2
3
2
2
3
2
2
1
2
2
3
3
1
3
3
1
2
1
1
1
3
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
0
0
2
2
2
1
1
2
2
2
2
23
23
21
14
14
15
8
16
9
5
5
9
3
2
2
2
1
1
1
1
1
2
2
2
2
2
2
2
2
2
1
1
1
2
2
0
2
2
1
1
2
2
2
2
1
1
1
1
1
1
2
2
2
2
1
1
1
1
1
1
2
1
1
1
1
1
2
2
2
2
2
2
2
2
1
1
1
1
1
1
1
1
0
0
1
2
2
2
1
1
1
1
1
1
2
2
2
2
1
1
1
1
2
2
2
2
2
2
2
2
2
4
4
3
1
1
2
2
2
1
1
1
2
2
1
2
20000
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
10000
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
0
        eval"sub ${pkg}::${attr} $code";
88    }
89
36
0
    return ( $self, $attr, @vals );
90}
91
92# check hook option order ( constrain, filter, and trigger )
93our %VALID_HOOK_OPT = ( constrain => 1, filter => 2, trigger => 3 );
94
95sub _SIMO_check_hook_options_order{
96
35
0
    my ( $key, $hook_options_exist ) = @_;
97
98
35
0
    return 1 unless $VALID_HOOK_OPT{ $key };
99
100
23
23
0
0
    foreach my $hook_option_exist ( keys %{ $hook_options_exist } ){
101
6
0
        if( $VALID_HOOK_OPT{ $key } < $VALID_HOOK_OPT{ $hook_option_exist } ){
102
3
0
            $@ = "$key option should be appear before $hook_option_exist option";
103
3
0
            return 0;
104        }
105    }
106
20
0
    $hook_options_exist->{ $key } = 1;
107
20
0
    return 1;
108}
109
110# create accessor.
111sub _SIMO_create_accessor{
112
39
0
    my ( $pkg, $attr ) = @_;
113
114
39
0
    my $read_only = $AC_OPT->{ $pkg }{ $attr }{ read_only };
115
116
39
0
    if( $read_only ){
117
2
0
        my $attr_org = $attr;
118
2
0
        if( $attr =~ s/get_// ){
119
1
0
            $AC_OPT->{ $pkg }{ $attr } = delete $AC_OPT->{ $pkg }{ $attr_org }
120        }
121        else{
122
1
0
            Carp::carp( "Read only method should be contain 'get_' in accessor name" )
123        }
124    }
125
126
39
0
    my $e =
127        qq/{\n/ .
128        # arg recieve
129        qq/ my ( \$self, \@vals ) = \@_;\n\n/;
130
131
39
10001
    if( defined $AC_OPT->{ $pkg }{ $attr }{ default } ){
132        # default value
133
13
0
        $e .=
134        qq/ if( ! exists( \$self->{ $attr } ) ){\n/ .
135        qq/ \$self->{ $attr } = \$AC_OPT->{ $pkg }{ $attr }{ default };\n/ .
136        qq/ }\n/ .
137        qq/ \n/;
138    }
139
140    # get value
141    $e .=
142
39
0
        qq/ my \$ret = \$self->{ $attr };\n\n/;
143
144
145    # read only
146
39
2
0
0
    if( $read_only ){ goto END_SET_PROCESS }
147
148    $e .=
149
37
0
        qq/ if( \@vals ){\n/ .
150
151    # rearrange value
152        qq/ my \$val = \@vals == 1 ? \$vals[0] :\n/;
153    $e .= $AC_OPT->{ $pkg }{ $attr }{ hash_force } ?
154
37
0
        qq/ \@vals >= 2 ? { \@vals } :\n/ :
155        qq/ \@vals >= 2 ? [ \@vals ] :\n/;
156
37
0
    $e .=
157        qq/ undef;\n\n/;
158
159
37
0
    if( defined $AC_OPT->{ $pkg }{ $attr }{ set_hook } ){
160        # set_hook option
161
2
0
        $e .=
162        qq/ eval{ \$val = \$AC_OPT->{ $pkg }{ $attr }{ set_hook }->( \$self, \$val ) };\n/ .
163        qq/ Carp::confess( \$@ ) if \$@;\n\n/;
164    }
165
166
37
0
    if( defined $AC_OPT->{ $pkg }{ $attr }{ constrain } ){
167        # constrain option
168
169        $AC_OPT->{ $pkg }{ $attr }{ constrain } = [ $AC_OPT->{ $pkg }{ $attr }{ constrain } ]
170
9
0
            unless ref $AC_OPT->{ $pkg }{ $attr }{ constrain } eq 'ARRAY';
171
172
9
9
0
0
        foreach my $constrain ( @{ $AC_OPT->{ $pkg }{ $attr }{ constrain } } ){
173
10
0
            Carp::croak( "constrain of ${pkg}::$attr must be code ref" )
174                unless ref $constrain eq 'CODE';
175        }
176
177        $e .=
178
8
0
        qq/ foreach my \$constrain ( \@{ \$AC_OPT->{ $pkg }{ $attr }{ constrain } } ){\n/ .
179        qq/ local \$_ = \$val;\n/ .
180        qq/ my \$ret = \$constrain->( \$val );\n/ .
181        qq/ Carp::croak( "Illegal value \$val is passed to ${pkg}::$attr" )\n/ .
182        qq/ unless \$ret;\n/ .
183        qq/ }\n\n/;
184    }
185
186
36
0
    if( defined $AC_OPT->{ $pkg }{ $attr }{ filter } ){
187        # filter option
188        $AC_OPT->{ $pkg }{ $attr }{ filter } = [ $AC_OPT->{ $pkg }{ $attr }{ filter } ]
189
7
0
            unless ref $AC_OPT->{ $pkg }{ $attr }{ filter } eq 'ARRAY';
190
191
7
7
0
0
        foreach my $filter ( @{ $AC_OPT->{ $pkg }{ $attr }{ filter } } ){
192
8
0
            Carp::croak( "filter of ${pkg}::$attr must be code ref" )
193                unless ref $filter eq 'CODE';
194        }
195
196        $e .=
197
6
0
        qq/ foreach my \$filter ( \@{ \$AC_OPT->{ $pkg }{ $attr }{ filter } } ){\n/ .
198        qq/ local \$_ = \$val;\n/ .
199        qq/ \$val = \$filter->( \$val );\n/ .
200        qq/ }\n\n/;
201    }
202
203    # set value
204    $e .=
205
35
0
        qq/ \$self->{ $attr } = \$val;\n\n/;
206
207
35
0
    if( defined $AC_OPT->{ $pkg }{ $attr }{ trigger } ){
208        $AC_OPT->{ $pkg }{ $attr }{ trigger } = [ $AC_OPT->{ $pkg }{ $attr }{ trigger } ]
209
7
0
            unless ref $AC_OPT->{ $pkg }{ $attr }{ trigger } eq 'ARRAY';
210
211
7
7
0
0
        foreach my $trigger ( @{ $AC_OPT->{ $pkg }{ $attr }{ trigger } } ){
212
8
0
            Carp::croak( "trigger of ${pkg}::$attr must be code ref" )
213                unless ref $trigger eq 'CODE';
214        }
215
216        # trigger option
217        $e .=
218
6
0
        qq/ foreach my \$trigger ( \@{ \$AC_OPT->{ $pkg }{ $attr }{ trigger } } ){\n/ .
219        qq/ local \$_ = \$self;\n/ .
220        qq/ \$trigger->( \$self );\n/ .
221        qq/ }\n/;
222    }
223
224    $e .=
225
34
0
        qq/ }\n/;
226
227    END_SET_PROCESS:
228
229
36
0
    if( defined $AC_OPT->{ $pkg }{ $attr }{ get_hook } ){
230        # get_hook option
231
2
0
        $e .=
232        qq/ eval{ \$ret = \$AC_OPT->{ $pkg }{ $attr }{ get_hook }->( \$self, \$ret ) };\n/ .
233        qq/ Carp::confess( \$@ ) if \$@;\n/;
234    }
235
236    #return
237    $e .=
238
36
0
        qq/ return \$ret;\n/ .
239        qq/}\n/;
240
241
36
0
    return $e;
242}
243
244# Helper to get acsessor info;
245sub _SIMO_get_ac_info {
246    package DB;
247
40
0
    my @caller = caller 3;
248
249
40
0
    my ( $self, @vals ) = @DB::args;
250
40
0
    my $sub = $caller[ 3 ];
251
40
0
    my ( $pkg, $attr ) = $sub =~ /^(.*)::(.+)$/;
252
253
40
0
    return ( $self, $attr, $pkg, @vals );
254}
255
256 - 264
=head1 NAME

Simo - Very simple framework for Object Oriented Perl.

=head1 VERSION

Version 0.05_05

=cut
265
266 - 287
=head1 FEATURES

Simo is framework that simplify Object Oriented Perl.

The feature is that

=over 4

=item 1. You can define accessors in very simple way.

=item 2. Overridable new method is prepared.

=item 3. You can define default value of attribute.

=item 4. Simo is very small. so You can install and excute it very fast.

=back

If you use Simo, you are free from bitter work 
writing new and accessors repeatedly.

=cut
288
289 - 322
=head1 SYNOPSIS

=head2 Define class and accessors.

    package Book;
    use Simo;
    
    # define accessors
    sub title{ ac }
    
    # define default value
    sub author{ ac default => 'Kimoto' }
    
    # define constrain subroutine
    sub price{ ac constrain => sub{ /^\d+$/ } } # price must be integer.

    # define filter subroutine
    sub description{ ac filter => sub{ uc } } # convert to upper case.

    # define trigger subroutine
    sub issue_datetime{ ac trigger => \&update_issue_date }
    sub issue_date{ ac } # if issue_datetime is updated, issue_date is updated.
    
    sub update_issue_date{
        my $self = shift;
        my $date = substr( $self->issue_datetime, 0, 10 );
        $self->issue_date( $date );
    }
    
    # read only accessor
    sub get_size{ ac default => 5, read_only => 1 }
    
    1;
=cut
323
324 - 352
=head2 Using class and accessors

    use strict;
    use warnings;
    use Book;

    # create object
    my $book = Book->new( title => 'OO tutorial' );

    # get attribute
    my $author = $book->author;

    # set attribute
    $book->author( 'Ken' );

    # constrain( If try to set illegal value, this call will die )
    $book->price( 'a' ); 

    # filter ( convert to 'IT IS USEFUL' )
    $book->description( 'It is useful' );

    # trigger( issue_date is updated '2009-01-01' )
    $book->issue_datetime( '2009-01-01 12:33:45' );
    my $issue_date = $book->issue_date;
    
    # read only accessor
    $book->get_size;

=cut
353
354 - 368
=head1 DESCRIPTION

=head2 Define class and accessors

You can define class and accessors in simple way.

new method is automatically created, and title accessor is defined.

    package Book;
    use Simo;

    sub title{ ac }
    1;

=cut
369
370 - 387
=head2 Using class and accessors

You can pass key-value pairs to new, and can get and set value.

    use Book;
    
    # create object
    my $book = Book->new(
        title => 'OO tutorial',
    );
    
    # get value
    my $title = $book->title;
    
    # set value
    $book->title( 'The simplest OO' );

=cut
388
389 - 396
=head2 Automatically array convert

If you pass array to accessor, array convert to array ref.

    $book->title( 'a', 'b' );
    $book->title; # get [ 'a', 'b' ], not ( 'a', 'b' )

=cut
397
398 - 406
=head2 Accessor options

=head3 default option

You can define default value of attribute.

    sub title{ ac default => 'Perl is very interesting' }

=cut
407
408 - 440
=head3 constrain option

you can constrain setting value.

    sub price{ ac constrain => sub{ /^\d+$/ } }

For example, If you call $book->price( 'a' ), this call is die, because 'a' is not number.

'a' is set to $_. so if you can use regular expression, omit $_.

you can write not omiting $_.

    sub price{ ac constrain => sub{ $_ > 0 && $_ < 3 } }

If you display your message when program is die, you call craok.
    
    use Carp;
    sub price{ ac constrain => sub{ $_ > 0 && $_ < 3 or croak "Illegal value" } }

and 'a' is alse set to first argument. So you can receive 'a' as first argument.

   sub price{ ac constrain => \&_is_number }
   
   sub _is_number{
       my $val = shift;
       return $val =~ /^\d+$/;
   }

and you can define more than one constrain.

    sub price{ ac constrain => [ \&_is_number, \&_is_non_zero ] }

=cut
441
442 - 454
=head3 filter option

you can filter setting value.

    sub description{ ac filter => sub{ uc } }

setting value is $_ and frist argument like constrain.

and you can define more than one filter.

    sub description{ ac filter => [ \&uc, \&quoute ] }

=cut
455
456 - 477
=head3 trigger option

You can define subroutine called after value is set.

For example, issue_datetime is set, issue_date is update.

$self is set to $_ and $_[0] different from constrain and filter.

    sub issue_datetime{ ac trigger => \&update_issue_date }
    sub issue_date{ ac }
    
    sub update_issue_date{
        my $self = shift;
        my $date = substr( $self->issue_datetime, 0, 10 );
        $self->issue_date( $date );
    }

and you can define more than one trigger.

    sub issue_datetime{ ac trigger => [ \&update_issue_date, \&update_issue_time ] }

=cut
478
479 - 503
=head3 read_only option

Read only accessor is defined

    sub get_size{ ac default => 5, read_only => 1 }

Accessor name should be contain 'get_'. If not, warning is happen.

=head3 hash_force option

If you pass array to accessor, Normally list convert to array ref.
    $book->title( 'a' , 'b' ); # convert to [ 'a', 'b' ]

Even if you write
    $book->title( a => 'b' )

( a => 'b' ) converted to [ 'a', 'b' ] 

If you use hash_force option, you convert list to hash ref

    sub country_id{ ac hash_force => 1 }

    $book->title( a => 'b' ); # convert to { a => 'b' }

=cut
504
505 - 509
=head3 set_hook option

set_hook option is now not recommended. this option will be deleted in future 2019/01/01

=cut
510
511 - 515
=head3 get_hook option

get_hook option is now not recommended. this option will be deleted in future 2019/01/01

=cut
516
517 - 537
=head2 Order of constrain, filter and trigger

=over 4

=item 1. val is passed to constrain subroutine.

=item 2. val is passed to filter subroutine.

=item 3. val is set

=item 4. trigger subroutine is called

=back

       |---------|   |------|                  |-------| 
       |         |   |      |                  |       | 
 val-->|constrain|-->|filter|-->(val is set)-->|trigger| 
       |         |   |      |                  |       | 
       |---------|   |------|                  |-------| 

=cut
538
539 - 546
=head2 Get old value

You can get old value when you use accessor as setter.

    $book->author( 'Ken' );
    my $old_value = $book->author( 'Taro' ); # $old_value is 'Ken'

=cut
547
548 - 554
=head1 FUNCTIONS

=head2 ac

ac is exported. This is used by define accessor. 

=cut
555
556 - 560
=head2 new

orveridable new method.

=cut
561
562
563 - 597
=head1 MORE TECHNIQUES

I teach you useful techniques.

=head2 New method overriding

by default, new method receive key-value pairs.
But you can change this action by overriding new method.

For example, Point class. You want to call new method this way.

    my $point = Point->new( 3, 5 ); # xPos and yPos

You can override new method.
    
    package Point;
    use Simo;

    sub new{
        my ( $self, $x, $y ) = @_; # two arg( not key-value pairs )
        
        # You can do anything if you need
        
        return $self->SUPER::new( x => $x, y => $y );
    }

    sub x{ ac }
    sub y{ ac }
    1;

Simo implement inheritable new method.
Whenever You change argments or add initializetion,
You override new method.

=cut
598
599 - 637
=head2 Extend base class

you may want to extend base class. It is OK.

But I should say to you that there are one thing you should know.
The order of Inheritance is very important.

I write good sample and bad sample.

    # base class
    package Book;
    sub title{ ac };
    
    # Good sample.
    # inherit base class. It is OK!
    package Magazine;
    use base 'Book'; # use base is first
    use Simo;        # use Simo is second;
    
    # Bad sample
    package Magazine;
    use Simo;          # use Simo is first
    use base 'Book';   # use base is second

If you call new method in Good sample, you call Book::new method.
This is what you wanto to do.

If you call new method in Bad sample, you call Simo::new method. 
you will think why Book::new method is not called?

Maybe, You will be wrong sometime. So I recomend you the following writing.

    package Magazine; use base 'Book'; # package and base class
    use Simo;                          

It is like other language class Definition and I think looking is not bat.
and you are not likely to choose wrong order.

=cut
638
639 - 647
=head1 CAUTION

set_hook and get_hook option is now not recomended. these option will be deleted in future 2019/01/01

and non named defalut value definition is not recommended. this expression cannot be available in future 2019/01/01

    sub title{ ac 'OO tutorial' } # not recommend. cannot be available in future.

=cut
648
649 - 701
=head1 AUTHOR

Yuki Kimoto, C<< <kimoto.yuki at gmail.com> >>

=head1 BUGS

Please report any bugs or feature requests to C<bug-simo at rt.cpan.org>, or through
the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Simo>.  I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Simo


You can also look for information at:

=over 4

=item * RT: CPAN's request tracker

L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Simo>

=item * AnnoCPAN: Annotated CPAN documentation

L<http://annocpan.org/dist/Simo>

=item * CPAN Ratings

L<http://cpanratings.perl.org/d/Simo>

=item * Search CPAN

L<http://search.cpan.org/dist/Simo/>

=back


=head1 SEE ALSO

L<Class::Accessor>,L<Class::Accessor::Fast>, L<Moose>, L<Mouse>.

=head1 COPYRIGHT & LICENSE

Copyright 2008 Yuki Kimoto, all rights reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.


=cut
702
7031; # End of Simo