no warnings;
sub add_vocabularies {
my ($item, @items) = @_;
while (@items) {
my $name = shift @items;
my $options = {};
if (@items > 0 && ref $items [0] eq HASH) {
$options = shift @items;
}
next
if $options -> {off};
$options -> {item} = $item;
my $table_name = $options -> {name} || $name;
$item -> {$name} = sql_select_vocabulary ($table_name, $options);
if ($options -> {ids}) {
ref $options -> {ids} eq HASH or $options -> {ids} = {table => $options -> {ids}};
$options -> {ids} -> {from} ||= 'id_' . en_unplural ($_REQUEST {type});
$options -> {ids} -> {to} ||= 'id_' . en_unplural ($table_name);
$options -> {ids} -> {name} ||= $options -> {ids} -> {to};
$_REQUEST {"__checkboxes_$options->{ids}->{to}"} = $options -> {ids} -> {table};
$item -> {$options -> {ids} -> {name}} = [sql_select_col ("SELECT $options->{ids}->{to} FROM $options->{ids}->{table} WHERE fake = 0 AND $options->{ids}->{from} = ?", $item -> {id})];
}
}
return $item;
}
sub sql_weave_model {
my ($db_model) = @_;
my @tables = grep {$_ ne $conf -> {systables} -> {log}} map {lc} get_tables ();
foreach my $table_name (@tables) {
my $def = $db_model -> {tables} -> {$table_name};
$def -> {name} = $table_name;
foreach my $column_name (keys %{$def -> {columns}}) {
$def -> {columns} -> {$column_name} -> {name} = $column_name;
$def -> {columns} -> {$column_name} -> {table_name} = $table_name;
}
$db_model -> {aliases} -> {$table_name} = $def;
foreach my $alias (@{$def -> {aliases}}) {
$db_model -> {aliases} -> {$alias} = $def;
}
}
foreach my $table_name (@tables) {
my $def = $db_model -> {aliases} -> {$table_name};
foreach my $column_name (keys %{$def -> {columns}}) {
my $column_def = $def -> {columns} -> {$column_name};
$column_name =~ /^ids?_(.*)/ or next;
my $target2 = $1;
my $target1 = $target2;
if ($target2 =~ /y$/) {
$target1 =~ s{y$}{ies};
}
else {
$target1 .= 's';
}
my $referenced_table_def = undef;
if ($column_def -> {ref}) {
$referenced_table_def = $db_model -> {aliases} -> {$column_def -> {ref}}
}
else {
$referenced_table_def =
$db_model -> {aliases} -> {$target1} ||
$db_model -> {aliases} -> {$target2} ||
$db_model -> {aliases} -> {'voc_' . $target1} ||
$db_model -> {aliases} -> {'voc_' . $target2} ||
undef;
}
$referenced_table_def or next;
$referenced_table_def -> {references} ||= [];
push @{$referenced_table_def -> {references}}, $column_def;
}
}
}
sub check_systables {
foreach (qw(
__access_log
__queries
__defaults
__benchmarks
__request_benchmarks
__last_update
__moved_links
__required_files
__screenshots
cache_html
log
roles
sessions
users
)) {
$conf -> {systables} -> {$_} ||= $_;
}
}
sub sql_assert_core_tables {
$db or return;
$model_update or die "\$db && !\$model_update ?!! Can't believe it.\n";
return if $model_update -> {core_ok};
my $time = time;
$model_update -> assert (
tables => {
$conf -> {systables} -> {__last_update} => {
columns => {
id => {TYPE_NAME => 'bigint', _EXTRA => 'auto_increment', _PK => 1},
pid => {TYPE_NAME => 'int'},
unix_ts => {TYPE_NAME => 'bigint'},
},
},
},
prefix => 'sql_assert_core_tables#',
);
sql_version ();
$model_update -> {core_ok} = 1;
__log_profilinig ($time, ' <sql_assert_core_tables>');
}
sub sql_temporality_callback {
my ($self, %params) = @_;
my $needed_tables = $params {tables};
foreach my $name (keys (%$needed_tables)) {
sql_is_temporal_table ($name) or next;
my $log_def = Storable::dclone ($needed_tables -> {$name});
foreach my $key (keys %{$log_def -> {columns}}) {
delete $log_def -> {columns} -> {$key} -> {_EXTRA};
delete $log_def -> {columns} -> {$key} -> {_PK};
}
$log_def -> {columns} -> {id} -> {TYPE_NAME} ||= 'int';
delete $log_def -> {data};
$log_def -> {keys} ||= {};
$log_def -> {keys} -> {__id} = 'id';
$log_def -> {columns} -> {__dt} = {
TYPE_NAME => 'datetime',
};
$log_def -> {columns} -> {__id} = {
TYPE_NAME => 'int',
_EXTRA => 'auto_increment',
_PK => 1,
};
$log_def -> {columns} -> {__op} = {
TYPE_NAME => 'int',
};
$log_def -> {columns} -> {__id_log} = {
TYPE_NAME => 'int',
};
$log_def -> {columns} -> {__is_actual} = {
TYPE_NAME => 'tinyint',
NULLABLE => 0,
COLUMN_DEF => 0,
};
$params {tables} -> {'__log_' . $name} = $log_def;
}
}
sub sql_is_temporal_table {
if (ref $conf -> {db_temporality} eq ARRAY) {
$conf -> {db_temporality} = {(map {$_ => 1} @{$conf -> {db_temporality}})};
}
my ($name) = @_;
return 0 if $name =~ /^__log_/;
if (ref $conf -> {db_temporality} eq HASH) {
return $conf -> {db_temporality} -> {$name};
}
else {
return $conf -> {db_temporality};
}
}
sub sql_reconnect {
my $time = time;
our $db, $model_update, $SQL_VERSION;
if ($db && ($preconf -> {no_model_update} || ($model_update && $model_update -> {core_ok}))) {
$db -> ping and return
$time = __log_profilinig ($time, ' sql_reconnect: ping OK');
}
$db = DBI -> connect ($preconf -> {db_dsn}, $preconf -> {db_user}, $preconf -> {db_password}, {
RaiseError => 1,
AutoCommit => 1,
LongReadLen => 1000000,
LongTruncOk => 1,
InactiveDestroy => 0,
});
$time = __log_profilinig ($time, " sql_reconnect: connected to $preconf->{db_dsn}");
unless ($INC_FRESH {db_driver}) {
my $driver_name = $db -> get_info ($GetInfoType {SQL_DBMS_NAME});
$driver_name =~ s{\W}{}gsm;
my $path = __FILE__;
$path =~ s{(.)SQL\.pm$}{${1}SQL$1Dialect$1${driver_name}.pm};
do $path;
die $@ if $@;
$INC_FRESH {db_driver} = time;
$SQL_VERSION = {driver => $driver_name};
$time = __log_profilinig ($time, " sql_reconnect: $driver_name is loaded");
}
sql_version ();
$time = __log_profilinig ($time, " sql_reconnect: driver version is $SQL_VERSION->{string}");
unless ($preconf -> {no_model_update}) {
if ($model_update) {
$model_update -> {db} = $db;
}
else {
$model_update = $_NEW_PACKAGE -> new (
$db,
before_assert => $conf -> {'db_temporality'} ? \&sql_temporality_callback : undef,
schema => $preconf -> {db_schema},
);
$time = __log_profilinig ($time, ' sql_reconnect: $model_update created');
}
}
}
sub sql_disconnect {
eval { $db -> disconnect };
undef $db;
}
sub sql_select_vocabulary {
my ($table_name, $options) = @_;
$options -> {order} ||= '2';
my $filter = '1=1';
my $limit = '';
if ($_REQUEST {__read_only}) {
if ($options -> {field} && $options -> {item}) {
my $id = 0 + $options -> {item} -> {$options -> {field}};
$filter .= ' AND id = ' . $id;
}
else {
$filter .= ' AND fake <= 0';
}
}
else {
$filter .= ' AND fake = 0';
}
$filter .= " AND $options->{filter}" if $options -> {filter};
my @params = ();
if ($options -> {in}) {
my $in = $options -> {in};
my $ref = ref $in;
if ($ref eq SCALAR) {
my $tied = tied $$in;
if (_sql_ok_subselects ()) {
$filter .= " AND id IN ($tied->{sql})";
push @params, @{$tied -> {params}};
}
else {
$filter .= " AND id IN ($$in)";
}
}
elsif ($ref eq ARRAY) {
@$in > 0 or return [];
$in = join ',', @$in;
$filter .= " AND id IN ($in)";
}
elsif (!$ref) {
$in =~ /\d/ or return [];
$filter .= " AND id IN ($in)";
}
else {
die "Wrong IN list";
}
}
if ($options -> {not_in}) {
my $in = $options -> {not_in};
my $ref = ref $in;
if ($ref eq SCALAR) {
my $tied = tied $$in;
if (_sql_ok_subselects ()) {
$filter .= " AND id NOT IN ($tied->{sql})";
push @params, @{$tied -> {params}};
}
else {
$filter .= " AND id NOT IN ($$in)";
}
}
elsif ($ref eq ARRAY) {
@$in > 0 or return [];
$in = join ',', @$in;
$filter .= " AND id NOT IN ($in)";
}
elsif (!$ref) {
$in =~ /\d/ or return [];
$filter .= " AND id NOT IN ($in)";
}
else {
die "Wrong [NOT] IN list";
}
}
if ($preconf -> {subset} && $table_name eq $conf -> {systables} -> {roles}) {
$filter .= " AND name IN ('-1'";
foreach my $name (keys %{$preconf -> {subset_names}}) {
$filter .= ", '";
$filter .= $name;
$filter .= "'";
}
$filter .= ")";
}
$limit = "LIMIT $options->{limit}" if $options -> {limit};
$options -> {label} ||= 'label';
if ($options -> {label} ne 'label') {
$options -> {label} =~ s/ AS.*//i;
$options -> {label} .= ' AS label';
}
$options -> {label} .= ', parent' if $options -> {tree};
my @list;
tie @list, 'Eludia::Tie::Vocabulary', {
sql => "SELECT id, $$options{label}, fake FROM $table_name WHERE $filter ORDER BY $$options{order} $limit",
params => \@params,
_REQUEST => \%_REQUEST,
package => current_package (),
tree => $options -> {tree},
};
return \@list;
}
sub sql_select_id {
my ($table, $values, @lookup_field_sets) = @_;
my $result = {};
my $table_safe = sql_table_name ($table);
my %values = ();
my $forced = {};
foreach my $key (keys %$values) {
$key =~ /^(\-?)(.*)$/;
$forced -> {$2} = 1 if $1;
$values {$2} = $values -> {$key};
}
$values = \%values;
exists $values -> {fake} or $values -> {fake} = 0;
@lookup_field_sets = (['label']) if @lookup_field_sets == 0;
my $options = ref $lookup_field_sets [-1] eq HASH ? pop @lookup_field_sets : {};
my $record = {};
my $auto_commit = $db -> {AutoCommit};
eval { $db -> {AutoCommit} = 0; };
sql_lock ($table);
eval {
foreach my $lookup_fields (@lookup_field_sets) {
if (ref $lookup_fields eq CODE) {
next if &$lookup_fields ();
return 0;
}
my $sql = "SELECT * FROM $table_safe WHERE fake <= 0";
my @params = ();
foreach my $lookup_field (@$lookup_fields) {
my $value = $values -> {$lookup_field};
if ($value eq '' && $SQL_VERSION -> {driver} eq 'Oracle') {
$value = undef;
}
if (defined $value) {
$sql .= " AND $lookup_field = ?";
push @params, $values -> {$lookup_field};
}
else {
$sql .= " AND $lookup_field IS NULL";
}
}
$sql .= " ORDER BY fake DESC, id DESC";
$record = sql_select_hash ($sql, @params);
last if $record -> {id};
}
unless ($_REQUEST {_no_search_merged_record}) {
while (my $id = ($record -> {is_merged_to} || $record -> {id_merged_to})) {
$record = sql_select_hash ($table, $id);
}
}
if ($record -> {id}) {
my @keys = ();
my @values = ();
foreach my $key (keys %$values) {
($forced -> {$key} && $values -> {$key} ne $record -> {$key}) or $record -> {$key} eq '' or next;
$result -> {update} -> {$key} = {old => $record -> {$key}, new => $values -> {$key}};
push @keys, $key;
push @values, $values -> {$key};
}
if (@keys) {
sql_do ('UPDATE ' . $table_safe . ' SET ' . (join ', ', map {"$_ = ?"} @keys) . ' WHERE id = ?', @values, $record -> {id});
}
}
unless ($record -> {id}) {
$record -> {id} = sql_do_insert ($table, $values);
$result -> {insert} = $values;
}
};
sql_unlock ($table);
if ($auto_commit) {
eval {
$db -> commit;
$db -> {AutoCommit} = 1;
};
}
return $options -> {show_diff} && wantarray ? ($record -> {id}, $result) : $record -> {id};
}
sub sql_do_relink {
my ($table_name, $old_ids, $new_id, $options) = @_;
sql_weave_model ($DB_MODEL);
ref $old_ids eq ARRAY or $old_ids = [$old_ids];
my $column_name = '';
$column_name = 'is_merged_to' if $DB_MODEL -> {tables} -> {$table_name} -> {columns} -> {is_merged_to};
$column_name = 'id_merged_to' if $DB_MODEL -> {tables} -> {$table_name} -> {columns} -> {id_merged_to};
my $record = sql_select_hash ($table_name, $new_id);
my @empty_fields = ();
foreach my $key (keys %$record) {
next if $options -> {no_update};
next if $record -> {$key} . '' ne '';
next if $key eq 'id';
next if $key eq 'fake';
next if $key eq 'is_merged_to';
next if $key eq 'id_merged_to';
push @empty_fields, $key;
}
my $moved_links_table = sql_table_name ($conf -> {systables} -> {__moved_links});
foreach my $old_id (@$old_ids) {
warn "relink $table_name: $old_id -> $new_id";
my $record = sql_select_hash ($table_name, $old_id);
foreach my $empty_field (@empty_fields) {
$_REQUEST {'_' . $empty_field} ||= $record -> {$empty_field};
}
foreach my $column_def (@{$DB_MODEL -> {aliases} -> {$table_name} -> {references}}) {
next
if $DB_MODEL -> {tables} -> {$column_def -> {table_name}} -> {sql};
warn "relink $$column_def{table_name} ($$column_def{name}): $old_id -> $new_id";
if ($column_def -> {TYPE_NAME} =~ /int/) {
sql_do (<<EOS, $old_id);
INSERT INTO $moved_links_table
(table_name, column_name, id_from, id_to)
SELECT
'$$column_def{table_name}' AS table_name,
'$$column_def{name}' AS column_name,
id AS id_from,
'$old_id' AS id_to
FROM
$$column_def{table_name}
WHERE
$$column_def{name} = ?
EOS
sql_do ("UPDATE $$column_def{table_name} SET $$column_def{name} = ? WHERE $$column_def{name} = ?", $new_id, $old_id);
}
else {
my $_old_id = ',' . $old_id . ',';
my $_new_id = ',' . $new_id . ',';
sql_do (<<EOS, '%' . $old_id . '%');
INSERT INTO $moved_links_table
(table_name, column_name, id_from, id_to)
SELECT
'$$column_def{table_name}' AS table_name,
'$$column_def{name}' AS column_name,
id AS id_from,
'$_old_id' AS id_to
FROM
$$column_def{table_name}
WHERE
$$column_def{name} LIKE ?
EOS
sql_do ("UPDATE $$column_def{table_name} SET $$column_def{name} = REPLACE($$column_def{name}, ?, ?) WHERE $$column_def{name} LIKE ?", $_old_id, $_new_id, '%' . $_old_id . '%');
}
}
if ($column_name) {
sql_do ("UPDATE $table_name SET fake = -1, $column_name = ? WHERE id = ?", $new_id, $old_id);
}
else {
sql_do ("UPDATE $table_name SET fake = -1 WHERE id = ?", $old_id);
}
}
sql_do_update ($table_name, \@empty_fields) if @empty_fields > 0;
delete $DB_MODEL -> {aliases};
}
sub sql_undo_relink {
sql_weave_model ($DB_MODEL);
my ($table_name, $old_ids) = @_;
ref $old_ids eq ARRAY or $old_ids = [$old_ids];
my $moved_links_table = sql_table_name ($conf -> {systables} -> {__moved_links});
foreach my $old_id (@$old_ids) {
$old_id > 0 or next;
warn "undo relink $table_name: $old_id";
my $record = sql_select_hash ($table_name, $old_id);
foreach my $column_def (@{$DB_MODEL -> {aliases} -> {$table_name} -> {references}}) {
my $from = <<EOS;
FROM
$moved_links_table
WHERE
table_name = '$$column_def{table_name}'
AND column_name = '$$column_def{name}'
AND id_to = $old_id
EOS
my $ids = sql_select_ids ("SELECT id_from $from");
sql_do ("DELETE $from");
warn "undo relink $$column_def{table_name} ($$column_def{name}): $old_id";
if ($column_def -> {TYPE_NAME} =~ /int/) {
sql_do ("UPDATE $$column_def{table_name} SET $$column_def{name} = ? WHERE id IN ($ids)", $old_id);
}
else {
$old_id_ = $old_id . ',';
sql_do ("UPDATE $$column_def{table_name} SET $$column_def{name} = CONCAT($$column_def{name}, ?) WHERE id IN ($ids)", $old_id_);
}
}
}
delete $DB_MODEL -> {aliases};
}
sub assert_fake_key {
my ($table_name) = @_;
$DB_MODEL -> {tables} -> {$table_name} or return;
return if $DB_MODEL -> {tables} -> {$table_name} -> {keys} -> {fake};
$model_update -> assert (
tables => {
$table_name => {
keys => {fake => 'fake'},
},
},
prefix => 'assert_fake_key#',
);
}
sub is_recyclable {
my ($table_name) = @_;
return 0 if $table_name eq $conf -> {systables} -> {log};
return 0 if $table_name eq $conf -> {systables} -> {sessions};
if (ref $conf -> {core_recycle_ids} eq ARRAY) {
$conf -> {core_recycle_ids} = {map {$_ => 1} @{$conf -> {core_recycle_ids}}}
}
return 1 if $conf -> {core_recycle_ids} == 1 || $conf -> {core_recycle_ids} -> {$table_name};
return 0;
}
sub delete_fakes {
my ($table_name) = @_;
$table_name ||= $_REQUEST {type};
return if ($_REQUEST {__delete_fakes} -> {$table_name} ||= is_recyclable ($table_name));
assert_fake_key ($table_name);
my ($ids, $in_clause) = sql_select_ids (<<EOS);
SELECT
$table_name.id
FROM
$table_name
LEFT JOIN $conf->{systables}->{sessions} ON $table_name.fake = $conf->{systables}->{sessions}.id
WHERE
$table_name.fake > 0
AND $conf->{systables}->{sessions}.id_user IS NULL
EOS
sql_do ("DELETE FROM $table_name WHERE id IN ($in_clause)");
$_REQUEST {__delete_fakes} -> {$table_name} = 1;
}
sub __log_sql_profilinig {
my ($options) = @_;
$_REQUEST {__sql_time} += 1000 * (time - $options -> {time});
}
sub sql_extract_params {
my ($sql, @params) = @_;
return ($sql, @params) if $sql !~ /^\s*(SELECT|INSERT|UPDATE|DELETE)/i;
my $sql1 = '';
my @params1 = ();
my $i = 0;
my $flag = $sql =~ /SELECT/i ? 0 : 1;
my $flag1 = 1;
foreach my $token (
$sql =~ m{
(
(?:>=|<=|==)
|
[\(\),=;]
|
\'\'(?!\')
|
\"\"(?!\"")
|
".*?(?:(?:""){1,}"|(?<!["\\])"(?!")|\\"{2})
|
'.*?(?:(?:''){1,}'|(?<!['\\])'(?!')|\\'{2})
|
--[\ \t\S]*
|
\
|
/\*[\ \t\n\S]*?\*/
|
[^\s\(\),=;]+
|
\n
|
[\t\ ]+
)
}smxgo
) {
$token =~ s{\s+}{ }gsm;
if (
$token =~ /^--\s/
|| $token =~ /^\/\*\s*[^\+]/ || $token =~ /^\
) {
$token = ' ';
}
else {
$flag = 1 if $token =~ /^FROM$/i;
$flag1 = 1 if $token =~ /^END$/i;
$flag = 0 if $token =~ /^ORDER$/i || $token =~ /^GROUP$/i || $token =~ /^SELECT$/i;
$flag1 = 0 if $token =~ /^CASE$/i;
if ($token eq '?') {
push @params1, $params [$i ++];
}
elsif (
$token =~ /^0(\d+)$/
) {
$token = $1;
}
elsif (
($flag && $flag1) && (
$token =~ /^(\-?\d+)$/
|| $token =~ /^\'(.*?)\'$/
)
) {
my $value = $1;
$value =~ s{\\\'}{\'}gsm; #'
push @params1, $value;
$token = '?';
}
}
$token =~ /^\"(.*?)\"$/ or $token = uc $token;
$sql1 .= ' ';
$sql1 .= $token;
$sql1 .= ' ';
}
$sql1 =~ s{\s+$}{};
$sql1 =~ s{^\s+}{};
$sql1 =~ s{\s+}{ }g;
$sql = $sql1;
return ($sql1, @params1);
}
sub sql_adjust_fake_filter {
my ($sql, $options) = @_;
$options -> {fake} or return $sql;
my $where = 'WHERE ';
my $fake = $_REQUEST {fake} || 0;
my $condition = $fake =~ /\,/ ? "IN ($fake)" : '=' . $fake;
foreach my $table (split /\,/, $options -> {fake}) {
$where .= "$table.fake $condition AND ";
}
$sql =~ s{where}{$where}i;
return $sql;
}
sub __log_request_profilinig {
my ($request_time) = @_;
return unless ($preconf -> {core_debug_profiling} > 2 && $model_update -> {core_ok});
my $c = $r -> connection;
$_REQUEST {_id_request_log} = sql_do_insert ($conf -> {systables} -> {__request_benchmarks}, {
id_user => $_USER -> {id},
ip => $ENV {REMOTE_ADDR},
ip_fw => $ENV {HTTP_X_FORWARDED_FOR},
fake => 0,
type => $_REQUEST {type},
mac => get_mac (),
request_time => int ($request_time),
connection_id => $c -> id (),
connection_no => $c -> keepalives (),
});
my $request_benchmarks_table = sql_table_name ($conf -> {systables} -> {__request_benchmarks});
sql_do ("UPDATE $request_benchmarks_table SET params = ? WHERE id = ?",
Data::Dumper -> Dump ([\%_REQUEST], ['_REQUEST']), $_REQUEST {_id_request_log});
}
sub __log_request_finish_profilinig {
my ($options) = @_;
return
unless ($preconf -> {core_debug_profiling} > 2 && $model_update -> {core_ok});
my $time = time;
my $request_benchmarks_table = sql_table_name ($conf -> {systables} -> {__request_benchmarks});
sql_do ("UPDATE $request_benchmarks_table SET application_time = ?, sql_time = ?, response_time = ?, bytes_sent = ?, is_gzipped = ? WHERE id = ?",
int ($options -> {application_time}),
int ($options -> {sql_time}),
$options -> {out_html_time} ? int (1000 * (time - $options -> {out_html_time})) : 0,
$r -> bytes_sent,
$options -> {is_gzipped},
$options -> {id_request_log},
);
}
sub sql_select_ids {
my ($sql, @params) = @_;
my $ids;
my $tied = tie $ids, 'Eludia::Tie::IdsList', {
sql => $sql,
_REQUEST => \%_REQUEST,
package => __PACKAGE__,
params => \@params,
db => $db,
sql_translator_ref => get_sql_translator_ref(),
};
return wantarray ? (
$ids,
wantarray && _sql_ok_subselects () ? $tied -> _sql : $ids,
) : $ids;
}
sub sql_upload_files {
my ($options) = @_;
my @nos = ();
foreach my $k (keys %_REQUEST) {
$k =~ /^_$options->{name}_(\d+)$/ or next;
$_REQUEST {$k} or next;
push @nos, $1;
}
@nos > 0 or return;
my ($table, $field) = split /\./, $_REQUEST {"__$options->{name}_file_field"};
$options -> {id} ||= $_REQUEST {id};
sql_do ("UPDATE $table SET fake = -1 WHERE $field = ?", $options -> {id});
my $name = $options -> {name};
my $id = $options -> {id};
$options -> {table} = $table;
$options -> {file_name_column} = 'file_name';
$options -> {size_column} = 'file_size';
$options -> {type_column} = 'file_type';
$options -> {path_column} = 'file_path';
$options -> {body_column} = 'file_body' if $model_update -> get_columns ($table) -> {file_body};
foreach my $no (sort {$a <=> $b} @nos) {
$options -> {name} = "${name}_${no}";
$options -> {id} = sql_do_insert ($table => {
$field => $id,
fake => 0,
});
sql_upload_file ($options);
}
sql_select_loop ("SELECT * FROM $table WHERE $field = ? AND fake = -1", sub {
my $path = $i -> {$options -> {path_column}} or return;
unlink $r -> document_root . $path;
}, $id);
sql_do ("DELETE FROM $table WHERE $field = ? AND fake = -1", $id);
}
sub new {
my ($package_name, $db, @options) = @_;
my $driver_name = $db -> get_info ($GetInfoType {SQL_DBMS_NAME});
$driver_name =~ s{\s}{}gsm;
die $@ if $@;
my $self = bless ({
db => $db,
driver_name => $driver_name,
quote => $db -> get_info ($GetInfoType {SQL_IDENTIFIER_QUOTE_CHAR}),
@options
}, $package_name);
if ($driver_name eq 'Oracle') {
$self -> {characterset} = sql_select_scalar ('SELECT VALUE FROM V$NLS_PARAMETERS WHERE PARAMETER = ?', 'NLS_CHARACTERSET');
$self -> {schema} ||= uc $db -> {Username};
}
$self -> {schema} ||= '';
return $self;
}
sub sql_assert_default_columns {
my ($needed_tables, $params) = @_;
my $default_columns = $params -> {default_columns} or return $needed_tables;
foreach my $name (keys %$needed_tables) {
my $definition = $needed_tables -> {$name};
next if $definition -> {sql};
next if $definition -> {columns} -> {id};
foreach my $dc_name (keys %$default_columns) {
$definition -> {columns} -> {$dc_name} ||= Storable::dclone $default_columns -> {$dc_name};
}
}
return $needed_tables;
}
sub assert {
my ($self, %params) = @_;
my $core_debug_sql_do = $preconf -> {core_debug_sql_do};
$preconf -> {core_debug_sql_do} = 1;
my ($tables, my $new_checksums) = checksum_filter (db_model => $params {prefix},
sql_assert_default_columns (Storable::dclone ($params {tables}), \%params)
);
my $objects = [\my @tables, \my @views];
while (my ($name, $object) = each %$tables) {
next if $object -> {off};
$object -> {name} = $name;
push @{$objects -> [$object -> {sql} ? 1 : 0]}, $object;
}
wish (tables => Storable::dclone \@tables, {});
foreach my $table (@tables) {
wish (table_columns => [map {{name => $_, %{$table -> {columns} -> {$_}}}} (keys %{$table -> {columns}})], {table => $table -> {name}}) if exists $table -> {columns};
wish (table_keys => [map {{name => $_, parts => $table -> {keys} -> {$_}}} (keys %{$table -> {keys}})], {table => $table -> {name}, table_def => $table}) if exists $table -> {keys};
if (exists $table -> {data} && ref $table -> {data} eq ARRAY && @{$table -> {data}} > 0) {
wish (table_data => $table -> {data}, {
table => $table -> {name},
key => exists $table -> {data} -> [0] -> {id} ? 'id' : 'name',
});
}
}
wish (views => \@views, {});
$preconf -> {core_debug_sql_do} = $core_debug_sql_do;
checksum_write ('db_model', $new_checksums);
}
sub sql_store_ids {
my $options;
if (@_ == 2 && !ref $_[0] && !ref $_[1]) {
$options = {
table => $_[0],
key => $_[1],
}
}
elsif (ref $_[0] eq HASH) {
$options = $_[0];
}
else {
die "Wrong parameters for sql_store_ids: " . Dumper (\@_);
}
$options -> {root} ||= {'id_' . en_unplural ($_REQUEST {type}) => $_REQUEST {id}};
wish (table_data => [map {{ fake => 0, $options -> {key} => $_ }} get_ids ($options -> {key})], $options);
}
sub sql_clone {
my ($table, $data, %fields) = @_;
my $clone = {%$data, %fields};
delete $clone -> {id};
$clone -> {id} = sql_do_insert ($table => $clone);
return $clone;
}
sub require_wish ($) {
return if $INC_FRESH {"Wish::$_[0]"};
foreach my $key (map {"Eludia/SQL$_/Wish/$_[0].pm"} ('', '/Dialect/' . $SQL_VERSION -> {driver})) {
eval {require $key};
delete $INC {$key};
}
$INC_FRESH {"Wish::$_[0]"} = 1;
}
sub wish {
my ($type, $items, $options) = @_;
require_wish $type;
&{"wish_to_adjust_options_for_$type"} ($options);
foreach my $i (@$items) { &{"wish_to_clarify_demands_for_$type"} ($i, $options) }
my $existing = &{"wish_to_explore_existing_$type"} ($options);
my $todo = {};
my @key = @{$options -> {key}};
foreach my $new (@$items) {
my $old = delete $existing -> {join '_', @$new {@key}} or (push @{$todo -> {create}}, $new) and next;
&{"wish_to_update_demands_for_$type"} ($old, $new, $options);
next if Dumper ($new) eq Dumper ($old);
&{"wish_to_schedule_modifications_for_$type"} ($old, $new, $todo, $options);
}
&{"wish_to_schedule_cleanup_for_$type"} ($existing, $todo, $options);
foreach my $action (keys %$todo) { &{"wish_to_actually_${action}_${type}"} ($todo -> {$action}, $options) }
}
sub get_tables {
my ($self, $table) = @_;
require_wish 'tables';
return sort keys %{wish_to_explore_existing_tables ()};
}
sub get_columns {
my ($self, $table) = @_;
require_wish 'table_columns';
wish_to_adjust_options_for_table_columns (my $options = {table => $table});
return wish_to_explore_existing_table_columns ($options);
}
sub get_keys {
my ($self, $table) = @_;
require_wish 'table_keys';
wish_to_adjust_options_for_table_keys (my $options = {table => $table});
my %keys = ();
foreach my $i (values %{wish_to_explore_existing_table_keys ($options)}) {
if ($i -> {global_name} =~ /.*?$options->{table}_/i) {
$i -> {global_name} = $';
}
$keys {lc $i -> {global_name}} = join ', ', @{$i -> {parts}}
}
return \%keys;
}
sub sql_table_name {$_[0]}
1;