view release on metacpan or  search on metacpan

lib/Gtk2/Ex/DbLinker/AbForm.pm  view on Meta::CPAN

package Gtk2::Ex::DbLinker::AbForm;
use Class::InsideOut qw(public private register id);
use Gtk2::Ex::DbLinker::DbTools;
use Scalar::Util qw(weaken);
use Log::Any;
#use Carp 'croak';
our $VERSION = $Gtk2::Ex::DbLinker::DbTools::VERSION;
=head1 NAME

Gtk2::Ex::DbLinker::AbForm - Common methods for Gtk2::Ex::DbLinker::Form and Wx::Perl::DbLinker::Wxform

=head1 SYNOPSIS

See L<Gtk2::Ex::DbLinker::Form> and L<Wx::Perl::DbLinker::Wxform>. The methods in this module are not supposed to be called directly. But they are commented here.

=cut

use strict;
use warnings;
#use Data::Dumper;
use DateTime::Format::Strptime;
use Carp qw(confess croak);

private data_manager => my %dman;
public child_class => my %child_class;
private log => my %log;
private event => my %events;
private states => my %states;
private widgets => my %widgets;

my @arg_names;

sub new {

    my $class = shift;
    my $self = \( my $scalar );
    bless $self, $class;
     register $self;
 weaken $self;
    my $id = id $self;
    my @arg   = @_;
    my $def   = {};
    my $arg_value_ref  = { ( %$def, @arg ) };

    my $arg_holder_ref = { 
        childclass=> \%child_class, 
        data_manager=> \%dman,
        datawidgets => \$widgets{ $id}->{cols},
        datawidgets_ro => \$widgets{ $id}->{datawidgets_ro},
        builder => \$widgets{ $id }->{builder}, 
        on_current => \$events{ $id }->{on_current},
        date_formatters => \$widgets{ $id }->{date_formatters},
        time_zone => \$widgets{ $id }->{time_zone},
        locale => \$widgets{ $id }->{locale},
        rec_spinner_callback => \$events{ $id }->{rec_spinner_callback},
        rec_spinner_insert_callback => \$events{ $id}->{rec_spinner_insert_callback},

    } ;

     @arg_names = keys %{$arg_holder_ref};

    for my $name (@arg_names){
        next unless defined ($arg_value_ref->{$name});

        if (ref $arg_holder_ref->{$name} eq "HASH"){
            $arg_holder_ref->{$name}->{ $id } = $arg_value_ref->{$name};
        } 
        #elsif (ref $arg_holder_ref->{$name} eq "ARRAY") {

        #} 
        else {
           ${$arg_holder_ref->{$name} } =  $arg_value_ref->{$name};
        
        }
    
    }
    #$log{ $id } = Log::Log4perl->get_logger(__PACKAGE__);
    $log{ $id } = Log::Any->get_logger();
        my @dates;

    #$self->{subform} = [];

    #my %formatters_db;
    #my %formatters_f;
    # $self->{dates_formatted} = \(keys %{$self->{date_formatters}});
    if ( !defined $widgets{ $id }->{cols} ) {
        my @col = $dman{ $id }->get_field_names;
        $widgets{ $id }->{cols} = \@col;
    }
    foreach my $v ( keys %{ $widgets{ $id }->{date_formatters} } ) {
        $log{ $id }->debug( "** " . $v . " **" );
        push @dates, $v;
    }
    $widgets{ $id }->{dates_formatted} = \@dates;
    my %hdates = map { $_ => 1 } @dates;
    $widgets{ $id }->{hdates_formatted} = \%hdates;
    $widgets{ $id }->{dates_formatters} = {};
    $states{ $id }->{inserting}        = 0;
    $widgets{ $id }->{pos2del}          = [];

    #bless $self, $class;
   return $self;
}

sub _super_args_needed {
        return @arg_names;
}

=head2 C<set_data_manager( $dman ) >

Replaces the current data manager with the one receives. The columns should not changed, but this method can be use to change the join clause. 

=cut

sub set_data_manager {
    my ( $self, $dman ) = @_;
    $dman{ id $self } = $dman;
}

=head2 C<add_childform( $childform )>

You may add any dependant form or datasheet object with this call if you want that a changed in this subform/datasheet be applied when the apply method of this form is called. 

=cut

sub add_childform {
    my ( $self, $sf ) = @_;
    my $id = id $self;
    $log{ $id }->warn(
        "add_childform : do not set auto_apply to 0 if you call this method")
      unless ( $states{ $id }->{auto_apply} );

#carp("add_childform : do not set auto_apply to 0 if you call this method")  unless ($self->{auto_apply});
    push @{ $widgets{ $id }->{subform} }, $sf;
    weaken @{ $widgets{ $id }->{subform} }[-1];


}

sub _init {
    my $self = shift;
    my $id = id $self;
    if ( defined $widgets{ $id }->{datawidgets_ro} ) {
        my %seen;
        %seen = map { $_ => $seen{$_}++ }
          ( @{ $widgets{ $id }->{cols} }, @{ $widgets{ $id }->{datawidgets_ro} } );
        my @fields_to_save = grep { $seen{$_} < 1 } keys %seen;

        #$log{ $id }->debug("cols: " . join(" ", @{$self->{cols}}));
        $log{ $id }->debug( "cols to saved: " . join( " ", @fields_to_save ) );
        $widgets{ $id }->{col2save} = \@fields_to_save;

    } else {
        $widgets{ $id }->{col2save} = $widgets{ $id }->{cols};

    }

}

sub _painting {
    my $self = shift;
    my $idob = id $self;
    $states{ $idob}->{painting} = $_[0] if (defined $_[0]);
    return  $states{ $idob}->{painting};

}

sub _changed {
    my $self = shift;
    my $idob = id $self;
    $states{ $idob}->{changed} = $_[0] if (defined $_[0]);
    return  $states{ $idob }->{changed};

}

sub _builder {
    my $self = shift;
    my $idob = id $self;
    $widgets{ $idob}->{builder} = $_[0] if (defined $_[0]);
    return  $widgets{ $idob}->{builder};

}
#this datawidgets hash has nothing to do with the argument datawidgets 
#used in new ... it just shows my lake of imagination
sub _datawidgets {
    my $self = shift;
    my $idob = id $self;
    $widgets{ $idob}->{datawidgets}->{ $_[0]} = $_[1] if (defined $_[1]);
    return  $widgets{ $idob}->{datawidgets}->{ $_[0] } if (defined $_[0]); 
    return  $widgets{ $idob}->{datawidgets};

}
sub _datawidgetsName {
    my $self = shift;
    my $idob = id $self;