| DBI.pm (interchange-5.8.2) | : | DBI.pm (interchange-5.10.0) |
|---|
| | |
| skipping to change at line 45 | | skipping to change at line 45 |
|---|
| # 6: each reference (transitory) | | # 6: each reference (transitory) |
| | |
| use vars qw/ | | use vars qw/ |
| $CONFIG | | $CONFIG |
| $TABLE | | $TABLE |
| $KEY | | $KEY |
| $NAME | | $NAME |
| $TYPE | | $TYPE |
| $DBI | | $DBI |
| $EACH | | $EACH |
|
| | $QTABLE |
| | $QKEY |
| | $QNAME |
| $TIE_HASH | | $TIE_HASH |
| %DBI_connect_cache | | %DBI_connect_cache |
| %DBI_connect_count | | %DBI_connect_count |
| %DBI_connect_bad | | %DBI_connect_bad |
| /; | | /; |
| | |
|
| ($CONFIG, $TABLE, $KEY, $NAME, $TYPE, $DBI, $EACH) = (0 .. 6); | | ($CONFIG, $TABLE, $KEY, $NAME, $TYPE, $DBI, $EACH, $QTABLE, $QKEY, $QNAME) = (0
.. 9); |
| | |
| $TIE_HASH = $DBI; | | $TIE_HASH = $DBI; |
| | |
| my %Cattr = ( qw( | | my %Cattr = ( qw( |
| RAISEERROR RaiseError | | RAISEERROR RaiseError |
| PRINTERROR PrintError | | PRINTERROR PrintError |
| AUTOCOMMIT AutoCommit | | AUTOCOMMIT AutoCommit |
| MYSQL_ENABLE_UTF8 mysql_enable_utf8 | | MYSQL_ENABLE_UTF8 mysql_enable_utf8 |
| ) ); | | ) ); |
| my @Cattr = keys %Cattr; | | my @Cattr = keys %Cattr; |
| | |
| skipping to change at line 146 | | skipping to change at line 149 |
|---|
| Oracle => 1, | | Oracle => 1, |
| }, | | }, |
| HAS_DESCRIBE => { | | HAS_DESCRIBE => { |
| mysql => 1, | | mysql => 1, |
| Pg => 0, | | Pg => 0, |
| Oracle => 0, | | Oracle => 0, |
| }, | | }, |
| DESCRIBE_TABLE => { | | DESCRIBE_TABLE => { |
| mysql => sub { | | mysql => sub { |
| my $s = shift; | | my $s = shift; |
|
| my $q = "show create table $s->[$TABLE]"; | | my $q = "show create table $s->[$QTABLE]"; |
| #::logDebug("describe query: $q"); | | #::logDebug("describe query: $q"); |
| my $sth = $s->[$DBI]->prepare($q); | | my $sth = $s->[$DBI]->prepare($q); |
| $sth->execute(); | | $sth->execute(); |
| my $out = ''; | | my $out = ''; |
| my $ary; | | my $ary; |
| while($ary = $sth->fetchrow_arrayref()) { | | while($ary = $sth->fetchrow_arrayref()) { |
| $out .= $ary->[1]; | | $out .= $ary->[1]; |
| $out .= "\n"; | | $out .= "\n"; |
| } | | } |
| #::logDebug("describe query returns: $out"); | | #::logDebug("describe query returns: $out"); |
| | |
| skipping to change at line 186 | | skipping to change at line 189 |
|---|
| }, | | }, |
| ALTER_INDEX => { | | ALTER_INDEX => { |
| mysql => 'CREATE _UNIQUE_ INDEX $TABLE$_$COLUMN$ ON _TABLE_ (_COL
UMN_)', | | mysql => 'CREATE _UNIQUE_ INDEX $TABLE$_$COLUMN$ ON _TABLE_ (_COL
UMN_)', |
| Pg => 'CREATE _UNIQUE_ INDEX $TABLE$_$COLUMN$ ON _TABLE_ (_COLUMN
_)', | | Pg => 'CREATE _UNIQUE_ INDEX $TABLE$_$COLUMN$ ON _TABLE_ (_COLUMN
_)', |
| default => 'CREATE _UNIQUE_ INDEX $TABLE$_$COLUMN$ ON _TABLE_ (_C
OLUMN_)', | | default => 'CREATE _UNIQUE_ INDEX $TABLE$_$COLUMN$ ON _TABLE_ (_C
OLUMN_)', |
| }, | | }, |
| LIST_FIELDS_QUERY => { | | LIST_FIELDS_QUERY => { |
| mysql => 'SELECT * FROM `_TABLE_` WHERE 2 = 1', | | mysql => 'SELECT * FROM `_TABLE_` WHERE 2 = 1', |
| }, | | }, |
| SEQUENCE_CREATE => { | | SEQUENCE_CREATE => { |
|
| Oracle => "CREATE SEQUENCE _SEQUENCE_NAME_", | | Oracle => "CREATE SEQUENCE _SEQUENCE_NAME_ID_", |
| Pg => "CREATE SEQUENCE _SEQUENCE_NAME_", | | Pg => "CREATE SEQUENCE _SEQUENCE_NAME_ID_", |
| }, | | }, |
| HAS_TABLE_TYPE => { | | HAS_TABLE_TYPE => { |
| mysql => 1, | | mysql => 1, |
| }, | | }, |
| TABLE_COMMENT_SQL => { | | TABLE_COMMENT_SQL => { |
| mysql => 'COMMENT=_COMMENT_', | | mysql => 'COMMENT=_COMMENT_', |
| Pg => 'COMMENT ON _TABLE_ IS _COMMENT_', | | Pg => 'COMMENT ON _TABLE_ IS _COMMENT_', |
| Oracle => 'COMMENT ON _TABLE_ IS _COMMENT_', | | Oracle => 'COMMENT ON _TABLE_ IS _COMMENT_', |
| }, | | }, |
| TABLE_COMMENT_DURING_CREATE => { | | TABLE_COMMENT_DURING_CREATE => { |
| mysql => 1, | | mysql => 1, |
| }, | | }, |
| SEQUENCE_QUERY => { | | SEQUENCE_QUERY => { |
|
| Oracle => "SELECT _SEQUENCE_NAME_.nextval FROM dual", | | Oracle => "SELECT _SEQUENCE_NAME_ID_.nextval FROM dual", |
| Pg => "SELECT nextval('_SEQUENCE_NAME_')", | | Pg => "SELECT nextval(_SEQUENCE_NAME_V_)", |
| }, | | }, |
| SEQUENCE_VAL => { | | SEQUENCE_VAL => { |
| mysql => undef, | | mysql => undef, |
| }, | | }, |
| SEQUENCE_KEY => { | | SEQUENCE_KEY => { |
| mysql => 'INT PRIMARY KEY AUTO_INCREMENT', | | mysql => 'INT PRIMARY KEY AUTO_INCREMENT', |
| Pg => 'INT NOT NULL PRIMARY KEY', | | Pg => 'INT NOT NULL PRIMARY KEY', |
| Oracle => 'INT NOT NULL PRIMARY KEY', | | Oracle => 'INT NOT NULL PRIMARY KEY', |
| }, | | }, |
| SEQUENCE_VALUE_FUNCTION => { | | SEQUENCE_VALUE_FUNCTION => { |
|
| Pg => "SELECT currval('_SEQUENCE_NAME_')", | | Pg => "SELECT currval(_SEQUENCE_NAME_V_)", |
| Oracle => "SELECT _SEQUENCE_NAME_.currval FROM dual", | | Oracle => "SELECT _SEQUENCE_NAME_ID_.currval FROM dual", |
| }, | | }, |
| SEQUENCE_LAST_FUNCTION => { | | SEQUENCE_LAST_FUNCTION => { |
| mysql => 'select last_insert_id()', | | mysql => 'select last_insert_id()', |
| ## These use explicit | | ## These use explicit |
| Pg => undef, | | Pg => undef, |
| Oracle => undef, | | Oracle => undef, |
| }, | | }, |
| UPPER_COMPARE => { | | UPPER_COMPARE => { |
| Oracle => 1, | | Oracle => 1, |
| Pg => 1, | | Pg => 1, |
| | |
| skipping to change at line 254 | | skipping to change at line 257 |
|---|
| if(! defined $config->{$k} ) { | | if(! defined $config->{$k} ) { |
| #::logDebug("checking $driver_name cap $k: $known->{$driver_name}"); | | #::logDebug("checking $driver_name cap $k: $known->{$driver_name}"); |
| $config->{$k} = $known->{$driver_name} | | $config->{$k} = $known->{$driver_name} |
| if defined $known->{$driver_name}; | | if defined $known->{$driver_name}; |
| } | | } |
| } | | } |
| } | | } |
| | |
| sub create_sql { | | sub create_sql { |
| my ($s, $tablename, $config, $columns) = @_; | | my ($s, $tablename, $config, $columns) = @_; |
|
| | my ($qtable, $qcols); |
| | |
| #::logDebug("create_sql called, tablename=$tablename config=$config columns=$col
umns"); | | #::logDebug("create_sql called, tablename=$tablename config=$config columns=$col
umns"); |
| if($s) { | | if($s) { |
| $config = $s->[$CONFIG]; | | $config = $s->[$CONFIG]; |
| my @col = $s->columns(); | | my @col = $s->columns(); |
| $columns = \@col; | | $columns = \@col; |
| } | | } |
| elsif(! $config) { | | elsif(! $config) { |
| return undef; | | return undef; |
| } | | } |
| | |
|
| | if (!$config->{QUOTE_IDENTIFIERS}) { |
| | $qtable = $tablename; |
| | $qcols = $columns; |
| | } |
| | elsif ($s) { |
| | $qtable = $s->[$QTABLE]; |
| | $qcols = $s->[$QNAME]; |
| | } |
| | else { |
| | # We need a db handle to quote the identifiers with |
| | my $cc = {%$config}; # Make a copy |
| | $cc->{HANDLE_ONLY} = 1; |
| | my $db = __PACKAGE__->open_table($cc, $tablename); |
| | $db &&= $db->[$DBI]; |
| | if ($db) { |
| | $qtable = $db->quote_identifier($tablename); |
| | $qcols = [map { |
| | my $col = $_; |
| | $col =~ s/^(\S+)/$db->quote_identifier($1)/e; |
| | $col; |
| | } @$columns]; |
| | } |
| | else { |
| | $qtable = $tablename; |
| | $qcols = $columns; |
| | } |
| | } |
| | |
| if($s and $config->{HAS_DESCRIBE}) { | | if($s and $config->{HAS_DESCRIBE}) { |
| #::logDebug("attempting DESCRIBE_TABLE=$config->{DESCRIBE_TABLE}"); | | #::logDebug("attempting DESCRIBE_TABLE=$config->{DESCRIBE_TABLE}"); |
| return $config->{DESCRIBE_TABLE}->($s); | | return $config->{DESCRIBE_TABLE}->($s); |
| } | | } |
| my $key = $config->{KEY} || $columns->[0]; | | my $key = $config->{KEY} || $columns->[0]; |
| | |
| my @cols; | | my @cols; |
| my $keycol; | | my $keycol; |
| | |
| my $def_type = $config->{DEFAULT_TYPE} || 'char(128)'; | | my $def_type = $config->{DEFAULT_TYPE} || 'char(128)'; |
| #::logDebug("columns coming in: @{$columns}"); | | #::logDebug("columns coming in: @{$columns}"); |
| for (my $i = 0; $i < @$columns; $i++) { | | for (my $i = 0; $i < @$columns; $i++) { |
|
| $cols[$i] = $$columns[$i]; | | $cols[$i] = $qcols->[$i]; |
| #::logDebug("checking column '$cols[$i]'"); | | #::logDebug("checking column '$column->[$i]'"); |
| if(defined $key) { | | if(defined $key) { |
|
| $keycol = $i if $cols[$i] eq $key; | | $keycol = $i if $columns->[$i] eq $key; |
| } | | } |
|
| if(defined $config->{COLUMN_DEF}->{$cols[$i]}) { | | if(defined $config->{COLUMN_DEF}->{$columns->[$i]}) { |
| $cols[$i] .= " " . $config->{COLUMN_DEF}->{$cols[$i]}; | | $cols[$i] .= " " . $config->{COLUMN_DEF}->{$columns->[$i] |
| | }; |
| } | | } |
| else { | | else { |
| $cols[$i] .= " $def_type"; | | $cols[$i] .= " $def_type"; |
| } | | } |
|
| $$columns[$i] = $cols[$i]; | | # $$columns[$i] = $cols[$i]; |
| $$columns[$i] =~ s/\s+.*//; | | $$columns[$i] =~ s/\s+.*//; |
| } | | } |
| | |
| $keycol = 0 unless defined $keycol; | | $keycol = 0 unless defined $keycol; |
| $config->{KEY_INDEX} ||= $keycol; | | $config->{KEY_INDEX} ||= $keycol; |
| $config->{KEY} ||= $key; | | $config->{KEY} ||= $key; |
| $config->{KEY_DEF} ||= 'char (16) NOT NULL'; | | $config->{KEY_DEF} ||= 'char (16) NOT NULL'; |
| | |
| if ( not defined $config->{COLUMN_DEF}->{$key} ) { | | if ( not defined $config->{COLUMN_DEF}->{$key} ) { |
| if($config->{AUTO_SEQUENCE} and $config->{SEQUENCE_KEY}) { | | if($config->{AUTO_SEQUENCE} and $config->{SEQUENCE_KEY}) { |
| $cols[$keycol] =~ s/\s+.*/ $config->{SEQUENCE_KEY}/; | | $cols[$keycol] =~ s/\s+.*/ $config->{SEQUENCE_KEY}/; |
| } | | } |
| elsif(! $config->{COMPOSITE_KEY}) { | | elsif(! $config->{COMPOSITE_KEY}) { |
| $cols[$keycol] =~ s/\s+.*/ $config->{KEY_DEF}/; | | $cols[$keycol] =~ s/\s+.*/ $config->{KEY_DEF}/; |
| } | | } |
| } | | } |
| | |
|
| my $query = "create table $tablename ( \n"; | | my $query = "create table $qtable ( \n"; |
| $query .= join ",\n", @cols; | | $query .= join ",\n", @cols; |
| $query .= "\n)\n"; | | $query .= "\n)\n"; |
| | |
| if ($config->{TABLE_TYPE} && $config->{HAS_TABLE_TYPE} ) { | | if ($config->{TABLE_TYPE} && $config->{HAS_TABLE_TYPE} ) { |
| $query =~ s/\s*$/ TYPE=$config->{TABLE_TYPE}\n/; | | $query =~ s/\s*$/ TYPE=$config->{TABLE_TYPE}\n/; |
| } | | } |
| | |
| if ($config->{TABLE_COMMENT} && $config->{TABLE_COMMENT_SQL}) { | | if ($config->{TABLE_COMMENT} && $config->{TABLE_COMMENT_SQL}) { |
| my $comment = $config->{TABLE_COMMENT}; | | my $comment = $config->{TABLE_COMMENT}; |
| $comment =~ s/^\s*(["'])\s*(.*?)\s*\1\s*$/$2/; | | $comment =~ s/^\s*(["'])\s*(.*?)\s*\1\s*$/$2/; |
| $comment =~ s/'/''/g; | | $comment =~ s/'/''/g; |
| | |
| my $template = $config->{TABLE_COMMENT_SQL}; | | my $template = $config->{TABLE_COMMENT_SQL}; |
| $template =~ s/\b_COMMENT_\b/'$comment'/; | | $template =~ s/\b_COMMENT_\b/'$comment'/; |
| | |
| if ($config->{TABLE_COMMENT_DURING_CREATE}) { | | if ($config->{TABLE_COMMENT_DURING_CREATE}) { |
| $query =~ s/\s*$/ $template\n/; | | $query =~ s/\s*$/ $template\n/; |
| } | | } |
| else { | | else { |
|
| $template =~ s/\b_TABLE_\b/$tablename/; | | $template =~ s/\b_TABLE_\b/$qtable/; |
| | |
| $config->{POSTCREATE} ||= []; | | $config->{POSTCREATE} ||= []; |
| push(@{$config->{POSTCREATE}},$template); | | push(@{$config->{POSTCREATE}},$template); |
| } | | } |
| } | | } |
| return $query; | | return $query; |
| } | | } |
| | |
| sub create { | | sub create { |
| my ($class, $config, $columns, $tablename) = @_; | | my ($class, $config, $columns, $tablename) = @_; |
| | |
| skipping to change at line 369 | | skipping to change at line 401 |
|---|
| || $DBI::errstr | | || $DBI::errstr |
| || "unknown error. Driver '$dname' instal
led?"; | | || "unknown error. Driver '$dname' instal
led?"; |
| } | | } |
| die ::errmsg("connect to %s failed (create) -- %s\n", $call[0], $
msg); | | die ::errmsg("connect to %s failed (create) -- %s\n", $call[0], $
msg); |
| } | | } |
| | |
| # Allow multiple tables in different DBs to have same local name | | # Allow multiple tables in different DBs to have same local name |
| $tablename = $config->{REAL_NAME} | | $tablename = $config->{REAL_NAME} |
| if $config->{REAL_NAME}; | | if $config->{REAL_NAME}; |
| | |
|
| | my $qtable = $config->{QUOTE_IDENTIFIERS} ? $db->quote_identifier($tablen |
| | ame) : $tablename; |
| | |
| # Used so you can do query() and nothing else | | # Used so you can do query() and nothing else |
| if($config->{HANDLE_ONLY}) { | | if($config->{HANDLE_ONLY}) { |
|
| return bless [$config, $tablename, undef, undef, undef, $db], $cl
ass; | | return bless [$config, $tablename, undef, undef, undef, $db, unde
f, $qtable], $class; |
| } | | } |
| | |
| check_capability($config, $db->{Driver}{Name}); | | check_capability($config, $db->{Driver}{Name}); |
| | |
| die ::errmsg( | | die ::errmsg( |
| "table %s: columns argument %s is not an array ref\n", | | "table %s: columns argument %s is not an array ref\n", |
| $config->{name}, | | $config->{name}, |
| $columns, | | $columns, |
| ) unless CORE::ref($columns) eq 'ARRAY'; | | ) unless CORE::ref($columns) eq 'ARRAY'; |
| | |
| if(defined $dattr) { | | if(defined $dattr) { |
| for(keys %$dattr) { | | for(keys %$dattr) { |
| $db->{$_} = $dattr->{$_}; | | $db->{$_} = $dattr->{$_}; |
| } | | } |
| } | | } |
| | |
| my ($i, $key, $keycol); | | my ($i, $key, $keycol); |
| my(@cols); | | my(@cols); |
| | |
| $key = $config->{KEY} || $columns->[0]; | | $key = $config->{KEY} || $columns->[0]; |
|
| | my $qkey = $config->{QUOTE_IDENTIFIERS} ? $db->quote_identifier($key) : $
key; |
| $keycol = 0 unless defined $keycol; | | $keycol = 0 unless defined $keycol; |
| $config->{KEY_INDEX} = $keycol; | | $config->{KEY_INDEX} = $keycol; |
| $config->{KEY} = $key; | | $config->{KEY} = $key; |
| | |
| if(ref $config->{PRECREATE}) { | | if(ref $config->{PRECREATE}) { |
| for(@{$config->{PRECREATE}} ) { | | for(@{$config->{PRECREATE}} ) { |
| $db->do($_) | | $db->do($_) |
| or ::logError( | | or ::logError( |
| "DBI: Prior creat
ion query '%s' failed: %s" , | | "DBI: Prior creat
ion query '%s' failed: %s" , |
| $_, | | $_, |
| | |
| skipping to change at line 426 | | skipping to change at line 461 |
|---|
| $tablename, | | $tablename, |
| $DBI::errstr, | | $DBI::errstr, |
| ); | | ); |
| } | | } |
| } | | } |
| else { | | else { |
| # test creation of table | | # test creation of table |
| my $query = create_sql(undef, $tablename, $config, $columns); | | my $query = create_sql(undef, $tablename, $config, $columns); |
| | |
| eval { | | eval { |
|
| $db->do("drop table $tablename") | | $db->do("drop table $qtable") |
| and $config->{Clean_start} = 1 | | and $config->{Clean_start} = 1 |
| or warn "$DBI::errstr\n"; | | or warn "$DBI::errstr\n"; |
| $db->commit() if $config->{Transactions}; | | $db->commit() if $config->{Transactions}; |
| }; | | }; |
| | |
| #::logDebug("Trying to create with:$query"); | | #::logDebug("Trying to create with:$query"); |
| eval { | | eval { |
| $db->do($query); | | $db->do($query); |
| $db->commit() if $config->{Transactions}; | | $db->commit() if $config->{Transactions}; |
| }; | | }; |
| if($@) { | | if($@) { |
| warn "DBI: Create table '$tablename' failed: $DBI::errstr
\n"; | | warn "DBI: Create table '$tablename' failed: $DBI::errstr
\n"; |
| } | | } |
| else { | | else { |
| ::logError("table %s created: %s" , $tablename, $query ); | | ::logError("table %s created: %s" , $tablename, $query ); |
| } | | } |
| } | | } |
| | |
| #::logDebug("seq: $config->{AUTO_SEQUENCE} create: $config->{SEQUENCE_CREATE}"); | | #::logDebug("seq: $config->{AUTO_SEQUENCE} create: $config->{SEQUENCE_CREATE}"); |
| if($config->{AUTO_SEQUENCE} and my $q = $config->{SEQUENCE_CREATE}) { | | if($config->{AUTO_SEQUENCE} and my $q = $config->{SEQUENCE_CREATE}) { |
|
| | my $seq_name = $config->{AUTO_SEQUENCE}; |
| | my $seq_name_id = $config->{QUOTE_IDENTIFIERS} ? $db->quote_ident |
| | ifier($seq_name) : $seq_name; |
| | my $seq_name_v = $db->quote($seq_name); |
| if($config->{AUTO_SEQUENCE_DROP}) { | | if($config->{AUTO_SEQUENCE_DROP}) { |
|
| my $dq = $config->{SEQUENCE_DROP} || 'DROP SEQUENCE _SEQU | | my $dq = $config->{SEQUENCE_DROP} || 'DROP SEQUENCE _SEQU |
| ENCE_NAME_'; | | ENCE_NAME_ID_'; |
| $dq =~ s/_SEQUENCE_NAME_/$config->{AUTO_SEQUENCE}/g; | | $dq =~ s/_SEQUENCE_NAME_ID_/$seq_name_id/g; |
| | $dq =~ s/_SEQUENCE_NAME_V_/$seq_name_v/g; |
| | $dq =~ s/_SEQUENCE_NAME_/$seq_name/g; |
| #::logDebug("dropping sequence with query: $dq"); | | #::logDebug("dropping sequence with query: $dq"); |
| eval { | | eval { |
| $db->do($dq) | | $db->do($dq) |
| or warn("drop sequence failed: $dq"); | | or warn("drop sequence failed: $dq"); |
| $db->commit() if $config->{Transactions}; | | $db->commit() if $config->{Transactions}; |
| }; | | }; |
| } | | } |
|
| $q =~ s/_SEQUENCE_NAME_/$config->{AUTO_SEQUENCE}/g; | | |
| | $q =~ s/_SEQUENCE_NAME_ID_/$seq_name_id/g; |
| | $q =~ s/_SEQUENCE_NAME_V_/$seq_name_v/g; |
| | $q =~ s/_SEQUENCE_NAME_/$seq_name/g; |
| $q =~ s/_SEQUENCE_START_/$config->{AUTO_SEQUENCE_START} || 1/eg; | | $q =~ s/_SEQUENCE_START_/$config->{AUTO_SEQUENCE_START} || 1/eg; |
| $q =~ s/_SEQUENCE_CACHE_/$config->{AUTO_SEQUENCE_CACHE} || 1/eg; | | $q =~ s/_SEQUENCE_CACHE_/$config->{AUTO_SEQUENCE_CACHE} || 1/eg; |
| $q =~ s/_SEQUENCE_MINVAL_/$config->{AUTO_SEQUENCE_MINVAL} || 1/eg
; | | $q =~ s/_SEQUENCE_MINVAL_/$config->{AUTO_SEQUENCE_MINVAL} || 1/eg
; |
| $q =~ s/_SEQUENCE_MAXVAL_/$config->{AUTO_SEQUENCE_MAXVAL} || 2147
483647/eg; | | $q =~ s/_SEQUENCE_MAXVAL_/$config->{AUTO_SEQUENCE_MAXVAL} || 2147
483647/eg; |
| #::logDebug("create query: $q"); | | #::logDebug("create query: $q"); |
| eval { | | eval { |
| $db->do($q) | | $db->do($q) |
| or warn("create sequence failed: $q"); | | or warn("create sequence failed: $q"); |
| $db->commit() if $config->{Transactions}; | | $db->commit() if $config->{Transactions}; |
| }; | | }; |
| | |
| skipping to change at line 481 | | skipping to change at line 524 |
|---|
| my $key_index_found; | | my $key_index_found; |
| if(ref $config->{INDEX}) { | | if(ref $config->{INDEX}) { |
| for my $def (@{$config->{INDEX}}) { | | for my $def (@{$config->{INDEX}}) { |
| my $uniq = ''; | | my $uniq = ''; |
| $uniq = 'UNIQUE' if $def =~ s/^\s*unique\s+//i; | | $uniq = 'UNIQUE' if $def =~ s/^\s*unique\s+//i; |
| $def =~ s/:(\w+)//g | | $def =~ s/:(\w+)//g |
| and $config->{INDEX_OPTIONS}{$def} = $1; | | and $config->{INDEX_OPTIONS}{$def} = $1; |
| my $col = $def; | | my $col = $def; |
| $col =~ s/\W.*//s; | | $col =~ s/\W.*//s; |
| $key_index_found = 1 if lc($col) eq lc($key); | | $key_index_found = 1 if lc($col) eq lc($key); |
|
| | my $qcol = $config->{QUOTE_IDENTIFIERS} ? $db->quote_iden |
| | tifier($col) : $col; |
| | my $qdef = $def; |
| | $qdef =~ s/^\Q$col\E/$qcol/i if $config->{QUOTE_IDENTIFIE |
| | RS}; |
| my $template = $config->{ALTER_INDEX} | | my $template = $config->{ALTER_INDEX} |
| || $known_capability{ALTER_INDEX}
{default}; | | || $known_capability{ALTER_INDEX}
{default}; |
|
| $template =~ s/\b_TABLE_\b/$tablename/g; | | $template =~ s/\b_TABLE_\b/$qtable/g; |
| $template =~ s/\b_COLUMN_\b/$col/g; | | $template =~ s/\b_COLUMN_\b/$qcol/g; |
| $template =~ s/\b_DEF_\b/$def/g; | | $template =~ s/\b_DEF_\b/$qdef/g; |
| $template =~ s/\$TABLE\$/$tablename/g; | | $template =~ s/\$TABLE\$/$qtable/g; |
| $template =~ s/\$DEF\$/$def/g; | | $template =~ s/\$DEF\$/$qdef/g; |
| $template =~ s/\$COLUMN\$/$col/g; | | $template =~ s/\$COLUMN\$/$qcol/g; |
| $template =~ s/\b_UNIQUE_(\w+_)?/$uniq ? ($1 || $uniq) :
''/eg; | | $template =~ s/\b_UNIQUE_(\w+_)?/$uniq ? ($1 || $uniq) :
''/eg; |
| push @index, $template; | | push @index, $template; |
| } | | } |
| } | | } |
| | |
| if(ref $config->{POSTCREATE}) { | | if(ref $config->{POSTCREATE}) { |
| for(@{$config->{POSTCREATE}} ) { | | for(@{$config->{POSTCREATE}} ) { |
| $db->do($_) | | $db->do($_) |
| or ::logError( | | or ::logError( |
| "DBI: Post creati
on query '%s' failed: %s" , | | "DBI: Post creati
on query '%s' failed: %s" , |
| | |
| skipping to change at line 510 | | skipping to change at line 556 |
|---|
| $DBI::errstr, | | $DBI::errstr, |
| ); | | ); |
| $db->commit() if $config->{Transactions}; | | $db->commit() if $config->{Transactions}; |
| } | | } |
| } | | } |
| elsif ($config->{AUTO_INDEX_PRIMARY_KEY}) { | | elsif ($config->{AUTO_INDEX_PRIMARY_KEY}) { |
| # Oracle automatically creates indexes on primary keys, | | # Oracle automatically creates indexes on primary keys, |
| # so we don't need to do it again | | # so we don't need to do it again |
| } | | } |
| elsif(! $key_index_found) { | | elsif(! $key_index_found) { |
|
| $db->do("create index ${tablename}_${key} on $tablename ($key)") | | my $ind_name = "${tablename}_${key}"; |
| | $ind_name = $db->quote_identifier($ind_name) if $config->{QUOTE_IDENT |
| | IFIERS}; |
| | $db->do("create index $ind_name on $qtable ($qkey)") |
| or ::logError("table %s index failed: %s" , $tablename, $
DBI::errstr); | | or ::logError("table %s index failed: %s" , $tablename, $
DBI::errstr); |
| $db->commit() if $config->{Transactions}; | | $db->commit() if $config->{Transactions}; |
| } | | } |
| | |
| for(@index) { | | for(@index) { |
| #::logDebug("Running: $_"); | | #::logDebug("Running: $_"); |
| $db->do($_) | | $db->do($_) |
| or ::logError( | | or ::logError( |
| "DBI: Post creation query
'%s' failed: %s" , | | "DBI: Post creation query
'%s' failed: %s" , |
| $_, | | $_, |
| | |
| skipping to change at line 552 | | skipping to change at line 600 |
|---|
| | |
| $config->{EXTENDED} = defined($config->{FIELD_ALIAS}) | | $config->{EXTENDED} = defined($config->{FIELD_ALIAS}) |
| || defined $config->
{FILTER_FROM} | | || defined $config->
{FILTER_FROM} |
| || defined $config->
{FILTER_TO} | | || defined $config->
{FILTER_TO} |
| || $config->{UPPERCA
SE} | | || $config->{UPPERCA
SE} |
| || ''; | | || ''; |
| } | | } |
| | |
| $config->{NAME} = $columns; | | $config->{NAME} = $columns; |
| | |
|
| my $s = [$config, $tablename, $key, $columns, undef, $db]; | | # Quote identifiers |
| | my ($qtable, $qkey, $qnames); |
| | if ($config->{QUOTE_IDENTIFIERS}) { |
| | $qtable = $db->quote_identifier($tablename); |
| | $qkey = $db->quote_identifier($key); |
| | $qnames = [map {$db->quote_identifier($_)} @$columns]; |
| | } |
| | else { |
| | $qtable = $tablename; |
| | $qkey = $key; |
| | $qnames = $columns; |
| | } |
| | |
| | my $s = [$config, $tablename, $key, $columns, undef, $db, undef, $qtable, $q |
| | key, $qnames]; |
| bless $s, $class; | | bless $s, $class; |
| } | | } |
| | |
| sub new { | | sub new { |
| my ($class, $obj) = @_; | | my ($class, $obj) = @_; |
| bless [$obj], $class; | | bless [$obj], $class; |
| } | | } |
| | |
| sub open_table { | | sub open_table { |
| my ($class, $config, $tablename) = @_; | | my ($class, $config, $tablename) = @_; |
| | |
| skipping to change at line 656 | | skipping to change at line 717 |
|---|
| else { | | else { |
| #::logDebug("$config->{name} using cached connection $config->{dsn_id}"); | | #::logDebug("$config->{name} using cached connection $config->{dsn_id}"); |
| } | | } |
| } | | } |
| | |
| die ::errmsg("%s: %s", $tablename, $DBI::errstr) unless $db; | | die ::errmsg("%s: %s", $tablename, $DBI::errstr) unless $db; |
| | |
| # Allow multiple tables in different DBs to have same local name | | # Allow multiple tables in different DBs to have same local name |
| $tablename = $config->{REAL_NAME} | | $tablename = $config->{REAL_NAME} |
| if $config->{REAL_NAME}; | | if $config->{REAL_NAME}; |
|
| | my $qtable = $config->{QUOTE_IDENTIFIERS} ? $db->quote_identifier($tablen
ame) : $tablename; |
| | |
| if (ref $config->{PREQUERY} eq 'ARRAY') { | | if (ref $config->{PREQUERY} eq 'ARRAY') { |
| for (@{$config->{PREQUERY}}) { | | for (@{$config->{PREQUERY}}) { |
| $db->do($_) | | $db->do($_) |
| or ::logError( | | or ::logError( |
| "DBI: Pre-use query '%s' failed:
%s" , | | "DBI: Pre-use query '%s' failed:
%s" , |
| $_, | | $_, |
| $DBI::errstr, | | $DBI::errstr, |
| ); | | ); |
| } | | } |
| | |
| skipping to change at line 681 | | skipping to change at line 743 |
|---|
| } | | } |
| | |
| check_capability($config, $db->{Driver}{Name}); | | check_capability($config, $db->{Driver}{Name}); |
| | |
| unless ($config->{hot_dbi}) { | | unless ($config->{hot_dbi}) { |
| $DBI_connect_count{$config->{dsn_id}}++; | | $DBI_connect_count{$config->{dsn_id}}++; |
| } | | } |
| #::logDebug("connect count open: " . $DBI_connect_count{$config->{dsn_id}}); | | #::logDebug("connect count open: " . $DBI_connect_count{$config->{dsn_id}}); |
| | |
| if($config->{HANDLE_ONLY}) { | | if($config->{HANDLE_ONLY}) { |
|
| return bless [$config, $tablename, undef, undef, undef, $db], $cl
ass; | | return bless [$config, $tablename, undef, undef, undef, $db, unde
f, $qtable], $class; |
| } | | } |
| my $key; | | my $key; |
| my $columns; | | my $columns; |
| | |
| if(defined $dattr) { | | if(defined $dattr) { |
| for(keys %$dattr) { | | for(keys %$dattr) { |
| $db->{$_} = $dattr->{$_}; | | $db->{$_} = $dattr->{$_}; |
| } | | } |
| } | | } |
| | |
| | |
| skipping to change at line 704 | | skipping to change at line 766 |
|---|
| ## $config->{_Numeric_ary}, reads GUESS_NUMERIC | | ## $config->{_Numeric_ary}, reads GUESS_NUMERIC |
| | |
| $config->{_Auto_number} = $config->{AUTO_SEQUENCE} || $config->{A
UTO_NUMBER}; | | $config->{_Auto_number} = $config->{AUTO_SEQUENCE} || $config->{A
UTO_NUMBER}; |
| | |
| if(! $config->{NAME}) { | | if(! $config->{NAME}) { |
| $config->{NAME} = list_fields($db, $tablename, $config); | | $config->{NAME} = list_fields($db, $tablename, $config); |
| } | | } |
| else { | | else { |
| list_fields($db, $tablename, $config); | | list_fields($db, $tablename, $config); |
| } | | } |
|
| | $config->{QNAME} = $config->{QUOTE_IDENTIFIERS} ? |
| | [map {$db->quote_identifier($_)} @{$config->{NAME}}] : |
| | $config->{NAME}; |
| | |
| ## side-effects here -- sets $config->{_Default_ary} if needed | | ## side-effects here -- sets $config->{_Default_ary} if needed |
| $config->{COLUMN_INDEX} = fields_index($config->{NAME}, $config,
$db) | | $config->{COLUMN_INDEX} = fields_index($config->{NAME}, $config,
$db) |
| if ! $config->{COLUMN_INDEX}; | | if ! $config->{COLUMN_INDEX}; |
| | |
| $config->{EXTENDED} = defined($config->{FIELD_ALIAS}) | | $config->{EXTENDED} = defined($config->{FIELD_ALIAS}) |
| || defined $config->
{FILTER_FROM} | | || defined $config->
{FILTER_FROM} |
| || defined $config->
{FILTER_TO} | | || defined $config->
{FILTER_TO} |
| || $config->{UPPERCA
SE} | | || $config->{UPPERCA
SE} |
| || ''; | | || ''; |
| | |
| skipping to change at line 735 | | skipping to change at line 800 |
|---|
| } | | } |
| $config->{KEY_INDEX} = $config->{COLUMN_INDEX}{lc $key} | | $config->{KEY_INDEX} = $config->{COLUMN_INDEX}{lc $key} |
| if ! $config->{KEY_INDEX}; | | if ! $config->{KEY_INDEX}; |
| die ::errmsg("Bad key specification: %s" . | | die ::errmsg("Bad key specification: %s" . |
| Vend::Util::uneval_it($config->{NAME}) . | | Vend::Util::uneval_it($config->{NAME}) . |
| Vend::Util::uneval_it($config->{COLUMN_IN
DEX}), | | Vend::Util::uneval_it($config->{COLUMN_IN
DEX}), |
| $key | | $key |
| ) | | ) |
| if ! defined $config->{KEY_INDEX}; | | if ! defined $config->{KEY_INDEX}; |
| | |
|
| | my $qkey = $config->{QKEY} = $config->{QUOTE_IDENTIFIERS} ? $db->quote_id |
| | entifier($key) : $key; |
| | |
| if ( $config->{MAX_FIELD_LENGTH} | | if ( $config->{MAX_FIELD_LENGTH} |
| and | | and |
| $config->{LENGTH_EXCEPTION_DEFAULT} | | $config->{LENGTH_EXCEPTION_DEFAULT} |
| and | | and |
| ! $config->{FIELD_LENGTH_DATA} | | ! $config->{FIELD_LENGTH_DATA} |
| ) | | ) |
| { | | { |
| my $ssql = $config->{MAX_FIELD_LENGTH}; | | my $ssql = $config->{MAX_FIELD_LENGTH}; |
|
| $ssql =~ s/_TABLE_/$tablename/g; | | $ssql =~ s/_TABLE_/$qtable/g; |
| my $osth = $db->prepare($ssql); | | my $osth = $db->prepare($ssql); |
| $osth->execute; | | $osth->execute; |
| | |
| $config->{FIELD_LENGTH_DATA} = {}; | | $config->{FIELD_LENGTH_DATA} = {}; |
| | |
| while (my @ores = $osth->fetchrow_array) { | | while (my @ores = $osth->fetchrow_array) { |
| my $stype = $ores[1]; | | my $stype = $ores[1]; |
| my $slen = $ores[2]; | | my $slen = $ores[2]; |
| my $slenvar = $ores[3]; | | my $slenvar = $ores[3]; |
| my $len; | | my $len; |
| | |
| skipping to change at line 778 | | skipping to change at line 845 |
|---|
| $scfg->{LENGTH} = $slenvar; | | $scfg->{LENGTH} = $slenvar; |
| } | | } |
| else { | | else { |
| $scfg->{LENGTH} = $len; | | $scfg->{LENGTH} = $len; |
| } | | } |
| } | | } |
| | |
| $osth->finish; | | $osth->finish; |
| } | | } |
| | |
|
| my $s = [$config, $tablename, $key, $config->{NAME}, $config->{EXTENDED}, $d
b]; | | my $s = [$config, $tablename, $key, $config->{NAME}, $config->{EXTENDED}, $d
b, undef, $qtable, $qkey, $config->{QNAME}]; |
| bless $s, $class; | | bless $s, $class; |
| } | | } |
| | |
| sub suicide { | | sub suicide { |
| my $s = shift; | | my $s = shift; |
| undef $s->[$DBI]; | | undef $s->[$DBI]; |
| } | | } |
| | |
| sub close_table { | | sub close_table { |
| my $s = shift; | | my $s = shift; |
| | |
| skipping to change at line 840 | | skipping to change at line 907 |
|---|
| $s = $s->import_db() if ! defined $s->[$DBI]; | | $s = $s->import_db() if ! defined $s->[$DBI]; |
| return $s->[$DBI]->quote($value) unless $field; | | return $s->[$DBI]->quote($value) unless $field; |
| return 'NULL' if ! length($value) | | return 'NULL' if ! length($value) |
| and exists $s->[$CONFIG]->{PREFER_NULL}{$
field}; | | and exists $s->[$CONFIG]->{PREFER_NULL}{$
field}; |
| return $s->[$DBI]->quote($value) | | return $s->[$DBI]->quote($value) |
| unless exists $s->[$CONFIG]->{NUMERIC}{$f
ield}; | | unless exists $s->[$CONFIG]->{NUMERIC}{$f
ield}; |
| $value = 0 if ! length($value); | | $value = 0 if ! length($value); |
| return $value; | | return $value; |
| } | | } |
| | |
|
| | sub quote_identifier { |
| | my ($s, $value) = @_; |
| | $s = $s->import_db() if ! defined $s->[$DBI]; |
| | return $s->[$DBI]->quote_identifier($value); |
| | } |
| | |
| sub numeric { | | sub numeric { |
| return exists $_[0]->[$CONFIG]->{NUMERIC}->{$_[1]}; | | return exists $_[0]->[$CONFIG]->{NUMERIC}->{$_[1]}; |
| } | | } |
| | |
| sub filter { | | sub filter { |
| my ($s, $ary, $col, $filter) = @_; | | my ($s, $ary, $col, $filter) = @_; |
| my $column; | | my $column; |
| for(keys %$filter) { | | for(keys %$filter) { |
| next unless defined ($column = $col->{$_}); | | next unless defined ($column = $col->{$_}); |
| $ary->[$column] = Vend::Interpolate::filter_value( | | $ary->[$column] = Vend::Interpolate::filter_value( |
| $filter->{$_}, | | $filter->{$_}, |
| $ary->[$column], | | $ary->[$column], |
| $_, | | $_, |
| ); | | ); |
| } | | } |
| } | | } |
| | |
| sub inc_field { | | sub inc_field { |
| my ($s, $key, $column, $value) = @_; | | my ($s, $key, $column, $value) = @_; |
| $s = $s->import_db() if ! defined $s->[$DBI]; | | $s = $s->import_db() if ! defined $s->[$DBI]; |
|
| $column = $s->[$NAME][ $s->column_index($column) ]; | | $column = $s->[$QNAME][ $s->column_index($column) ]; |
| my $q1 = "select $column from $s->[$TABLE] where $s->[$KEY] = ?"; | | my $q1 = "select $column from $s->[$QTABLE] where $s->[$QKEY] = ?"; |
| my $q2 = "update $s->[$TABLE] set $column = ? where $s->[$KEY] = ?"; | | my $q2 = "update $s->[$QTABLE] set $column = ? where $s->[$QKEY] = ?"; |
| my $sth1 = $s->[$DBI]->prepare($q1) | | my $sth1 = $s->[$DBI]->prepare($q1) |
| or $s->log_error("%s query (%s) failed: %s", 'inc_field', $q1, $D
BI::errstr) | | or $s->log_error("%s query (%s) failed: %s", 'inc_field', $q1, $D
BI::errstr) |
| and return undef; | | and return undef; |
| my $sth2 = $s->[$DBI]->prepare($q2) | | my $sth2 = $s->[$DBI]->prepare($q2) |
| or $s->log_error("%s query (%s) failed: %s", 'inc_field', $q2, $D
BI::errstr) | | or $s->log_error("%s query (%s) failed: %s", 'inc_field', $q2, $D
BI::errstr) |
| and return undef; | | and return undef; |
| $sth1->execute($key) | | $sth1->execute($key) |
| or $s->log_error("%s query (%s) failed: %s", 'inc_field', $q1, $D
BI::errstr) | | or $s->log_error("%s query (%s) failed: %s", 'inc_field', $q1, $D
BI::errstr) |
| and return undef; | | and return undef; |
| $value += ($sth1->fetchrow_array)[0]; | | $value += ($sth1->fetchrow_array)[0]; |
| | |
| skipping to change at line 940 | | skipping to change at line 1013 |
|---|
| | |
| sub column_exists { | | sub column_exists { |
| my ($s, $column) = @_; | | my ($s, $column) = @_; |
| $s = $s->import_db() if ! defined $s->[$DBI]; | | $s = $s->import_db() if ! defined $s->[$DBI]; |
| return defined($s->[$CONFIG]{COLUMN_INDEX}{lc $column}); | | return defined($s->[$CONFIG]{COLUMN_INDEX}{lc $column}); |
| } | | } |
| | |
| sub field_accessor { | | sub field_accessor { |
| my ($s, $column) = @_; | | my ($s, $column) = @_; |
| $s = $s->import_db() if ! defined $s->[$DBI]; | | $s = $s->import_db() if ! defined $s->[$DBI]; |
|
| $column = $s->[$NAME][ $s->column_index($column) ]; | | $column = $s->[$QNAME][ $s->column_index($column) ]; |
| my $q = "select $column from $s->[$TABLE] where $s->[$KEY] = ?"; | | my $q = "select $column from $s->[$QTABLE] where $s->[$QKEY] = ?"; |
| my $sth = $s->[$DBI]->prepare($q) | | my $sth = $s->[$DBI]->prepare($q) |
| or $s->log_error("field_accessor statement (%s) -- bad result.",
$q) | | or $s->log_error("field_accessor statement (%s) -- bad result.",
$q) |
| and return undef; | | and return undef; |
| #::logDebug("binding sub to $q"); | | #::logDebug("binding sub to $q"); |
| return sub { | | return sub { |
| my ($key) = @_; | | my ($key) = @_; |
| $sth->bind_param(1, $key); | | $sth->bind_param(1, $key); |
| $sth->execute(); | | $sth->execute(); |
| my ($return) = $sth->fetchrow_array(); | | my ($return) = $sth->fetchrow_array(); |
| return $return; | | return $return; |
| | |
| skipping to change at line 988 | | skipping to change at line 1061 |
|---|
| | |
| sub autosequence { | | sub autosequence { |
| my $s = shift; | | my $s = shift; |
| | |
| my $cfg = $s->[$CONFIG]; | | my $cfg = $s->[$CONFIG]; |
| # Like MySQL, get sequence number *after* insert | | # Like MySQL, get sequence number *after* insert |
| return $cfg->{SEQUENCE_VAL} if $cfg->{SEQUENCE_LAST_FUNCTION}; | | return $cfg->{SEQUENCE_VAL} if $cfg->{SEQUENCE_LAST_FUNCTION}; |
| | |
| # Like Oracle or Pg, get it now then return passed value later | | # Like Oracle or Pg, get it now then return passed value later |
| my $q = $cfg->{SEQUENCE_QUERY} || "select nextval('_SEQUENCE_NAME_')"; | | my $q = $cfg->{SEQUENCE_QUERY} || "select nextval('_SEQUENCE_NAME_')"; |
|
| $q =~ s/_SEQUENCE_NAME_/$cfg->{AUTO_SEQUENCE}/g; | | |
| | my $seq_name = $cfg->{AUTO_SEQUENCE}; |
| | my $seq_name_id = $cfg->{QUOTE_IDENTIFIERS} ? $s->[$DBI]->quote_identifie |
| | r($seq_name) : $seq_name; |
| | my $seq_name_v = $s->[$DBI]->quote($seq_name); |
| | $q =~ s/_SEQUENCE_NAME_ID_/$seq_name_id/g; |
| | $q =~ s/_SEQUENCE_NAME_V_/$seq_name_v/g; |
| | $q =~ s/_SEQUENCE_NAME_/$seq_name/g; |
| my $sth = $s->[$DBI]->prepare($q) | | my $sth = $s->[$DBI]->prepare($q) |
| or die ::errmsg('prepare %s: %s', $q, $DBI::errstr); | | or die ::errmsg('prepare %s: %s', $q, $DBI::errstr); |
| $sth->execute() | | $sth->execute() |
| or die ::errmsg('execute %s: %s', $q, $DBI::errstr); | | or die ::errmsg('execute %s: %s', $q, $DBI::errstr); |
| my $k = $sth->fetchrow_arrayref->[0]; | | my $k = $sth->fetchrow_arrayref->[0]; |
| return $k; | | return $k; |
| } | | } |
| | |
| sub add_column { | | sub add_column { |
| my ($s, $column, $def) = @_; | | my ($s, $column, $def) = @_; |
| | |
| skipping to change at line 1050 | | skipping to change at line 1129 |
|---|
| | |
| if($function =~ /^(ALTER_CHANGE)$/ and ! $s->column_exists($column) ) { | | if($function =~ /^(ALTER_CHANGE)$/ and ! $s->column_exists($column) ) { |
| $s->log_error( | | $s->log_error( |
| "Column '%s' doesn't exist in table %s. S
kipping.", | | "Column '%s' doesn't exist in table %s. S
kipping.", |
| $column, | | $column, |
| $s->[$TABLE], | | $s->[$TABLE], |
| ); | | ); |
| return undef; | | return undef; |
| } | | } |
| | |
|
| $template =~ s/\b_BACKUP_\b/"bak_$s->[$TABLE]"/g; | | my $backup = "bak_$s->[$TABLE]"; |
| $template =~ s/\b_TABLE_\b/$s->[$TABLE]/g; | | $backup = $s->[$DBI]->quote_identifier($backup) if $s->[$CONFIG]{QUOTE_ID |
| | ENTIFIERS}; |
| | $column = $s->[$DBI]->quote_identifier($column) if $s->[$CONFIG]{QUOTE_ID |
| | ENTIFIERS}; |
| | |
| | $template =~ s/\b_BACKUP_\b/$backup/g; |
| | $template =~ s/\b_TABLE_\b/$s->[$QTABLE]/g; |
| $template =~ s/\b_COLUMN_\b/$column/g; | | $template =~ s/\b_COLUMN_\b/$column/g; |
| $template =~ s/\b_DEF_\b/$def/g; | | $template =~ s/\b_DEF_\b/$def/g; |
|
| $template =~ s/\$BACKUP\$/"bak_$s->[$TABLE]"/g; | | $template =~ s/\$BACKUP\$/$backup/g; |
| $template =~ s/\$TABLE\$/$s->[$TABLE]/g; | | $template =~ s/\$TABLE\$/$s->[$QTABLE]/g; |
| $template =~ s/\$COLUMN\$/$column/g; | | $template =~ s/\$COLUMN\$/$column/g; |
| $template =~ s/\$DEF\$/$def/g; | | $template =~ s/\$DEF\$/$def/g; |
| | |
| my $rc; | | my $rc; |
| eval { | | eval { |
| $rc = $s->[$DBI]->do($template); | | $rc = $s->[$DBI]->do($template); |
| }; | | }; |
| | |
| if($@) { | | if($@) { |
| $s->log_error( "'%s' failed. Error: %s", $template,); | | $s->log_error( "'%s' failed. Error: %s", $template,); |
| | |
| skipping to change at line 1098 | | skipping to change at line 1181 |
|---|
| my $k = $s->set_row(@ary); | | my $k = $s->set_row(@ary); |
| #::logDebug("cloned, key=$k"); | | #::logDebug("cloned, key=$k"); |
| return $k; | | return $k; |
| } | | } |
| | |
| sub clone_set { | | sub clone_set { |
| my ($s, $col, $old, $new) = @_; | | my ($s, $col, $old, $new) = @_; |
| #::logDebug("called clone_set col=$col old=$old new=$new"); | | #::logDebug("called clone_set col=$col old=$old new=$new"); |
| return unless $s->column_exists($col); | | return unless $s->column_exists($col); |
| my $sel = $s->quote($old, $col); | | my $sel = $s->quote($old, $col); |
|
| my $name = $s->[$CONFIG]{name}; | | my $name = $s->[$QTABLE]; |
| | my $qcol = $s->[$CONFIG]{QUOTE_IDENTIFIERS} ? $s->[$DBI]->quote_identifie |
| | r($col) : $col; |
| my ($ary, $nh, $na) = $s->query("select * from $name where $col = $sel"); | | my ($ary, $nh, $na) = $s->query("select * from $name where $col = $sel"); |
| my $fpos = $nh->{$col} || return undef; | | my $fpos = $nh->{$col} || return undef; |
| $s->config('AUTO_NUMBER', '000001') unless $s->config('AUTO_NUMBER'); | | $s->config('AUTO_NUMBER', '000001') unless $s->config('AUTO_NUMBER'); |
| for(@$ary) { | | for(@$ary) { |
| my $line = $_; | | my $line = $_; |
| $line->[$s->[$CONFIG]{KEY_INDEX}] = ''; | | $line->[$s->[$CONFIG]{KEY_INDEX}] = ''; |
| $line->[$fpos] = $new; | | $line->[$fpos] = $new; |
| my $k = $s->set_row(@$line); | | my $k = $s->set_row(@$line); |
| #::logDebug("cloned, key=$k"); | | #::logDebug("cloned, key=$k"); |
| } | | } |
| | |
| skipping to change at line 1189 | | skipping to change at line 1273 |
|---|
| | |
| $tkey = $s->quote($key, $s->[$KEY]); | | $tkey = $s->quote($key, $s->[$KEY]); |
| #::logDebug("tkey now $tkey"); | | #::logDebug("tkey now $tkey"); |
| | |
| # Better than failing on a bad ref... | | # Better than failing on a bad ref... |
| if(ref $fary ne 'ARRAY') { | | if(ref $fary ne 'ARRAY') { |
| shift; shift; | | shift; shift; |
| $fary = [ @_ ]; | | $fary = [ @_ ]; |
| } | | } |
| | |
|
| | $fary = [map {$s->[$QNAME][$s->[$CONFIG]{COLUMN_INDEX}{lc $_}]} @$fary] i |
| | f $s->[$CONFIG]{QUOTE_IDENTIFIERS}; |
| | |
| my $fstring = join ",", @$fary; | | my $fstring = join ",", @$fary; |
|
| $sql = "SELECT $fstring from $s->[$TABLE] WHERE $s->[$KEY] = $tkey"; | | $sql = "SELECT $fstring from $s->[$QTABLE] WHERE $s->[$QKEY] = $tkey"; |
| | |
| #::logDebug("get_slice query: $sql"); | | #::logDebug("get_slice query: $sql"); |
| #::logDebug("get_slice key/fields:\nkey=$key\n" . ::uneval($fary)); | | #::logDebug("get_slice key/fields:\nkey=$key\n" . ::uneval($fary)); |
| my $sth; | | my $sth; |
| my $ary; | | my $ary; |
| eval { | | eval { |
| $sth = $s->[$DBI]->prepare($sql) | | $sth = $s->[$DBI]->prepare($sql) |
| or die ::errmsg("prepare %s: %s", $sql, $DBI::errstr); | | or die ::errmsg("prepare %s: %s", $sql, $DBI::errstr); |
| $sth->execute(); | | $sth->execute(); |
| }; | | }; |
| | |
| skipping to change at line 1278 | | skipping to change at line 1364 |
|---|
| | |
| for (my $i=0; $i < @$fary; $i++){ | | for (my $i=0; $i < @$fary; $i++){ |
| next unless defined $lcfg->{$fary->[$i]}; | | next unless defined $lcfg->{$fary->[$i]}; |
| | |
| $vary->[$i] = $s->length_exception($fary->[$i], $vary->[$
i]) | | $vary->[$i] = $s->length_exception($fary->[$i], $vary->[$
i]) |
| if length($vary->[$i]) > $lcfg->{$fary->[$i]}{LEN
GTH}; | | if length($vary->[$i]) > $lcfg->{$fary->[$i]}{LEN
GTH}; |
| | |
| } | | } |
| } | | } |
| | |
|
| | $fary = [map {$s->[$QNAME][$s->[$CONFIG]{COLUMN_INDEX}{lc $_}]} @$fary] i |
| | f $s->[$CONFIG]{QUOTE_IDENTIFIERS}; |
| | |
| $tkey = $s->quote($key, $s->[$KEY]) if defined $key; | | $tkey = $s->quote($key, $s->[$KEY]) if defined $key; |
| #::logDebug("tkey now $tkey"); | | #::logDebug("tkey now $tkey"); |
| | |
| my $force_insert = | | my $force_insert = |
| $opt->{dml} eq 'insert'; | | $opt->{dml} eq 'insert'; |
| my $force_update = | | my $force_update = |
| $opt->{dml} eq 'update'; | | $opt->{dml} eq 'update'; |
| | |
| if ( | | if ( |
| $force_update or | | $force_update or |
| !$force_insert and defined $tkey and $s->record_exists($key) | | !$force_insert and defined $tkey and $s->record_exists($key) |
| ) { | | ) { |
| unless (@$fary) { | | unless (@$fary) { |
| # as there are no data columns, we can safely skip the up
date | | # as there are no data columns, we can safely skip the up
date |
| return $key; | | return $key; |
| } | | } |
| my $fstring = join ",", map { "$_=?" } @$fary; | | my $fstring = join ",", map { "$_=?" } @$fary; |
|
| $sql = "update $s->[$TABLE] SET $fstring WHERE $s->[$KEY] = $tkey
"; | | $sql = "update $s->[$QTABLE] SET $fstring WHERE $s->[$QKEY] = $tk
ey"; |
| } | | } |
| else { | | else { |
| my $found; | | my $found; |
| if(! length($key)) { | | if(! length($key)) { |
| $key = $s->autonumber(); | | $key = $s->autonumber(); |
| } | | } |
| for(my $i = 0; $i < @$fary; $i++) { | | for(my $i = 0; $i < @$fary; $i++) { |
|
| next unless $fary->[$i] eq $s->[$KEY]; | | next unless $fary->[$i] eq $s->[$QKEY]; |
| splice @$fary, $i, 1; | | splice @$fary, $i, 1; |
| splice @$vary, $i, 1; | | splice @$vary, $i, 1; |
| last; | | last; |
| } | | } |
|
| unshift @$fary, $s->[$KEY]; | | unshift @$fary, $s->[$QKEY]; |
| unshift @$vary, $key; | | unshift @$vary, $key; |
| my $fstring = join ",", @$fary; | | my $fstring = join ",", @$fary; |
| my $vstring = join ",", map {"?"} @$vary; | | my $vstring = join ",", map {"?"} @$vary; |
| $sql = "insert into $s->[$TABLE] ($fstring) VALUES ($vstring)"; | | $sql = "insert into $s->[$TABLE] ($fstring) VALUES ($vstring)"; |
| } | | } |
| | |
| #::logDebug("set_slice query: $sql"); | | #::logDebug("set_slice query: $sql"); |
| #::logDebug("set_slice key/fields/values:\nkey=$key\n" . ::uneval($fary, $vary))
; | | #::logDebug("set_slice key/fields/values:\nkey=$key\n" . ::uneval($fary, $vary))
; |
| | |
| my $val; | | my $val; |
| | |
| skipping to change at line 1370 | | skipping to change at line 1458 |
|---|
| my $val; | | my $val; |
| | |
| if(scalar @fields == 1) { | | if(scalar @fields == 1) { |
| return if $cfg->{AUTO_SEQUENCE}; | | return if $cfg->{AUTO_SEQUENCE}; |
| $fields[0] = $s->autonumber() | | $fields[0] = $s->autonumber() |
| if ! length($fields[0]); | | if ! length($fields[0]); |
| $val = $s->quote($fields[0], $s->[$KEY]); | | $val = $s->quote($fields[0], $s->[$KEY]); |
| my $key_string; | | my $key_string; |
| my $val_string; | | my $val_string; |
| my $ary; | | my $ary; |
|
| my @flds = $s->[$KEY]; | | my @flds = $s->[$QKEY]; |
| my @vals = $val; | | my @vals = $val; |
| if($cfg->{_Default_ary} || $cfg->{_Default_session_ary}) { | | if($cfg->{_Default_ary} || $cfg->{_Default_session_ary}) { |
| my $ary = $cfg->{_Default_ary} || []; | | my $ary = $cfg->{_Default_ary} || []; |
| my $sary = $cfg->{_Default_session_ary} || []; | | my $sary = $cfg->{_Default_session_ary} || []; |
| my $max = $#$ary > $#$sary ? $#$ary : $#$sary; | | my $max = $#$ary > $#$sary ? $#$ary : $#$sary; |
| for (my $i = 0; $i <= $max; $i++) { | | for (my $i = 0; $i <= $max; $i++) { |
| if($sary->[$i]) { | | if($sary->[$i]) { |
|
| push @flds, $s->[$NAME][$i]; | | push @flds, $s->[$QNAME][$i]; |
| push @vals, $sary->[$i]->($s); | | push @vals, $sary->[$i]->($s); |
| next; | | next; |
| } | | } |
| next unless defined $ary->[$i]; | | next unless defined $ary->[$i]; |
|
| push @flds, $s->[$NAME][$i]; | | push @flds, $s->[$QNAME][$i]; |
| push @vals, $ary->[$i]; | | push @vals, $ary->[$i]; |
| } | | } |
| $key_string = join ",", @flds; | | $key_string = join ",", @flds; |
| $val_string = join ",", @vals; | | $val_string = join ",", @vals; |
| } | | } |
| else { | | else { |
|
| $key_string = $s->[$KEY]; | | $key_string = $s->[$QKEY]; |
| $val_string = $val; | | $val_string = $val; |
| } | | } |
| #::logDebug("def_ary query will be: insert into $s->[$TABLE] ($key_string) VALUE
S ($val_string)"); | | #::logDebug("def_ary query will be: insert into $s->[$TABLE] ($key_string) VALUE
S ($val_string)"); |
| eval { | | eval { |
|
| $s->[$DBI]->do("delete from $s->[$TABLE] where $s->[$KEY]
= $val") | | $s->[$DBI]->do("delete from $s->[$QTABLE] where $s->[$QKE
Y] = $val") |
| if $s->record_exists(); | | if $s->record_exists(); |
|
| $s->[$DBI]->do("insert into $s->[$TABLE] ($key_string) VA
LUES ($val_string)"); | | $s->[$DBI]->do("insert into $s->[$QTABLE] ($key_string) V
ALUES ($val_string)"); |
| }; | | }; |
| if($@) { | | if($@) { |
| my $caller = caller(); | | my $caller = caller(); |
| $s->log_error( | | $s->log_error( |
| "%s error as called by %s: %s\nfields=%s\nvalues=
%s", | | "%s error as called by %s: %s\nfields=%s\nvalues=
%s", |
| 'set_row', | | 'set_row', |
| $caller, | | $caller, |
| $@, | | $@, |
| $key_string, | | $key_string, |
| $val_string, | | $val_string, |
| | |
| skipping to change at line 1433 | | skipping to change at line 1521 |
|---|
| if(! length($fields[$ki]) ) { | | if(! length($fields[$ki]) ) { |
| $fields[$ki] = $s->autonumber(); | | $fields[$ki] = $s->autonumber(); |
| } | | } |
| elsif ( ! $s->[$CONFIG]{Clean_start} | | elsif ( ! $s->[$CONFIG]{Clean_start} |
| and defined $fields[$ki] | | and defined $fields[$ki] |
| and $s->record_exists($fields[$ki]) | | and $s->record_exists($fields[$ki]) |
| ) | | ) |
| { | | { |
| eval { | | eval { |
| $val = $s->quote($fields[$ki], $s->[$KEY]); | | $val = $s->quote($fields[$ki], $s->[$KEY]); |
|
| $s->[$DBI]->do("delete from $s->[$TABLE] where $s->[$KEY]
= $val"); | | $s->[$DBI]->do("delete from $s->[$QTABLE] where $s->[$QKE
Y] = $val"); |
| }; | | }; |
| } | | } |
| | |
| #::logDebug("set_row fields='" . join(',', @fields) . "'" ); | | #::logDebug("set_row fields='" . join(',', @fields) . "'" ); |
| if(! $cfg->{_Insert_h}) { | | if(! $cfg->{_Insert_h}) { |
| my (@ins_mark); | | my (@ins_mark); |
| my $i = 0; | | my $i = 0; |
| for(@{$s->[$NAME]}) { | | for(@{$s->[$NAME]}) { |
| push @ins_mark, '?'; | | push @ins_mark, '?'; |
| $i++; | | $i++; |
| } | | } |
| my $fstring = ''; | | my $fstring = ''; |
| | |
| my $ins_string = join ", ", @ins_mark; | | my $ins_string = join ", ", @ins_mark; |
|
| my $query = "INSERT INTO $s->[$TABLE]$fstring VALUES ($ins_string
)"; | | my $query = "INSERT INTO $s->[$QTABLE]$fstring VALUES ($ins_strin
g)"; |
| #::logDebug("set_row query=$query"); | | #::logDebug("set_row query=$query"); |
| $cfg->{_Insert_h} = $s->[$DBI]->prepare($query) | | $cfg->{_Insert_h} = $s->[$DBI]->prepare($query) |
| or die $s->log_error( | | or die $s->log_error( |
| "%s error on %s: $DBI::er
rstr", | | "%s error on %s: $DBI::er
rstr", |
| 'set_row', | | 'set_row', |
| $query, | | $query, |
| $DBI::errstr, | | $DBI::errstr, |
| ); | | ); |
| } | | } |
| | |
| | |
| skipping to change at line 1487 | | skipping to change at line 1575 |
|---|
| my $s = shift; | | my $s = shift; |
| my $passed = shift; | | my $passed = shift; |
| my $cfg = $s->[$CONFIG]; | | my $cfg = $s->[$CONFIG]; |
| my $q = $cfg->{SEQUENCE_LAST_FUNCTION}; | | my $q = $cfg->{SEQUENCE_LAST_FUNCTION}; |
| | |
| if (! $q) { | | if (! $q) { |
| return $passed if $passed; | | return $passed if $passed; |
| $q = $cfg->{SEQUENCE_VALUE_FUNCTION}; | | $q = $cfg->{SEQUENCE_VALUE_FUNCTION}; |
| } | | } |
| | |
|
| $q =~ s/_SEQUENCE_NAME_/$s->[$CONFIG]{AUTO_SEQUENCE}/g; | | my $seq_name = $cfg->{AUTO_SEQUENCE}; |
| $q =~ s/_TABLE_/$s->[$TABLE]/g; | | my $seq_name_id = $cfg->{QUOTE_IDENTIFIERS} ? $s->[$DBI]->quote_identifie |
| $q =~ s/_COLUMN_/$s->[$KEY]/g; | | r($seq_name) : $seq_name; |
| | my $seq_name_v = $s->[$DBI]->quote($seq_name); |
| | $q =~ s/_SEQUENCE_NAME_ID_/$seq_name_id/g; |
| | $q =~ s/_SEQUENCE_NAME_V_/$seq_name_v/g; |
| | $q =~ s/_SEQUENCE_NAME_/$seq_name/g; |
| | $q =~ s/_TABLE_/$s->[$QTABLE]/g; |
| | $q =~ s/_COLUMN_/$s->[$QKEY]/g; |
| my $sth = $s->[$DBI]->prepare($q) | | my $sth = $s->[$DBI]->prepare($q) |
| or die ::errmsg("prepare %s: %s", $q, $DBI::errstr); | | or die ::errmsg("prepare %s: %s", $q, $DBI::errstr); |
| my $rc = $sth->execute() | | my $rc = $sth->execute() |
| or die ::errmsg("execute %s: %s", $q, $DBI::errstr); | | or die ::errmsg("execute %s: %s", $q, $DBI::errstr); |
| my $aref = $sth->fetchrow_arrayref(); | | my $aref = $sth->fetchrow_arrayref(); |
| | |
| if (! $aref) { | | if (! $aref) { |
| die ::errmsg("missing return value from %s: %s", $q, $sth->err())
; | | die ::errmsg("missing return value from %s: %s", $q, $sth->err())
; |
| } | | } |
| elsif ($aref->[0] !~ /^\d+$/) { | | elsif ($aref->[0] !~ /^\d+$/) { |
| die ::errmsg("bogus return value from %s: %s", $q, $aref->[0]); | | die ::errmsg("bogus return value from %s: %s", $q, $aref->[0]); |
| } | | } |
| return $aref->[0]; | | return $aref->[0]; |
| } | | } |
| | |
| sub row { | | sub row { |
| my ($s, $key) = @_; | | my ($s, $key) = @_; |
| $s = $s->import_db() if ! defined $s->[$DBI]; | | $s = $s->import_db() if ! defined $s->[$DBI]; |
|
| my $q = "select * from $s->[$TABLE] where $s->[$KEY] = ?"; | | my $q = "select * from $s->[$QTABLE] where $s->[$QKEY] = ?"; |
| my $sth = $s->[$DBI]->prepare($q) | | my $sth = $s->[$DBI]->prepare($q) |
| or $s->log_error("%s prepare error for %s: %s", 'row', $q, $DBI::
errstr) | | or $s->log_error("%s prepare error for %s: %s", 'row', $q, $DBI::
errstr) |
| and return undef; | | and return undef; |
| $sth->execute($key) | | $sth->execute($key) |
| or $s->log_error("%s execute error for %s: %s", 'row', $q, $DBI::
errstr) | | or $s->log_error("%s execute error for %s: %s", 'row', $q, $DBI::
errstr) |
| and return undef; | | and return undef; |
| return @{ $sth->fetchrow_arrayref() || [] }; | | return @{ $sth->fetchrow_arrayref() || [] }; |
| } | | } |
| | |
| sub foreign_hash { | | sub foreign_hash { |
| my ($s, $col, $key) = @_; | | my ($s, $col, $key) = @_; |
|
| $s = $s->import_db() if ! defined $s->[$DBI]; | | $s = $s->import_db() if ! defined $s->[$DBI]; |
| my $q = "select * from $s->[$TABLE] where $col = ?"; | | $col = $s->[$DBI]->quote_identifier($col) if $s->[$CONFIG]{QUOTE_IDENTIFIERS |
| | }; |
| | my $q = "select * from $s->[$QTABLE] where $col = ?"; |
| my $sth = $s->[$DBI]->prepare($q) | | my $sth = $s->[$DBI]->prepare($q) |
| or $s->log_error("%s prepare error for %s: %s", 'row_hash', $q, $
DBI::errstr) | | or $s->log_error("%s prepare error for %s: %s", 'row_hash', $q, $
DBI::errstr) |
| and return undef; | | and return undef; |
| $sth->execute($key) | | $sth->execute($key) |
| or $s->log_error("%s execute error for %s: %s", 'row_hash', $q, $
DBI::errstr) | | or $s->log_error("%s execute error for %s: %s", 'row_hash', $q, $
DBI::errstr) |
| and return undef; | | and return undef; |
| | |
| return $sth->fetchrow_hashref() | | return $sth->fetchrow_hashref() |
| unless $s->[$TYPE]; | | unless $s->[$TYPE]; |
| my $ref; | | my $ref; |
| | |
| skipping to change at line 1555 | | skipping to change at line 1649 |
|---|
| my ($k, $v); | | my ($k, $v); |
| while ( ($k, $v) = each %{ $s->[$CONFIG]{FIELD_ALIAS} } ) { | | while ( ($k, $v) = each %{ $s->[$CONFIG]{FIELD_ALIAS} } ) { |
| $ref->{$v} = $ref->{$k}; | | $ref->{$v} = $ref->{$k}; |
| } | | } |
| return $ref; | | return $ref; |
| } | | } |
| | |
| sub row_hash { | | sub row_hash { |
| my ($s, $key) = @_; | | my ($s, $key) = @_; |
| $s = $s->import_db() if ! defined $s->[$DBI]; | | $s = $s->import_db() if ! defined $s->[$DBI]; |
|
| my $q = "select * from $s->[$TABLE] where $s->[$KEY] = ?"; | | my $q = "select * from $s->[$QTABLE] where $s->[$QKEY] = ?"; |
| my $sth = $s->[$DBI]->prepare($q) | | my $sth = $s->[$DBI]->prepare($q) |
| or $s->log_error("%s prepare error for %s: %s", 'row_hash', $q, $
DBI::errstr) | | or $s->log_error("%s prepare error for %s: %s", 'row_hash', $q, $
DBI::errstr) |
| and return undef; | | and return undef; |
| $sth->execute($key) | | $sth->execute($key) |
| or $s->log_error("%s execute error for %s: %s", 'row_hash', $q, $
DBI::errstr) | | or $s->log_error("%s execute error for %s: %s", 'row_hash', $q, $
DBI::errstr) |
| and return undef; | | and return undef; |
| | |
| return $sth->fetchrow_hashref() | | return $sth->fetchrow_hashref() |
| unless $s->[$TYPE]; | | unless $s->[$TYPE]; |
| my $ref; | | my $ref; |
| | |
| skipping to change at line 1588 | | skipping to change at line 1682 |
|---|
| return $ref unless $s->[$CONFIG]{FIELD_ALIAS}; | | return $ref unless $s->[$CONFIG]{FIELD_ALIAS}; |
| my ($k, $v); | | my ($k, $v); |
| while ( ($k, $v) = each %{ $s->[$CONFIG]{FIELD_ALIAS} } ) { | | while ( ($k, $v) = each %{ $s->[$CONFIG]{FIELD_ALIAS} } ) { |
| $ref->{$v} = $ref->{$k}; | | $ref->{$v} = $ref->{$k}; |
| } | | } |
| return $ref; | | return $ref; |
| } | | } |
| | |
| sub field_settor { | | sub field_settor { |
| my ($s, $column) = @_; | | my ($s, $column) = @_; |
|
| $s = $s->import_db() if ! defined $s->[$DBI]; | | $s = $s->import_db() if ! defined $s->[$DBI]; |
| | $column = $s->[$DBI]->quote_identifier($column) if $s->[$CONFIG]{QUOTE_IDENT |
| | IFIERS}; |
| my $q = "update $s->[$TABLE] SET $column = ? where $s->[$KEY] = ?"; | | my $q = "update $s->[$TABLE] SET $column = ? where $s->[$KEY] = ?"; |
| my $sth = $s->[$DBI]->prepare($q) | | my $sth = $s->[$DBI]->prepare($q) |
| or $s->log_error("Unable to prepare query for field_settor: %s",
$q) | | or $s->log_error("Unable to prepare query for field_settor: %s",
$q) |
| and return undef; | | and return undef; |
| return sub { | | return sub { |
| my ($key, $value) = @_; | | my ($key, $value) = @_; |
| $sth->execute($value, $key); | | $sth->execute($value, $key); |
| }; | | }; |
| } | | } |
| | |
| sub foreign { | | sub foreign { |
| my ($s, $key, $foreign) = @_; | | my ($s, $key, $foreign) = @_; |
| return single($s, $s->[$KEY], $foreign) if ref($foreign); | | return single($s, $s->[$KEY], $foreign) if ref($foreign); |
| $s = $s->import_db() if ! defined $s->[$DBI]; | | $s = $s->import_db() if ! defined $s->[$DBI]; |
| my $idx; | | my $idx; |
|
| | my $qforeign; |
| if( $s->[$TYPE] and $idx = $s->column_index($foreign) ) { | | if( $s->[$TYPE] and $idx = $s->column_index($foreign) ) { |
| $foreign = $s->[$NAME][$idx]; | | $foreign = $s->[$NAME][$idx]; |
|
| | $qforeign = $s->[$QNAME][$idx]; |
| | } |
| | else { |
| | $qforeign = $s->[$CONFIG]{QUOTE_IDENTIFIERS} ? $s->[$DBI]->quote_iden |
| | tifier($foreign) : $foreign; |
| } | | } |
| $key = $s->[$DBI]->quote($key) | | $key = $s->[$DBI]->quote($key) |
| unless exists $s->[$CONFIG]{NUMERIC}{$foreign}; | | unless exists $s->[$CONFIG]{NUMERIC}{$foreign}; |
|
| my $query = "select $s->[$KEY] from $s->[$TABLE] where $foreign = $key"; | | my $query = "select $s->[$QKEY] from $s->[$QTABLE] where $qforeign = $key
"; |
| #::logDebug("DBI field: key=$key query=$query"); | | #::logDebug("DBI field: key=$key query=$query"); |
| my $sth; | | my $sth; |
| eval { | | eval { |
| $sth = $s->[$DBI]->prepare($query); | | $sth = $s->[$DBI]->prepare($query); |
| $sth->execute(); | | $sth->execute(); |
| }; | | }; |
| return '' if $@; | | return '' if $@; |
| my $data = ($sth->fetchrow_array())[0]; | | my $data = ($sth->fetchrow_array())[0]; |
| return '' unless $data =~ /\S/; | | return '' unless $data =~ /\S/; |
| return $data; | | return $data; |
| } | | } |
| | |
| sub single { | | sub single { |
| my ($s, $field, $qhash) = @_; | | my ($s, $field, $qhash) = @_; |
| $s = $s->import_db() if ! defined $s->[$DBI]; | | $s = $s->import_db() if ! defined $s->[$DBI]; |
|
| | $field = $s->[$DBI]->quote_identifier($field) if $s->[$CONFIG]{QUOTE_IDEN
TIFIERS}; |
| my $idx; | | my $idx; |
| | |
|
| my $q = "select $field from $s->[$TABLE] WHERE "; | | my $q = "select $field from $s->[$QTABLE] WHERE "; |
| | |
| my @fields; | | my @fields; |
| my @dats; | | my @dats; |
| | |
| if(ref($qhash) eq 'ARRAY') { | | if(ref($qhash) eq 'ARRAY') { |
| for(@$qhash) { | | for(@$qhash) { |
| s/(\w+)\s*=\s*// | | s/(\w+)\s*=\s*// |
| or next; | | or next; |
|
| push @fields, "$1 = ?"; | | my $fn = $s->[$CONFIG]{QUOTE_IDENTIFIERS} ? $s->[$DBI]->q |
| | uote_identifier($1) : $1; |
| | push @fields, "$fn = ?"; |
| push @dats, $_; | | push @dats, $_; |
| } | | } |
| } | | } |
| elsif(ref($qhash) eq 'HASH') { | | elsif(ref($qhash) eq 'HASH') { |
| while(my ($k,$v) = each %$qhash) { | | while(my ($k,$v) = each %$qhash) { |
|
| push @fields, "$k = ?"; | | my $fn = $s->[$CONFIG]{QUOTE_IDENTIFIERS} ? $s->[$DBI]->q |
| | uote_identifier($k) : $k; |
| | push @fields, "$fn = ?"; |
| push @dats, $v; | | push @dats, $v; |
| } | | } |
| } | | } |
| else { | | else { |
| $s->log_error("Bad single data query parameter type: %s", ref($qh
ash)); | | $s->log_error("Bad single data query parameter type: %s", ref($qh
ash)); |
| return undef; | | return undef; |
| } | | } |
| | |
| $q .= join ' AND ', @fields; | | $q .= join ' AND ', @fields; |
| #::logDebug("DBI single: query=$q"); | | #::logDebug("DBI single: query=$q"); |
| | |
| skipping to change at line 1671 | | skipping to change at line 1774 |
|---|
| return $data; | | return $data; |
| } | | } |
| | |
| sub field { | | sub field { |
| my ($s, $key, $column) = @_; | | my ($s, $key, $column) = @_; |
| $s = $s->import_db() if ! defined $s->[$DBI]; | | $s = $s->import_db() if ! defined $s->[$DBI]; |
| $key = $s->[$DBI]->quote($key) | | $key = $s->[$DBI]->quote($key) |
| unless exists $s->[$CONFIG]{NUMERIC}{$s->[$KEY]}; | | unless exists $s->[$CONFIG]{NUMERIC}{$s->[$KEY]}; |
| my $idx; | | my $idx; |
| if( $s->[$TYPE] and $idx = $s->column_index($column) ) { | | if( $s->[$TYPE] and $idx = $s->column_index($column) ) { |
|
| $column = $s->[$NAME][$idx]; | | $column = $s->[$QNAME][$idx]; |
| } | | } |
|
| my $query = "select $column from $s->[$TABLE] where $s->[$KEY] = $key"; | | else { |
| | $column = $s->[$DBI]->quote_identifier($column) if $s->[$CONFIG]{QUOT |
| | E_IDENTIFIERS}; |
| | } |
| | my $query = "select $column from $s->[$QTABLE] where $s->[$QKEY] = $key"; |
| #::logDebug("DBI field: key=$key column=$column query=$query"); | | #::logDebug("DBI field: key=$key column=$column query=$query"); |
| my $sth; | | my $sth; |
| eval { | | eval { |
| $sth = $s->[$DBI]->prepare($query); | | $sth = $s->[$DBI]->prepare($query); |
| $sth->execute(); | | $sth->execute(); |
| }; | | }; |
| return '' if $@; | | return '' if $@; |
| my $data = ($sth->fetchrow_array())[0]; | | my $data = ($sth->fetchrow_array())[0]; |
| return '' unless $data =~ /\S/; | | return '' unless $data =~ /\S/; |
| $data; | | $data; |
| | |
| skipping to change at line 1714 | | skipping to change at line 1820 |
|---|
| | |
| $value = $s->length_exception($column, $value); | | $value = $s->length_exception($column, $value); |
| } | | } |
| | |
| $key = $s->autonumber() if ! length($key); | | $key = $s->autonumber() if ! length($key); |
| | |
| undef $value if $value eq '' and exists $s->[$CONFIG]{PREFER_NULL}{$colum
n}; | | undef $value if $value eq '' and exists $s->[$CONFIG]{PREFER_NULL}{$colum
n}; |
| | |
| my $rawkey = $key; | | my $rawkey = $key; |
| my $rawval = $value; | | my $rawval = $value; |
|
| | $column = $s->[$DBI]->quote_identifier($column) if $s->[$CONFIG]{QUOTE_ID
ENTIFIERS}; |
| | |
| my $q; | | my $q; |
| if(! $s->record_exists($rawkey)) { | | if(! $s->record_exists($rawkey)) { |
| if( $s->[$CONFIG]{AUTO_SEQUENCE} ) { | | if( $s->[$CONFIG]{AUTO_SEQUENCE} ) { |
| $key = 0 if ! $key; | | $key = 0 if ! $key; |
|
| $q = qq{INSERT INTO $s->[$TABLE] ($s->[$KEY], $column) VA
LUES (?,?)}; | | $q = qq{INSERT INTO $s->[$QTABLE] ($s->[$QKEY], $column)
VALUES (?,?)}; |
| } | | } |
| else { | | else { |
| #::logDebug("creating key '$rawkey' in table $s->[$TABLE]"); | | #::logDebug("creating key '$rawkey' in table $s->[$TABLE]"); |
| $s->set_row($key); | | $s->set_row($key); |
| } | | } |
| } | | } |
| | |
| my @args; | | my @args; |
| if(!$q) { | | if(!$q) { |
|
| $q = qq{update $s->[$TABLE] SET $column = ? where $s->[$KEY] = ?}
; | | $q = qq{update $s->[$QTABLE] SET $column = ? where $s->[$QKEY] =
?}; |
| @args = ($value, $key); | | @args = ($value, $key); |
| } | | } |
| else { | | else { |
| @args = ($key, $value); | | @args = ($key, $value); |
| } | | } |
| my $sth = $s->[$DBI]->prepare($q) | | my $sth = $s->[$DBI]->prepare($q) |
| or $s->log_error("%s prepare error for %s: %s", 'set_field', $q,
$DBI::errstr) | | or $s->log_error("%s prepare error for %s: %s", 'set_field', $q,
$DBI::errstr) |
| and return undef; | | and return undef; |
| $sth->execute(@args) | | $sth->execute(@args) |
| or $s->log_error("%s execute error for %s: %s", 'set_field', $q,
$DBI::errstr) | | or $s->log_error("%s execute error for %s: %s", 'set_field', $q,
$DBI::errstr) |
| | |
| skipping to change at line 1764 | | skipping to change at line 1871 |
|---|
| my ($s, $key) = @_; | | my ($s, $key) = @_; |
| $s = $s->import_db() if ! defined $s->[$DBI]; | | $s = $s->import_db() if ! defined $s->[$DBI]; |
| my $query; | | my $query; |
| | |
| # Does any SQL allow empty key? | | # Does any SQL allow empty key? |
| return '' if ! length($key) and ! $s->[$CONFIG]{ALLOW_EMPTY_KEY}; | | return '' if ! length($key) and ! $s->[$CONFIG]{ALLOW_EMPTY_KEY}; |
| | |
| $query = $s->[$CONFIG]{Exists_handle} | | $query = $s->[$CONFIG]{Exists_handle} |
| or | | or |
| $query = $s->[$DBI]->prepare( | | $query = $s->[$DBI]->prepare( |
|
| "select $s->[$KEY] from $s->[$TABLE] where $s->[$
KEY] = ?" | | "select $s->[$QKEY] from $s->[$QTABLE] where $s->
[$QKEY] = ?" |
| ) | | ) |
| and | | and |
| $s->[$CONFIG]{Exists_handle} = $query; | | $s->[$CONFIG]{Exists_handle} = $query; |
| my $status; | | my $status; |
| eval { | | eval { |
| $status = defined $s->[$DBI]->selectrow_array($query, undef, $key); | | $status = defined $s->[$DBI]->selectrow_array($query, undef, $key); |
| }; | | }; |
| return undef if $@; | | return undef if $@; |
| return $status; | | return $status; |
| } | | } |
| | |
| skipping to change at line 1791 | | skipping to change at line 1898 |
|---|
| $s->log_error("Attempt to delete record '%s' from read-only datab
ase %s", | | $s->log_error("Attempt to delete record '%s' from read-only datab
ase %s", |
| $key, | | $key, |
| $s->[$CONFIG]{name}, | | $s->[$CONFIG]{name}, |
| ); | | ); |
| return undef; | | return undef; |
| } | | } |
| | |
| ## Rely on DBI to quote | | ## Rely on DBI to quote |
| $key = $s->[$DBI]->quote($key, $s->[$KEY]); | | $key = $s->[$DBI]->quote($key, $s->[$KEY]); |
| | |
|
| $s->[$DBI]->do("delete from $s->[$TABLE] where $s->[$KEY] = $key"); | | $s->[$DBI]->do("delete from $s->[$QTABLE] where $s->[$QKEY] = $key"); |
| } | | } |
| | |
| sub fields_index { | | sub fields_index { |
| my($fields, $config, $dbh) = @_; | | my($fields, $config, $dbh) = @_; |
| my %idx; | | my %idx; |
| my $alias = $config->{FIELD_ALIAS} || {}; | | my $alias = $config->{FIELD_ALIAS} || {}; |
| my $fc = scalar @$fields; | | my $fc = scalar @$fields; |
| for( my $i = 0; $i < $fc; $i++) { | | for( my $i = 0; $i < $fc; $i++) { |
| $idx{lc $fields->[$i]} = $i; | | $idx{lc $fields->[$i]} = $i; |
| next unless defined $alias->{lc $fields->[$i]}; | | next unless defined $alias->{lc $fields->[$i]}; |
| | |
| skipping to change at line 1854 | | skipping to change at line 1961 |
|---|
| $config->{_Default_session_ary} = $def_session_ary; | | $config->{_Default_session_ary} = $def_session_ary; |
| } | | } |
| return \%idx; | | return \%idx; |
| } | | } |
| | |
| sub list_fields { | | sub list_fields { |
| my($db, $name, $config) = @_; | | my($db, $name, $config) = @_; |
| my @fld; | | my @fld; |
| | |
| my $q = $config->{LIST_FIELDS_QUERY} || "SELECT * FROM _TABLE_ WHERE 2 =
1"; | | my $q = $config->{LIST_FIELDS_QUERY} || "SELECT * FROM _TABLE_ WHERE 2 =
1"; |
|
| | #::logGlobal("list_fields() 1: name=$name q=$q"); |
| | $name = $db->quote_identifier($name) if $config->{QUOTE_IDENTIFIERS}; |
| | |
| | # This is a bit of a hack since LIST_FIELDS_QUERY for mysql includes |
| | # the backticks around the table name already and we can't break BC |
| | # with catalogs that don't have QUOTE_IDENTIFIERS set. |
| | $q =~ s/\B`_TABLE_`\B/$name/g if $config->{QUOTE_IDENTIFIERS}; |
| $q =~ s/\b_TABLE_\b/$name/g; | | $q =~ s/\b_TABLE_\b/$name/g; |
|
| | #::logGlobal("list_fields() 2: name=$name q=$q"); |
| | |
| my $sth = $db->prepare($q) | | my $sth = $db->prepare($q) |
| or die ::errmsg("%s prepare on %s: %s", 'list_fields', $name, $DB
I::errstr); | | or die ::errmsg("%s prepare on %s: %s", 'list_fields', $name, $DB
I::errstr); |
| | |
| # Wish we didn't have to do this, but we cache the columns | | # Wish we didn't have to do this, but we cache the columns |
| $sth->execute() | | $sth->execute() |
| or die ::errmsg("%s execute on %s: %s", 'list_fields', $name, $DB
I::errstr); | | or die ::errmsg("%s execute on %s: %s", 'list_fields', $name, $DB
I::errstr); |
| | |
| if($config and $config->{NAME_REQUIRES_FETCH}) { | | if($config and $config->{NAME_REQUIRES_FETCH}) { |
| $sth->fetch(); | | $sth->fetch(); |
| | |
| skipping to change at line 1895 | | skipping to change at line 2010 |
|---|
| return \@fld; | | return \@fld; |
| } | | } |
| | |
| sub touch { | | sub touch { |
| return '' | | return '' |
| } | | } |
| | |
| sub sort_each { | | sub sort_each { |
| my($s, $sort_field, $sort_option) = @_; | | my($s, $sort_field, $sort_option) = @_; |
| if(length $sort_field) { | | if(length $sort_field) { |
|
| | $s = $s->import_db() if ! defined $s->[$DBI]; |
| | $sort_field = $s->[$DBI]->quote_identifier($sort_field) if $s->[$CONF |
| | IG]{QUOTE_IDENTIFIERS}; |
| $sort_field .= " DESC" if $sort_option =~ /r/; | | $sort_field .= " DESC" if $sort_option =~ /r/; |
| $s->[$CONFIG]{Export_order} = " ORDER BY $sort_field" | | $s->[$CONFIG]{Export_order} = " ORDER BY $sort_field" |
| } | | } |
| } | | } |
| | |
| *each_sorted = \&each_record; | | *each_sorted = \&each_record; |
| | |
| # Now supported, including qualification | | # Now supported, including qualification |
| sub each_record { | | sub each_record { |
| my $s = shift; | | my $s = shift; |
| $s = $s->import_db() if ! defined $s->[$DBI]; | | $s = $s->import_db() if ! defined $s->[$DBI]; |
| my ($table, $db, $each); | | my ($table, $db, $each); |
| unless(defined $s->[$EACH]) { | | unless(defined $s->[$EACH]) { |
| my $qual = shift || ''; | | my $qual = shift || ''; |
| $qual .= $s->[$CONFIG]{Export_order} | | $qual .= $s->[$CONFIG]{Export_order} |
| if $s->[$CONFIG]{Export_order}; | | if $s->[$CONFIG]{Export_order}; |
|
| ($table, $db, $each) = @{$s}[$TABLE,$DBI,$EACH]; | | ($table, $db, $each) = @{$s}[$QTABLE,$DBI,$EACH]; |
| my $query = $db->prepare("select * from $table $qual") | | my $query = $db->prepare("select * from $table $qual") |
| or die $s->log_error('prepare'); | | or die $s->log_error('prepare'); |
| $query->execute() | | $query->execute() |
| or die $s->log_error('execute'); | | or die $s->log_error('execute'); |
| my $idx = $s->[$CONFIG]{KEY_INDEX}; | | my $idx = $s->[$CONFIG]{KEY_INDEX}; |
| $each = sub { | | $each = sub { |
| my $ref = $query->fetchrow_arrayref() | | my $ref = $query->fetchrow_arrayref() |
| or return undef; | | or return undef; |
| return ($ref->[$idx], $ref); | | return ($ref->[$idx], $ref); |
| }; | | }; |
|
| push @$s, $each; | | $s->[$EACH] = $each; |
| } | | } |
| my ($key, $return) = $s->[$EACH]->(); | | my ($key, $return) = $s->[$EACH]->(); |
| if(! defined $key) { | | if(! defined $key) { |
|
| pop @$s; | | undef $s->[$EACH]; |
| delete $s->[$CONFIG]{Export_order}; | | delete $s->[$CONFIG]{Export_order}; |
| return (); | | return (); |
| } | | } |
| return ($key, @$return); | | return ($key, @$return); |
| } | | } |
| | |
| # Now supported, including qualification | | # Now supported, including qualification |
| sub each_nokey { | | sub each_nokey { |
| my $s = shift; | | my $s = shift; |
| $s = $s->import_db() if ! defined $s->[$DBI]; | | $s = $s->import_db() if ! defined $s->[$DBI]; |
|
| my ($table, $db, $each); | | my ($table, $qtable, $db, $each); |
| unless(defined $s->[$EACH]) { | | unless(defined $s->[$EACH]) { |
| my $qual = shift || ''; | | my $qual = shift || ''; |
| $qual .= $s->[$CONFIG]{Export_order} | | $qual .= $s->[$CONFIG]{Export_order} |
| if $s->[$CONFIG]{Export_order}; | | if $s->[$CONFIG]{Export_order}; |
|
| ($table, $db, $each) = @{$s}[$TABLE,$DBI,$EACH]; | | ($table, $qtable, $db, $each) = @{$s}[$TABLE,$QTABLE,$DBI,$EACH]; |
| my $restrict; | | my $restrict; |
| if($restrict = $Vend::Cfg->{TableRestrict}{$table} | | if($restrict = $Vend::Cfg->{TableRestrict}{$table} |
| and ( | | and ( |
| ! defined $Global::SuperUserFunction | | ! defined $Global::SuperUserFunction |
| or | | or |
| ! $Global::SuperUserFunction->() | | ! $Global::SuperUserFunction->() |
| ) | | ) |
| ) { | | ) { |
| $qual = $qual ? "$qual AND " : 'WHERE '; | | $qual = $qual ? "$qual AND " : 'WHERE '; |
| my ($rfield, $rsession) = split /\s*=\s*/, $restrict; | | my ($rfield, $rsession) = split /\s*=\s*/, $restrict; |
|
| | $rfield = $s->[$DBI]->quote_identifier($rfield) if $s->[$
CONFIG]{QUOTE_IDENTIFIERS}; |
| $qual .= "$rfield = '$Vend::Session->{$rsession}'"; | | $qual .= "$rfield = '$Vend::Session->{$rsession}'"; |
| } | | } |
|
| my $query = $db->prepare("select * from $table " . ($qual || '')
) | | my $query = $db->prepare("select * from $qtable " . ($qual || '')
) |
| or die $s->log_error('prepare'); | | or die $s->log_error('prepare'); |
| $query->execute() | | $query->execute() |
| or die $s->log_error('execute'); | | or die $s->log_error('execute'); |
| $each = sub { | | $each = sub { |
| my $ref = $query->fetchrow_arrayref() | | my $ref = $query->fetchrow_arrayref() |
| or return undef; | | or return undef; |
| return $ref; | | return $ref; |
| }; | | }; |
|
| push @$s, $each; | | $s->[$EACH] = $each; |
| } | | } |
| my $return = $s->[$EACH]->(); | | my $return = $s->[$EACH]->(); |
| if(! defined $return->[0]) { | | if(! defined $return->[0]) { |
|
| pop @$s; | | undef $s->[$EACH]; |
| delete $s->[$CONFIG]{Export_order}; | | delete $s->[$CONFIG]{Export_order}; |
| return (); | | return (); |
| } | | } |
| return $return; | | return $return; |
| } | | } |
| | |
| sub sprintf_substitute { | | sub sprintf_substitute { |
| my ($s, $query, $fields, $cols) = @_; | | my ($s, $query, $fields, $cols) = @_; |
| my ($tmp, $arg); | | my ($tmp, $arg); |
| my $i; | | my $i; |
| | | |
| End of changes. 83 change blocks. |
|---|
| 82 lines changed or deleted | | 222 lines changed or added |
|---|
"Fossies" - the Fresh Open Source Software Archive 