view release on metacpan or  search on metacpan

lib/Gtk3/Ex/DBI/Form.pm  view on Meta::CPAN

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
          , force_upper_case_fields     => $$req{force_upper_case_fields}              # Forces fieldnames to be upper-case ( set this to match upper-case glade object names )
          , schema                      => $$req{schema}                               # The 'schema' to use to get column info from
          , builder                     => $$req{builder}                              # The Gtk3-Builder object ... use either this or 'form', below
          , 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_insert               => $$req{before_insert}                        # A reference to code that is run *before* an insert to the in-memory recordset ( can abort )
          , before_delete               => $$req{before_delete}                        # A reference to code that is run *before* a record is deleted ( can abort the delete operation )
          , 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_delete                   => $$req{on_delete}                            # A reference to code that is run *after* the 'delete' method is called
          , on_undo                     => $$req{on_undo}                              # A reference to code that is run *after* the '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_name                 => $$req{status_name}                          # The name of a field to use as the record status indicator
          , spinner_name                => $$req{spinner_name}                         # 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
          , use_compat_filter_clause    => $$req{use_compat_filter_clause}             # Build brain-dead filters for DBs that don't support mult-column 'in' clauses
          , widget_prefix               => $$req{widget_prefix}                        # A string to prefix ( builder ) 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
          , recordset_tools_box         => $$req{recordset_tools_box}                  # A box to create recordset tools in ( add / insert / update / delete / undo / spinnner )
          , recordset_tool_items        => $$req{recordset_tool_items}                 # An array of item names to add to the recordset tools box
          , recordset_extra_tools       => $$req{recordset_extra_tools}                # Extra buttons to add to the recordset tools box
        };
        
    } 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
        $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} };
        }
        
    }
    
    if ( $Gtk3::Ex::DBI::USE_COMPAT_FILTER_CLAUSE ) {
        $self->{use_compat_filter_clause} = 1;
    }
    
    # Check we've been passed enough stuff to continue ...
    
    if ( ! $self->{dbh} ) {
        croak( "Gtk3::Ex::DBI::Form constructor missing a dbh!\n" );
    }
    
    if ( ! $self->{builder} ) {
        croak( "Gtk3::Ex::DBI::Form constructor missing a 'builder' ( Gtk3::Builder ) ..." );
    } elsif ( ref $self->{builder} ne "Gtk3::Builder" ) {
        croak( "Gtk3::Ex::DBI::Form constructor contains a 'builder' ... but it's not a Gtk3::Builder!" );
    }
    
    # TODO: complete
    # Decide what class of Gtk3::Ex::DBI to construct ...
    $self->{server} = $self->{dbh}->get_info( 17 );
    
    my $dbi_manager_class = 'Gtk3::Ex::DBI';
    
    # Some database-specific stuff
    if ( $self->{server} =~ /postgres/i ) {
        
        $dbi_manager_class = 'Gtk3::Ex::Postgres';
        
        if ( ! $self->{search_path} ) {
            if ( $self->{schema} ) {
                $self->{search_path} = $self->{schema} . ",public";
            } else {
                $self->{search_path} = "public";
            }
        }
        my $sth = $self->{dbh}->prepare ( "SET search_path to " . $self->{search_path} );
        eval {
            $sth->execute or die $self->{dbh}->errstr;
        };
        if ( $@ ) {
            carp( "Failed to set search_path to " . $self->{search_path}
                . " for a Postgres database. I'm not sure what the implications of this are. Postgres users, please report ...\n" );
        }