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