use
5.016;
$Geoffrey::Converter::Pg::VERSION
=
'0.000200'
;
Readonly::Scalar
my
$I_CONST_LENGTH_VALUE
=> 2;
Readonly::Scalar
my
$I_CONST_NOT_NULL_VALUE
=> 3;
Readonly::Scalar
my
$I_CONST_PRIMARY_KEY_VALUE
=> 4;
Readonly::Scalar
my
$I_CONST_DEFAULT_VALUE
=> 5;
{
sub
new {
my
$class
=
shift
;
return
bless
$class
->SUPER::new(
not_null
=>
'NOT NULL'
,
unique
=>
'UNIQUE'
,
primary_key
=>
'PRIMARY KEY'
,
foreign_key
=>
'FOREIGN KEY'
,
check
=>
'CHECK'
,
default
=>
'DEFAULT'
,
),
$class
;
}
}
{
sub
add {
return
'CREATE VIEW {0} AS {1}'
; }
sub
drop {
return
'DROP VIEW {0}'
; }
sub
list {
my
(
$self
,
$schema
) =
@_
;
return
q~SELECT * FROM pg_views WHERE schemaname NOT IN('information_schema', 'pg_catalog')~
;
}
}
{
sub
add {
return
'FOREIGN KEY ({0}) REFERENCES {1}({2})'
}
sub
list {
return
q~SELECT
source_table::regclass,
source_attr.attname AS source_column,
target_table::regclass,
target_attr.attname AS target_column
FROM
pg_attribute target_attr,
pg_attribute source_attr,
(
SELECT
source_table,
target_table,
source_constraints[i] AS source_constraints,
target_constraints[i] AS target_constraints
FROM (
SELECT
conrelid as source_table,
confrelid AS target_table,
conkey AS source_constraints,
confkey AS target_constraints,
generate_series(1, array_upper(conkey, 1)) AS i
FROM
pg_constraint
WHERE
contype = 'f'
) query1
) query2
WHERE
target_attr.attnum = target_constraints
AND target_attr.attrelid = target_table
AND source_attr.attnum = source_constraints
AND source_attr.attrelid = source_table~
;
}
}
{
sub
add {
return
'CREATE SEQUENCE {0} INCREMENT {1} MINVALUE {2} MAXVALUE {3} START {4} CACHE {5}'
}
sub
nextval {
return
q~DEFAULT nextval('{0}'::regclass~
}
}
{
sub
add {
return
'CONSTRAINT {0} PRIMARY KEY ( {1} )'
; }
sub
list {
return
q~SELECT
tc.table_schema,
tc.table_name,
kc.column_name,
kc.constraint_name
FROM
information_schema.table_constraints tc,
information_schema.key_column_usage kc
WHERE
tc.constraint_type = 'PRIMARY KEY'
AND kc.table_name = tc.table_name
AND kc.table_schema = tc.table_schema
AND kc.constraint_name = tc.constraint_name~
;
}
}
{
sub
append {
return
'CREATE UNIQUE INDEX IF NOT EXISTS {0} ON {1} ( {2} )'
; }
sub
add {
return
'CONSTRAINT {0} UNIQUE ( {1} )'
; }
sub
drop {
return
'DROP INDEX IF EXISTS {1}'
; }
sub
list {
list
=>
q~SELECT
U.usename AS user_name,
ns.nspname AS schema_name,
idx.indrelid :: REGCLASS AS table_name,
i.relname AS index_name,
am.amname AS index_type,
idx.indkey,
ARRAY(
SELECT
pg_get_indexdef(idx.indexrelid, k + 1, TRUE)
FROM
generate_subscripts(idx.indkey, 1) AS k
ORDER BY k
) AS index_keys,
(idx.indexprs IS NOT NULL) OR (idx.indkey::int[] @> array[0]) AS is_functional,
idx.indpred IS NOT NULL AS is_partial
FROM
pg_index AS idx
JOIN pg_class AS i ON i.oid = idx.indexrelid
JOIN pg_am AS am ON i.relam = am.oid
JOIN pg_namespace AS NS ON i.relnamespace = NS.OID
JOIN pg_user AS U ON i.relowner = U.usesysid
WHERE
NOT nspname LIKE 'pg%'
AND NOT idx.indisprimary
AND idx.indisunique;~
;
}
}
{
sub
add {
return
q~CREATE FUNCTION {0}({1}) RETURNS {2} AS ' {3} ' LANGUAGE {4} VOLATILE COST {5}~
; }
sub
drop {
return
'DROP FUNCTION {0} ({1})'
; }
sub
list {
list
=>
q~SELECT n.nspname as "Schema",
p.proname as "Name",
p.prosrc,
p.procost,
pg_catalog.pg_get_function_result(p.oid) as result_data_type,
pg_catalog.pg_get_function_arguments(p.oid) as argument_data_types,
CASE
WHEN p.proisagg THEN 'agg'
WHEN p.proiswindow THEN 'window'
WHEN p.prorettype = 'pg_catalog.trigger'::pg_catalog.regtype THEN 'trigger'
ELSE
'normal'
END as
function_type
FROM
pg_catalog.pg_proc p
LEFT JOIN pg_catalog.pg_namespace n
ON ( n.oid = p.pronamespace )
WHERE
pg_catalog.pg_function_is_visible( p.oid )
AND n.nspname <> 'pg_catalog'
AND n.nspname <> 'information_schema'~
;
}
}
{
sub
add {
my
(
$self
,
$options
) =
@_
;
my
$s_sql_standard
=
<<'EOF';
CREATE TRIGGER {0} UPDATE OF {1} ON {2}
BEGIN
{4}
END
EOF
my
$s_sql_view
=
<<'EOF';
CREATE TRIGGER {0} INSTEAD OF UPDATE OF {1} ON {2}
BEGIN
{4}
END
EOF
return
$options
->{for_view} ?
$s_sql_view
:
$s_sql_standard
;
}
sub
drop {
return
'DROP TRIGGER IF EXISTS {1}'
; }
}
sub
new {
my
$class
=
shift
;
my
$self
=
$class
->SUPER::new(
@_
);
$self
->{min_version} =
'9.1'
;
return
bless
$self
,
$class
;
}
sub
defaults {
return
{
current_timestamp
=>
'CURRENT_TIMESTAMP'
,
autoincrement
=>
'SERIAL'
,};
}
sub
type {
my
(
$self
,
$hr_column_params
) =
@_
;
if
(
$hr_column_params
->{
default
} eq
'autoincrement'
) {
$hr_column_params
->{type}
=
lc
$hr_column_params
->{type} eq
'bigint'
?
'bigserial'
:
lc
$hr_column_params
->{type} eq
'smallint'
?
'smallserial'
:
'serial'
;
delete
$hr_column_params
->{
default
};
}
return
$self
->SUPER::type(
$hr_column_params
);
}
sub
types {
return
{
abstime
=>
'abstime'
,
aclitem
=>
'aclitem'
,
bigint
=>
'bigint'
,
bigserial
=>
'bigserial'
,
bit
=>
'bit'
,
var_bit
=>
'bit varying'
,
bool
=>
'boolean'
,
box
=>
'box'
,
bytea
=>
'bytea'
,
char
=>
'"char"'
,
character
=>
'character'
,
varchar
=>
'character varying'
,
cid
=>
'cid'
,
cidr
=>
'cidr'
,
circle
=>
'circle'
,
date
=>
'date'
,
daterange
=>
'daterange'
,
decimal
=>
'decimal'
,
double_precision
=>
'double precision'
,
gtsvector
=>
'gtsvector'
,
inet
=>
'inet'
,
int2vector
=>
'int2vector'
,
int4range
=>
'int4range'
,
int8range
=>
'int8range'
,
integer
=>
'integer'
,
interval
=>
'interval'
,
json
=>
'json'
,
line
=>
'line'
,
lseg
=>
'lseg'
,
macaddr
=>
'macaddr'
,
money
=>
'money'
,
name
=>
'name'
,
numeric
=>
'numeric'
,
numrange
=>
'numrange'
,
oid
=>
'oid'
,
oidvector
=>
'oidvector'
,
path
=>
'path'
,
pg_node_tree
=>
'pg_node_tree'
,
point
=>
'point'
,
polygon
=>
'polygon'
,
real
=>
'real'
,
refcursor
=>
'refcursor'
,
regclass
=>
'regclass'
,
regconfig
=>
'regconfig'
,
regdictionary
=>
'regdictionary'
,
regoper
=>
'regoper'
,
regoperator
=>
'regoperator'
,
regproc
=>
'regproc'
,
regprocedure
=>
'regprocedure'
,
regtype
=>
'regtype'
,
reltime
=>
'reltime'
,
serial
=>
'serial'
,
smallint
=>
'smallint'
,
smallserial
=>
'smallserial'
,
smgr
=>
'smgr'
,
text
=>
'text'
,
tid
=>
'tid'
,
timestamp
=>
'timestamp without time zone'
,
timestamp_tz
=>
'timestamp with time zone'
,
time
=>
'time without time zone'
,
time_tz
=>
'time with time zone'
,
tinterval
=>
'tinterval'
,
tsquery
=>
'tsquery'
,
tsrange
=>
'tsrange'
,
tstzrange
=>
'tstzrange'
,
tsvector
=>
'tsvector'
,
txid_snapshot
=>
'txid_snapshot'
,
uuid
=>
'uuid'
,
xid
=>
'xid'
,
xml
=>
'xml'
,
};
}
sub
select_get_table {
return
q~SELECT t.table_name AS table_name FROM information_schema.tables t WHERE t.table_type = 'BASE TABLE' AND t.table_schema = ? AND t.table_name = ?~
;
}
sub
convert_defaults {
my
(
$self
,
$params
) =
@_
;
$params
->{
default
} =~ s/^
'(.*)'
$/$1/;
if
(
$params
->{type} eq
'bit'
) {
return
qq~$params->{default}::bit~
;
}
return
$params
->{
default
};
}
sub
parse_default {
my
(
$self
,
$default_value
) =
@_
;
return
$1 * 1
if
(
$default_value
=~ m/\w
'(\d+)'
::
"\w+"
/);
return
$default_value
;
}
sub
can_create_empty_table {
return
0 }
sub
colums_information {
my
(
$self
,
$ar_raw_data
) =
@_
;
return
[]
if
scalar
@{
$ar_raw_data
} == 0;
my
$table_row
=
shift
@{
$ar_raw_data
};
$table_row
->{sql} =~ s/^.*(CREATE|create) .*\(//g;
my
$columns
= [];
for
(
split
m/,/,
$table_row
->{sql}) {
s/^\s*(.*)\s*$/$1/g;
my
$rx_not_null
=
'NOT NULL'
;
my
$rx_primary_key
=
'PRIMARY KEY'
;
my
$rx_default
=
'SERIAL|DEFAULT'
;
my
$rx_column_values
=
qr/($rx_not_null)*\s($rx_primary_key)*.*($rx_default \w{1,})*/
;
my
@column
= m/^(\w+)\s([[:upper:]]+)(\(\d*\))*\s
$rx_column_values
$/;
next
if
scalar
@column
== 0;
$column
[
$I_CONST_LENGTH_VALUE
] =~ s/([\(\)])//g
if
$column
[
$I_CONST_LENGTH_VALUE
];
push
@{
$columns
},
{
name
=>
$column
[0],
type
=>
$column
[1],
(
$column
[
$I_CONST_LENGTH_VALUE
] ? (
length
=>
$column
[
$I_CONST_LENGTH_VALUE
]) : ()),
(
$column
[
$I_CONST_NOT_NULL_VALUE
] ? (
not_null
=>
$column
[
$I_CONST_NOT_NULL_VALUE
]) : ()),
(
$column
[
$I_CONST_PRIMARY_KEY_VALUE
] ? (
primary_key
=>
$column
[
$I_CONST_PRIMARY_KEY_VALUE
]) : ()),
(
$column
[
$I_CONST_DEFAULT_VALUE
] ? (
default
=>
$column
[
$I_CONST_DEFAULT_VALUE
]) : ()),
};
}
return
$columns
;
}
sub
index_information {
my
(
$self
,
$ar_raw_data
) =
@_
;
my
@mapped
= ();
for
(@{
$ar_raw_data
}) {
next
if
!
$_
->{sql};
my
(
$s_columns
) =
$_
->{sql} =~ m/\((.*)\)$/;
my
@columns
=
split
m/,/,
$s_columns
;
s/^\s+|\s+$//g
for
@columns
;
push
@mapped
, {
name
=>
$_
->{name},
table
=>
$_
->{tbl_name},
columns
=> \
@columns
};
}
return
\
@mapped
;
}
sub
view_information {
my
(
$self
,
$ar_raw_data
) =
@_
;
return
[]
unless
$ar_raw_data
;
return
[
map
{ {
name
=>
$_
->{name},
sql
=>
$_
->{sql}} } @{
$ar_raw_data
}];
}
sub
constraints {
return
shift
->_get_value(
'constraints'
,
'Geoffrey::Converter::Pg::Constraints'
, 1);
}
sub
index
{
my
(
$self
,
$new_value
) =
@_
;
$self
->{
index
} =
$new_value
if
defined
$new_value
;
return
$self
->_get_value(
'index'
,
'Geoffrey::Converter::Pg::Index'
);
}
sub
table {
return
shift
->_get_value(
'table'
,
'Geoffrey::Converter::Pg::Tables'
);
}
sub
view {
return
shift
->_get_value(
'view'
,
'Geoffrey::Converter::Pg::View'
, 1);
}
sub
foreign_key {
my
(
$self
,
$new_value
) =
@_
;
$self
->{foreign_key} =
$new_value
if
defined
$new_value
;
return
$self
->_get_value(
'foreign_key'
,
'Geoffrey::Converter::Pg::ForeignKey'
, 1);
}
sub
trigger {
return
shift
->_get_value(
'trigger'
,
'Geoffrey::Converter::Pg::Trigger'
, 1);
}
sub
primary_key {
return
shift
->_get_value(
'primary_key'
,
'Geoffrey::Converter::Pg::PrimaryKey'
, 1);
}
sub
unique {
return
shift
->_get_value(
'unique'
,
'Geoffrey::Converter::Pg::UniqueIndex'
, 1);
}
sub
sequence {
return
shift
->_get_value(
'sequence'
,
'Geoffrey::Converter::Pg::Sequence'
, 1);
}
sub
_get_value {
my
(
$self
,
$key
,
$s_package_name
,
$b_ignore_require
) =
@_
;
$self
->{
$key
} //=
$self
->_set_value(
$key
,
$s_package_name
,
$b_ignore_require
);
return
$self
->{
$key
};
}
sub
_set_value {
my
(
$self
,
$key
,
$s_package_name
,
$b_ignore_require
) =
@_
;
$self
->{
$key
} =
$b_ignore_require
?
$s_package_name
->new(
@_
) : Geoffrey::Utils::obj_from_name(
$s_package_name
);
return
$self
->{
$key
};
}
1;