1package WebDAO::Base;
2our $VERSION = '0.02';
3
4=head1 NAME
5
6WebDAO::Base - Base class
7
8=head1 SYNOPSIS
9
10=head1 DESCRIPTION
11
12WebDAO::Base - Base class
13
14=cut
15
16use Carp;
17use warnings;
18
19@WebDAO::Base::ISA    = qw(Exporter);
20@WebDAO::Base::EXPORT = qw(mk_attr mk_route _log1 _log2 _log3
21  _log4 _log5 _log6);
22
23=head2 mk_attr ( _attr1=>'default value', __attr2=>undef, __attr2=>1)
24
25Make accessor for class attribute
26
27 use WebDAO;
28 mk_attr( _session=>undef, __obj=>undef, __events=>undef);
29
30
31=cut
32
33sub mk_attr {
34    my ($pkg) = caller;
35    shift if $_[0] =~ /\:\:/ or $_[0] eq $pkg;
36    my %attrs = @_;
37    %{"${pkg}::_WEBDAO_ATTRIBUTES_"} = %attrs;
38    my $code = "";
39    foreach my $attr ( keys %attrs ) {
40
41        # If the accessor is already present, give a warning
42        if ( UNIVERSAL::can( $pkg, "$attr" ) ) {
43            carp "$pkg already has method: $attr";
44            next;
45        }
46        $code .= _define_attr_accessor( $pkg, $attr, $attrs{$attr} );
47    }
48    eval $code;
49    if ($@) {
50        die "ERROR defining and attributes for '$pkg':"
51          . "\n\t$@\n"
52          . "-----------------------------------------------------"
53          . $code;
54    }
55}
56
57=head2 mk_route ( 'route1'=> 'Class::Name', 'route2'=> sub { return new My::Class() })
58
59Make route table for object
60
61 use WebDAO;
62 mk_route(
63    user=>'MyClass::User',
64    test=>sub { return  MyClass->new( param1=>1 ) }
65   );
66
67=cut
68
69sub mk_route {
70    my ($pkg) = caller;
71    shift if $_[0] =~ /\:\:/ or $_[0] eq $pkg;
72    my %attrs = @_;
73    no strict 'refs';
74    while ( my ( $route, $class ) = each %attrs ) {
75
76        #check non loaded mods
77        my ( $main, $module ) = $class =~ m/(.*\:\:)?(\S+)$/;
78        $main ||= 'main::';
79        $module .= '::';
80        unless ( exists $$main{$module} ) {
81            _log6("try autoload class $module");
82            eval "use $class";
83            if ($@) {
84                carp "Error make route for for class :$class with $@ ";
85            }
86        }
87    }
88    %{"${pkg}::_WEBDAO_ROUTE_"} = %attrs;
89    use strict 'refs';
90}
91
92sub _define_attr_accessor {
93    my ( $pkg, $attr, $default ) = @_;
94
95    # qq makes this block behave like a double-quoted string
96    my $code = qq{
97    package $pkg;
98    sub $attr {                                      # Accessor ...
99      my \$self=shift;
100      if (\@_) {
101      my \$prev = exists \$self->{"$attr"} ? \$self->{"$attr"} : \${"${pkg}::_WEBDAO_ATTRIBUTES_"}{"$attr"};
102      \$self->{"$attr"} = shift ;
103      return \$prev
104      }
105      return \${"${pkg}::_WEBDAO_ATTRIBUTES_"}{"$attr"} unless exists \$self->{"$attr"};
106      \$self->{"$attr"}
107    }
108  };
109    $code;
110}
111
112
113sub new {
114    my $class = shift;
115    my $self  = {};
116    my $stat;
117    bless( $self, $class );
118    return $self;
119    return ( $stat = $self->_init(@_) ) ? $self : $stat;
120}
121
122sub _init {
123    my $self = shift;
124    return 1;
125}
126
127#put message into syslog
128sub _deprecated {
129    my $self       = shift;
130    my $new_method = shift;
131    my ( $old_method, $called_from_str, $called_from_method ) =
132      ( ( caller(1) )[3], ( caller(1) )[2], ( caller(2) )[3] );
133    $called_from_method ||= $0;
134    _log3(
135"called deprecated method $old_method from $called_from_method at line $called_from_str. Use method $new_method instead."
136    );
137}
138
139sub _log1 { shift if ref( $_[0] ); _log( level => 1, par => \@_ ) }
140sub _log2 { shift if ref( $_[0] ); _log( level => 2, par => \@_ ) }
141sub _log3 { shift if ref( $_[0] ); _log( level => 3, par => \@_ ) }
142sub _log4 { shift if ref( $_[0] ); _log( level => 4, par => \@_ ) }
143sub _log5 { shift if ref( $_[0] ); _log( level => 5, par => \@_ ) }
144sub _log6 { shift if ref( $_[0] ); _log( level => 6, par => \@_ ) }
145
146sub _log {
147    my $dbg_level = $ENV{wdDebug} || $ENV{WD_DEBUG} || 0;
148    return 0 unless $dbg_level;
149    return $dbg_level unless ( scalar @_ );
150    my %args = @_;
151    return $dbg_level if $dbg_level < $args{level};
152    my ( $mod_sub, $str ) = ( caller(2) )[ 3, 2 ];
153    ($str) = ( caller(1) )[2];
154    print STDERR "$$ [$args{level}] $mod_sub:$str  @{$args{par}} \n";
155}
156
1571;
158__DATA__
159
160=head1 SEE ALSO
161
162http://webdao.sourceforge.net
163
164=head1 AUTHOR
165
166Zahatski Aliaksandr, E<lt>zag@cpan.orgE<gt>
167
168=head1 COPYRIGHT AND LICENSE
169
170Copyright 2002-2015 by Zahatski Aliaksandr
171
172This library is free software; you can redistribute it and/or modify
173it under the same terms as Perl itself.
174
175=cut
176