view release on metacpan or  search on metacpan

lib/Gtk2/Ex/DBI.pm  view on Meta::CPAN

);

BEGIN {
    $Gtk2::Ex::DBI::VERSION = '2.30';
}

sub new {
   	
	my ( $class, $req, $xml_options ) = @_;
	
	my $self;
	
	if ( ref $req eq "HASH" ) {
    	
    	# Assemble object from request
    	$self = {
            dbh                     => $$req{dbh}                                  # A database handle
    	  , primary_keys            => $$req{primary_keys}                         # An array of primary keys
          , sql                     => $$req{sql}                                  # A hash of SQL related stuff
          , widgets                 => $$req{widgets}                              # A hash of field definitions and stuff
          , schema                  => $$req{schema}                               # The 'schema' to use to get column info from
          , builder                 => $$req{builder}                              # The Gtk2-Builder object ... use either this or 'form', below
          , form                    => $$req{form}                                 # The Gtk2-GladeXML *object* we're using
          , formname                => $$req{formname}                             # The *name* of the window ( needed for dialogs to work properly )
          , read_only               => $$req{read_only} || FALSE                   # Whether changes to the table are allowed
          , apeture                 => $$req{apeture} || 100                       # The number of records to select at a time
          , on_current              => $$req{on_current}                           # A reference to code that is run when we move to a new record
          , before_query            => $$req{before_query}                         # A reference to code that is run *before* a query is executed ( can abort the query )
          , before_apply            => $$req{before_apply}                         # A reference to code that is run *before* the 'apply' method is called
          , on_apply                => $$req{on_apply}                             # A reference to code that is run *after* the 'apply' method is called
          , on_undo                 => $$req{on_undo}                              # A reference to code that is run *after* teh 'undo' method is called
          , on_changed              => $$req{on_changed}                           # A reference to code that is run *every* time a managed field is changed
          , on_initial_changed      => $$req{on_initial_changed}                   # A reference to code that is run when the recordset status *initially* changes to CHANGED 
          , auto_apply              => $$req{auto_apply}                           # Boolean to force all records to be applied automatically when querying, closing, etc
          , calc_fields             => $$req{calc_fields}                          # Calculated field definitions
          , defaults                => $$req{defaults}                             # Default values
          , disable_find            => $$req{disable_find} || FALSE                # Do we build the right-click 'find' item on GtkEntrys?
          , disable_full_table_find => $$req{disable_full_table_find} || FALSE     # Can the user search the whole table ( sql=>{from} ) or only the current recordset?
          , combos                  => $$req{combos}                               # Definitions to set up combos
          , autocompletions         => $$req{autocompletions}                      # Definitions to set up autocompletions
          , data_lock_field         => $$req{data_lock_field} || undef             # A field to use as a data-driven lock ( positive values will lock the record )
          , status_label            => $$req{status_label} || "lbl_RecordStatus"   # The name of a field to use as the record status indicator
          , record_spinner          => $$req{record_spinner} || "RecordSpinner"    # The name of a GtkSpinButton to use as the RecordSpinner
          , quiet                   => $$req{quiet} || FALSE                       # A flag to silence warnings such as missing widgets
          , friendly_table_name     => $$req{friendly_table_name}                  # Table name to use when issuing GUI errors
          , custom_changed_text	    => $$req{custom_changed_text}                  # Text ( including markup ) to use in GUI questions when changes need to be applied
          , changed                 => FALSE                                       # A flag indicating that the current record has been changed
          , changelock              => FALSE                                       # Prevents the 'changed' flag from being set when we're moving records
          , constructor_done        => FALSE                                       # A flag that indicates whether the new() method has completed yet
          , debug                   => $$req{debug} || FALSE                       # Dump info to terminal
          , skip_query              => $$req{skip_query}                           # Don't call query() in the constructor
          , dont_update_keys        => $$req{dont_update_keys}                     # Don't include primary keys in update statements
          , widget_prefix           => $$req{widget_prefix}                        # A string to prefix ( glade ) widget names with when searching for them
          , auto_incrementing       => $$req{auto_incrementing}                    # A flag to indicate whether we should try to poll the last inserted ID after an insert
    	};
    	
	} else {
	    
	    # Assume we're loading an XML
	    my $xml_cfg = XML::Simple->new(
            AttrIndent          => TRUE,                    # XML formatting option - doesn't affect performance
            OutputFile          => $self->{xml_file},
            KeyAttr             => [ ]                      # Stops XML::Simple from squishing some data structures
        );
        
        $self = $xml_cfg->XMLin( $req );
        
        # Attach to the libglade / builder object
        if ( exists $xml_options->{glade_xml} ) {
            $self->{form} = $xml_options->{glade_xml};
        } elsif ( exists $xml_options->{gtk_builder} ) {
        	$self->{builder} = $xml_options->{gtk_builder};
        }
        
        
        # Link DBI connections
        $self->{dbh} = $xml_options->{connections}->{ $self->{Connection} };
        
        foreach my $combo ( keys %{$self->{combos}} ) {
            $self->{combos}->{$combo}->{alternate_dbh} = $xml_options->{connections}->{ $self->{combos}->{$combo}->{connection_name} };
        }
        
	}
	
	my $legacy_warnings;
	
	if ( $self->{debug} ) {
		print "\nGtk2::Ex::DBI version $Gtk2::Ex::DBI::VERSION initialising ...\n\n";
	}
	
	# Check we've been passed enough stuff to continue ...
	
	if ( ! $self->{dbh} ) {
        croak( "Gtk2::Ex::DBI constructor missing a dbh!\n" );
    }
	
	if ( ! $self->{form} && ! $self->{builder} ) {
		croak( "Gtk2::Ex::DBI constructor missing a 'form' ( Gtk2::GladeXML ) and a 'builder' ( Gtk2::Builder ) ..."
		  . " You need one or the other" );
	}
	
    # Set window object for later ( optionally based on legacy 'formname' string )
    if ( ! $self->{formname} ) {
        if ( exists $self->{form} && ref $self->{form} eq "Gtk2::GladeXML" ) {
            foreach my $item ( $self->{form}->get_widget_prefix( "" ) ) {
                if ( ref $item eq "Gtk2::Window" || ref $item eq "Gtk2::Dialog") {
                    $self->{window} = $item;
                    last;
                }
            }
        } elsif ( exists $self->{builder} && ref $self->{builder} eq "Gtk2::Builder" ) {
            foreach my $item ( $self->{builder}->get_objects() ) {
                if ( ref $item eq "Gtk2::Window" || ref $item eq "Gtk2::Dialog") {
                    $self->{window} = $item;
                    last;
                }
            }
        }
        # Now check that we have a window
        if ( ! $self->{window} ) {
            croak( "Gtk2::Ex::DBI wasn't passed a formname,"