package WebDAO::Base;
#$Id$

=head1 NAME

WebDAO::Base - Base class

=head1 SYNOPSIS

=head1 DESCRIPTION

WebDAO::Base - Base class

=cut

use Data::Dumper;
use Carp;
@WebDAO::Base::ISA    = qw(Exporter);
@WebDAO::Base::EXPORT = qw(attributes sess_attributes);

$DEBUG = 0;    # assign 1 to it to see code generated on the fly

sub mk_sess_attr {
    my ($pkg) = caller;
    shift if $_[0] =~ /\:\:/ or $_[0] eq $pkg;
#    croak "Error: attributes() invoked multiple times"
#      if scalar @{"${pkg}::_SESS_ATTRIBUTES_"};
    my %attrs = @_;
    %{"${pkg}::_SESS_ATTRIBUTES_"} = %attrs;
    my $code = "";
    foreach my $attr (keys %attrs) {
        # If the accessor is already present, give a warning
        if ( UNIVERSAL::can( $pkg, "$attr" ) ) {
            carp "$pkg already has method: $attr";
            next;
        }
        $code .= _define_sess_accessor( $pkg, $attr, $attrs{$attr} );
    }
    eval $code;
    if ($@) {
        die "ERROR defining and attributes for '$pkg':"
          . "\n\t$@\n"
          . "-----------------------------------------------------"
          . $code;
    }
}


sub _define_sess_accessor {
    my ( $pkg, $attr, $default ) = @_;

    # qq makes this block behave like a double-quoted string
    my $code = qq{
    package $pkg;
    sub $attr {                                      # Accessor ...
      my \$self=shift;
      my \$ret = \@_ ? \$self->set_attribute("$attr",shift):\$self->get_attribute("$attr");
      return \${"${pkg}::_SESS_ATTRIBUTES_"}{"$attr"} unless defined \$ret;
      \$ret
    }
  };
    $code;
}

sub mk_attr {
    my ($pkg) = caller;
    shift if $_[0] =~ /\:\:/ or $_[0] eq $pkg;
    my %attrs = @_;
    %{"${pkg}::_WEBDAO_ATTRIBUTES_"} = %attrs;
    my $code = "";
    foreach my $attr (keys %attrs) {
        # If the accessor is already present, give a warning
        if ( UNIVERSAL::can( $pkg, "$attr" ) ) {
            carp "$pkg already has method: $attr";
            next;
        }
        $code .= _define_attr_accessor( $pkg, $attr, $attrs{$attr} );
    }
    eval $code;
    if ($@) {
        die "ERROR defining and attributes for '$pkg':"
          . "\n\t$@\n"
          . "-----------------------------------------------------"
          . $code;
    }
}

sub _define_attr_accessor {
    my ( $pkg, $attr, $default ) = @_;

    # qq makes this block behave like a double-quoted string
    my $code = qq{
    package $pkg;
    sub $attr {                                      # Accessor ...
      my \$self=shift;
      if (\@_) {
      my \$prev = exists \$self->{"$attr"} ? \$self->{"$attr"} : \${"${pkg}::_WEBDAO_ATTRIBUTES_"}{"$attr"};
      \$self->{"$attr"} = shift ;
      return \$prev
      }
      return \${"${pkg}::_WEBDAO_ATTRIBUTES_"}{"$attr"} unless exists \$self->{"$attr"};
      \$self->{"$attr"}
    }
  };
    $code;
}

sub sess_attributes {
    my ($pkg) = caller;
    shift if $_[0] =~ /\:\:/ or $_[0] eq $pkg;
    croak "Error: attributes() invoked multiple times"
      if scalar @{"${pkg}::_SESS_ATTRIBUTES_"};
    my %attrs = map { $_=>undef} @_;
    %{"${pkg}::_SESS_ATTRIBUTES_"} = %attrs;
    my $code = "";
    foreach my $attr (@_) {
        # If the accessor is already present, give a warning
        if ( UNIVERSAL::can( $pkg, "$attr" ) ) {
            carp "$pkg already has method: $attr";
            next;
        }
        $code .= _define_accessor( $pkg, $attr );
    }
    eval $code;
    if ($@) {
        die "ERROR defining and attributes for '$pkg':"
          . "\n\t$@\n"
          . "-----------------------------------------------------"
          . $code;
    }
}

sub attributes {
    my ($pkg) = caller;
    shift if $_[0] =~ /\:\:/ or $_[0] eq $pkg;
    my $code = "";
    foreach my $attr (@_) {
        print STDERR "  defining method $attr\n" if $DEBUG;

        # If the accessor is already present, give a warning
        if ( UNIVERSAL::can( $pkg, "$attr" ) ) {
            carp "$pkg already has rtl method: $attr";
            next;
        }
        $code .= _define_accessor( $pkg, $attr );
    }
    eval $code;
    if ($@) {
        die "ERROR defining  rtl_attributes for '$pkg':"
          . "\n\t$@\n"
          . "-----------------------------------------------------"
          . $code;
    }

}

sub _define_accessor {
    my ( $pkg, $attr ) = @_;

    # qq makes this block behave like a double-quoted string
    my $code = qq{
    package $pkg;
    sub $attr {                                      # Accessor ...
      my \$self=shift;
      \@_ ? \$self->set_attribute("$attr",shift):\$self->get_attribute("$attr");
    }
  };
    $code;
}

sub _define_constructor {
    my $pkg  = shift;
    my $code = qq {
    package $pkg;
    sub new {
	my \$class =shift;
	my \$self={};
	my \$stat;
	bless (\$self,\$class);
	return (\$stat=\$self->_init(\@_)) ? \$self: \$stat;
#	return \$self if (\$self->_init(\@_));
#	return (\$stat=\$self->Error) ? \$stat : "Error initialize";
    }
  };
    $code;
}

sub get_attribute_names {
    my $pkg = shift;
    $pkg = ref($pkg) if ref($pkg);
    my @result = keys %{"${pkg}::_SESS_ATTRIBUTES_"};
    if ( defined( @{"${pkg}::ISA"} ) ) {
        foreach my $base_pkg ( @{"${pkg}::ISA"} ) {
            push( @result, get_attribute_names($base_pkg) );
        }
    }
    @result;
}

sub set_attribute {
    my ( $obj, $attr_name, $attr_value ) = @_;
    $obj->{"Var"}->{$attr_name} = $attr_value;
}

#
sub get_attribute {
    my ( $self, $attr_name ) = @_;
    return $self->{"Var"}->{$attr_name};
}

# $obj->set_attributes (name => 'John', age => 23);
# Or, $obj->set_attributes (['name', 'age'], ['John', 23]);
sub set_attributes {
    my $obj = shift;
    my $attr_name;
    if ( ref( $_[0] ) ) {
        my ( $attr_name_list, $attr_value_list ) = @_;
        my $i = 0;
        foreach $attr_name (@$attr_name_list) {
            $obj->$attr_name( $attr_value_list->[ $i++ ] );
        }
    }
    else {
        my ( $attr_name, $attr_value );
        while (@_) {
            $attr_name  = shift;
            $attr_value = shift;
            $obj->$attr_name($attr_value);
        }
    }
}

# @attrs = $obj->get_attributes (qw(name age));
sub get_attributes {
    my $obj = shift;
    my (@retval);
    map { $obj->$_() } @_;
}

sub new {
    my $class = shift;
    my $self  = {};
    my $stat;
    bless( $self, $class );
    return ( $stat = $self->_init(@_) ) ? $self : $stat;
}

sub _init {
    my $self = shift;
    return 1;
}

#put message into syslog
sub _deprecated {
    my $self       = shift;
    my $new_method = shift;
    my ( $old_method, $called_from_str, $called_from_method ) =
      ( ( caller(1) )[3], ( caller(1) )[2], ( caller(2) )[3] );
      $called_from_method ||= $0;
    $self->_log3(
"called deprecated method $old_method from $called_from_method at line $called_from_str. Use method $new_method instead."
    );
}

sub logmsgs {
    my $self = shift;
    $self->_deprecated("_log1,_log2");
    $self->_log1(@_);
}
sub _log1 { my $self = shift; $self->_log( level => 1, par => \@_ ) }
sub _log2 { my $self = shift; $self->_log( level => 2, par => \@_ ) }
sub _log3 { my $self = shift; $self->_log( level => 3, par => \@_ ) }
sub _log4 { my $self = shift; $self->_log( level => 4, par => \@_ ) }
sub _log5 { my $self = shift; $self->_log( level => 5, par => \@_ ) }

sub _log {
    my $self = shift;
    my $dbg_level = $ENV{wdDebug} || $ENV{WD_DEBUG} || 0;
    return 0 unless $dbg_level ;
    return $dbg_level unless ( scalar @_ );
    my %args = @_;
    return $dbg_level if $dbg_level < $args{level}; 
    my ( $mod_sub, $str ) = ( caller(2) )[ 3, 2 ];
    ($str) = ( caller(1) )[2];
    print STDERR "$$ [$args{level}] $mod_sub:$str  @{$args{par}} \n";
}

sub LOG {
    my $self = shift;
    $self->_deprecated("_log1,_log2");
    return $self->logmsgs(@_);
}
1;
__DATA__

=head1 SEE ALSO

http://webdao.sourceforge.net

=head1 AUTHOR

Zahatski Aliaksandr, E<lt>zag@cpan.orgE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright 2002-2009 by Zahatski Aliaksandr

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

=cut
