no
warnings
'uninitialized'
;
our
@ISA
=
qw(Rose::DB::Object::Metadata)
;
our
$Debug
;
*Debug
= \
$Rose::DB::Object::Metadata::Debug
;
our
$Sort_Columns_Alphabetically
= 0;
our
$VERSION
=
'0.786'
;
our
$Missing_PK_OK
= 0;
(
inheritable_scalar
=>
[
'default_perl_indent'
,
'default_perl_braces'
,
'default_perl_unique_key_style'
,
],
inheritable_hash
=>
[
relationship_type_ranks
=> {
interface
=>
'get_set_all'
},
relationship_type_rank
=> {
interface
=>
'get_set'
,
hash_key
=>
'relationship_type_ranks'
},
delete_relationship_type_rank
=> {
interface
=>
'delete'
,
hash_key
=>
'relationship_type_ranks'
},
],
);
(
'scalar --get_set_init'
=>
[
'column_alias_generator'
,
'foreign_key_name_generator'
,
],
scalar
=>
'auto_init_args'
,
);
__PACKAGE__->relationship_type_ranks
(
'one to one'
=> 1,
'many to one'
=> 2,
'one to many'
=> 3,
'many to many'
=> 4,
);
__PACKAGE__->default_perl_indent(4);
__PACKAGE__->default_perl_braces(
'k&r'
);
__PACKAGE__->default_perl_unique_key_style(
'array'
);
sub
auto_formatted_schema
{
my
(
$self
,
$db
) =
@_
;
$db
||=
$self
->db;
my
$schema
=
$self
->select_schema(
$db
);
$schema
=
$db
->default_implicit_schema
unless
(
defined
$schema
);
if
(
defined
$schema
)
{
if
(
$db
->likes_lowercase_schema_names)
{
$schema
=
lc
$schema
;
}
elsif
(
$db
->likes_uppercase_schema_names)
{
$schema
=
uc
$schema
;
}
}
return
$schema
;
}
sub
auto_formatted_catalog
{
my
(
$self
,
$db
) =
@_
;
$db
||=
$self
->db;
my
$catalog
=
$self
->select_catalog(
$db
);
if
(
defined
$catalog
)
{
if
(
$db
->likes_lowercase_catalog_names)
{
$catalog
=
lc
$catalog
;
}
elsif
(
$db
->likes_uppercase_catalog_names)
{
$catalog
=
uc
$catalog
;
}
}
return
$catalog
;
}
sub
auto_generate_columns
{
my
(
$self
) =
shift
;
my
(
$db
,
$class
,
%columns
,
$catalog
,
$schema
,
$table
,
$error
);
TRY:
{
local
$@;
eval
{
$class
=
$self
->class or
die
"Missing class!"
;
$db
=
$self
->db;
my
$dbh
=
$db
->dbh or
die
$db
->error;
local
$dbh
->{
'FetchHashKeyName'
} =
'NAME'
;
$table
=
$self
->table;
$table
=
lc
$table
if
(
$db
->likes_lowercase_table_names);
my
$table_unquoted
=
$db
->unquote_table_name(
$table
);
my
$supports_catalog
=
$db
->supports_catalog;
$catalog
=
$self
->auto_formatted_catalog(
$db
);
$schema
=
$self
->auto_formatted_schema(
$db
);
my
$sth
=
$dbh
->column_info(
$catalog
,
$schema
,
$table_unquoted
,
'%'
);
unless
(
defined
$sth
)
{
no
warnings;
die
"No column information found for catalog '"
,
$catalog
,
"' schema '"
,
$schema
,
"' table '"
,
$table_unquoted
,
"'"
;
}
COLUMN:
while
(
my
$col_info
=
$sth
->fetchrow_hashref)
{
CHECK_TABLE:
{
no
warnings;
$col_info
->{
'TABLE_NAME'
} =
$db
->unquote_table_name(
$col_info
->{
'TABLE_NAME'
});
next
COLUMN
unless
((!
$supports_catalog
||
$col_info
->{
'TABLE_CAT'
} eq
$catalog
) &&
$col_info
->{
'TABLE_SCHEM'
} eq
$schema
&&
$col_info
->{
'TABLE_NAME'
} eq
$table_unquoted
);
}
unless
(
defined
$col_info
->{
'COLUMN_NAME'
})
{
Carp::croak
"Could not extract column name from DBI column_info()"
;
}
$db
->refine_dbi_column_info(
$col_info
,
$self
);
$columns
{
$col_info
->{
'COLUMN_NAME'
}} =
$self
->auto_generate_column(
$col_info
->{
'COLUMN_NAME'
},
$col_info
);
}
};
$error
= $@;
}
if
(
$error
|| !
keys
%columns
)
{
no
warnings;
Carp::croak
"Could not auto-generate columns for class $class - "
,
(
$error
||
"no column info found for catalog '"
.
$catalog
.
"' schema '"
.
$schema
.
"' table '$table'"
);
}
$self
->auto_alias_columns(
values
%columns
);
return
wantarray
?
values
%columns
: \
%columns
;
}
sub
auto_alias_columns
{
my
(
$self
) =
shift
;
foreach
my
$column
(
@_
)
{
foreach
my
$type
(
$column
->auto_method_types)
{
my
$method
=
$self
->method_name_from_column(
$column
,
$type
);
if
(
$self
->method_name_is_reserved(
$method
,
$self
->class))
{
$self
->auto_alias_column(
$column
);
last
;
}
}
foreach
my
$type
(
$column
->auto_method_types)
{
my
$method
=
$self
->method_name_from_column(
$column
,
$type
);
if
(
$self
->method_name_is_reserved(
$method
,
$self
->class))
{
Carp::croak
"Cannot create '$type' method named '$method' for "
,
"column '$column' - method name is reserved"
;
}
}
}
}
sub
auto_generate_column
{
my
(
$self
,
$name
,
$col_info
) =
@_
;
my
$type
=
$col_info
->{
'TYPE_NAME'
};
my
$meta_class
=
$self
->original_class;
my
$column_class
=
$meta_class
->column_type_class(
$type
) ||
$meta_class
->column_type_class(
'scalar'
)
or Carp::croak
"No column class set for column types '$type' or 'scalar'"
;
unless
(
$self
->column_class_is_loaded(
$column_class
))
{
$self
->load_column_class(
$column_class
);
}
my
$column
=
$column_class
->new(
name
=>
$name
,
parent
=>
$self
);
$column
->init_with_dbi_column_info(
$col_info
);
return
$column
;
}
sub
init_column_alias_generator {
sub
{
$_
[1] .
'_col'
} }
DEFAULT_FK_NAME_GEN:
{
my
%Seen_FK_Name
;
sub
default_foreign_key_name_generator
{
my
(
$meta
,
$fk
) =
@_
;
my
$class
=
$meta
->class;
my
$key_columns
=
$fk
->key_columns;
my
$name
=
$fk
->name;
if
(
keys
%$key_columns
> 1)
{
$name
=
$fk
->class;
$name
=~ s/::/_/g;
$name
=~ s/([a-z])([A-Z])/$1_$2/g;
$name
=
lc
$name
;
}
else
{
my
(
$local_column
,
$foreign_column
) =
%$key_columns
;
if
(
$local_column
=~ s/_
$foreign_column
$//)
{
$name
=
$local_column
;
}
else
{
if
(!
$meta
->class->can(
$local_column
))
{
$name
=
$local_column
;
}
else
{
$name
=
$local_column
.
'_object'
;
}
}
}
if
(
$Seen_FK_Name
{
$class
}{
$name
})
{
my
$num
= 2;
my
$new_name
=
$name
;
while
(
$Seen_FK_Name
{
$class
}{
$new_name
})
{
$new_name
=
$name
.
$num
++;
}
$name
=
$new_name
;
}
$Seen_FK_Name
{
$class
}{
$name
}++;
return
$name
;
}
}
sub
init_foreign_key_name_generator { \
&default_foreign_key_name_generator
}
sub
auto_alias_column
{
my
(
$self
,
$column
) =
@_
;
my
$code
=
$self
->column_alias_generator;
local
$_
=
$column
->name;
my
$alias
=
$code
->(
$self
,
$_
);
if
(
$self
->method_name_is_reserved(
$alias
,
$self
->class))
{
Carp::croak
"Called column_alias_generator() to alias column "
,
"'$_' but the value returned is a reserved method "
,
"name: $alias"
;
}
$column
->alias(
$alias
);
return
;
}
sub
auto_retrieve_primary_key_column_names
{
my
(
$self
) =
shift
;
unless
(
defined
wantarray
)
{
Carp::croak
"Useless call to auto_retrieve_primary_key_column_names() in void context"
;
}
my
$db
=
$self
->db;
my
$catalog
=
$self
->auto_formatted_catalog(
$db
);
my
$schema
=
$self
->auto_formatted_schema(
$db
);
my
(
$pk_columns
,
$error
);
TRY:
{
local
$@;
eval
{
$pk_columns
=
$self
->db->primary_key_column_names(
table
=>
$self
->table,
catalog
=>
$catalog
,
schema
=>
$schema
);
};
$error
= $@;
}
if
(
$error
|| (!
$Missing_PK_OK
&& !
@$pk_columns
))
{
$error
=
'no primary key columns found'
unless
(
defined
$error
);
Carp::croak
"Could not auto-retrieve primary key columns for class "
,
$self
->class,
" - "
,
(
$error
||
"no primary key info found for catalog '"
.
$catalog
.
"' schema '"
.
$schema
.
"' table '"
.
$self
->table,
"'"
);
}
$pk_columns
||= [];
return
wantarray
?
@$pk_columns
:
$pk_columns
;
}
my
%Warned
;
sub
auto_generate_foreign_keys
{
my
(
$self
,
%args
) =
@_
;
unless
(
defined
wantarray
)
{
Carp::croak
"Useless call to auto_generate_foreign_keys() in void context"
;
}
my
$no_warnings
=
$args
{
'no_warnings'
};
my
(
$class
,
@foreign_keys
,
$total_fks
,
%used_names
,
$error
);
TRY:
{
local
$@;
eval
{
$class
=
$self
->class or
die
"Missing class!"
;
my
$db
=
$self
->db;
my
$dbh
=
$db
->dbh or
die
$db
->error;
local
$dbh
->{
'FetchHashKeyName'
} =
'NAME'
;
my
$catalog
=
$self
->auto_formatted_catalog(
$db
);
my
$schema
=
$self
->auto_formatted_schema(
$db
);
my
$table
=
$db
->likes_lowercase_table_names ?
lc
$self
->table :
$self
->table;
my
$sth
=
$dbh
->foreign_key_info(
undef
,
undef
,
undef
,
$catalog
,
$schema
,
$table
);
return
unless
(
defined
$sth
);
my
(
%fk
,
@fk_info
);
FK:
while
(
my
$fk_info
=
$sth
->fetchrow_hashref)
{
$db
->refine_dbi_foreign_key_info(
$fk_info
,
$self
);
CHECK_TABLE:
{
no
warnings;
next
FK
unless
(
$fk_info
->{
'FK_TABLE_CAT'
} eq
$catalog
&&
$fk_info
->{
'FK_TABLE_SCHEM'
} eq
$schema
&&
$fk_info
->{
'FK_TABLE_NAME'
} eq
$table
);
}
my
$local_column
=
$fk_info
->{
'FK_COLUMN_NAME'
};
my
$foreign_column
=
$fk_info
->{
'UK_COLUMN_NAME'
};
my
$fk_id
=
$fk_info
->{
'RDBO_FK_ID'
} =
$fk_info
->{
'FK_NAME'
} ||
$fk_info
->{
'UK_NAME'
};
$fk
{
$fk_id
}{
'key_columns'
}{
$local_column
} =
$foreign_column
;
push
(
@fk_info
,
$fk_info
);
}
@fk_info
=
sort
{
lc
$a
->{
'UK_TABLE_NAME'
} cmp
lc
$b
->{
'UK_TABLE_NAME'
} }
@fk_info
;
my
$cm
=
$self
->convention_manager;
my
%seen_fk_id
;
FK_INFO:
foreach
my
$fk_info
(
@fk_info
)
{
my
$fk_id
=
$fk_info
->{
'RDBO_FK_ID'
};
next
if
(
$seen_fk_id
{
$fk_id
}++);
my
$foreign_class
=
$self
->class_for(
catalog
=>
$fk_info
->{
'UK_TABLE_CAT'
},
schema
=>
$fk_info
->{
'UK_TABLE_SCHEM'
},
table
=>
$fk_info
->{
'UK_TABLE_NAME'
});
unless
(
$foreign_class
)
{
$foreign_class
=
$self
->convention_manager->related_table_to_class(
$fk_info
->{
'UK_TABLE_NAME'
},
$self
->class);
unless
(UNIVERSAL::isa(
$foreign_class
,
'Rose::DB::Object'
))
{
no
warnings
'uninitialized'
;
eval
"require $foreign_class"
;
$foreign_class
=
undef
if
($@ || !UNIVERSAL::isa(
$foreign_class
,
'Rose::DB::Object'
));
}
}
unless
(
$foreign_class
)
{
my
$key
=
join
($;,
map
{
defined
(
$_
) ?
$_
:
"\034"
}
$self
->class,
@$fk_info
{
qw(UK_TABLE_CAT UK_TABLE_SCHEM UK_TABLE_NAME)
});
$self
->add_deferred_task(
{
class
=>
$self
->class,
method
=>
'auto_init_foreign_keys'
,
args
=> \
%args
,
code
=>
sub
{
$self
->auto_init_foreign_keys(
%args
);
$self
->make_foreign_key_methods(
%args
,
preserve_existing
=> 1);
},
check
=>
sub
{
my
$fks
=
$self
->foreign_keys;
return
@$fks
==
$total_fks
? 1 : 0;
},
});
unless
(
$no_warnings
||
$Warned
{
$key
}++ ||
$self
->allow_auto_initialization)
{
no
warnings;
Carp::carp
"No Rose::DB::Object-derived class found for catalog '"
,
$fk_info
->{
'UK_TABLE_CAT'
},
"' schema '"
,
$fk_info
->{
'UK_TABLE_SCHEM'
},
"' table '"
,
$fk_info
->{
'UK_TABLE_NAME'
},
"'"
;
}
$total_fks
++;
next
FK_INFO;
}
$fk
{
$fk_id
}{
'class'
} =
$foreign_class
;
my
$key_name
=
$cm
->auto_foreign_key_name(
$foreign_class
,
$fk_id
,
$fk
{
$fk_id
}{
'key_columns'
},
\
%used_names
);
$used_names
{
$key_name
}++
if
(
defined
$key_name
);
if
(
defined
$key_name
&&
length
$key_name
)
{
$fk
{
$fk_id
}{
'name'
} =
$key_name
;
}
$total_fks
++;
}
my
(
%seen
,
%seen_name
);
foreach
my
$fk_info
(
@fk_info
)
{
next
if
(
$seen
{
$fk_info
->{
'RDBO_FK_ID'
}}++);
my
$info
=
$fk
{
$fk_info
->{
'RDBO_FK_ID'
}};
my
$fk
= Rose::DB::Object::Metadata::ForeignKey->new(
%$info
);
next
unless
(
defined
$fk
->class);
unless
(
defined
$fk
->name)
{
$fk
->name(
$self
->foreign_key_name_generator->(
$self
,
$fk
));
}
push
(
@foreign_keys
,
$fk
);
}
};
$error
= $@;
}
if
(
$error
)
{
Carp::croak
"Could not auto-generate foreign keys for class $class - $error"
;
}
@foreign_keys
=
sort
{
lc
$a
->name cmp
lc
$b
->name }
@foreign_keys
;
return
wantarray
?
@foreign_keys
: \
@foreign_keys
;
}
sub
auto_init_columns
{
my
(
$self
,
%args
) =
@_
;
my
$auto_columns
=
$self
->auto_generate_columns;
my
$existing_columns
=
$self
->columns;
if
(!
$args
{
'replace_existing'
} &&
keys
%$auto_columns
!=
@$existing_columns
)
{
while
(
my
(
$name
,
$column
) =
each
(
%$auto_columns
))
{
next
if
(
$self
->column(
$name
));
$self
->add_column(
$column
);
}
}
elsif
(
$args
{
'replace_existing'
} || !
@$existing_columns
)
{
$self
->columns(
values
%$auto_columns
);
}
return
;
}
sub
perl_columns_definition
{
my
(
$self
,
%args
) =
@_
;
my
$for_setup
=
$args
{
'for_setup'
};
my
$indent
=
defined
$args
{
'indent'
} ?
$args
{
'indent'
} :
$self
->default_perl_indent;
my
$braces
=
defined
$args
{
'braces'
} ?
$args
{
'braces'
} :
$self
->default_perl_braces;
unless
(
$indent
=~ /^\d+$/)
{
Carp::croak
'Invalid '
, (
defined
$args
{
'indent'
} ?
''
:
'default '
),
"indent size: '$braces'"
;
}
$indent
=
' '
x
$indent
;
my
$def_start
=
$for_setup
?
'columns => '
:
"__PACKAGE__->meta->columns"
;
my
$ob
=
$for_setup
?
'['
:
'('
;
my
$cb
=
$for_setup
?
']'
:
')'
;
if
(
$braces
eq
'bsd'
)
{
$def_start
.=
"\n$ob\n"
;
}
elsif
(
$braces
eq
'k&r'
)
{
$def_start
.=
"$ob\n"
;
}
else
{
Carp::croak
'Invalid '
, (
defined
$args
{
'braces'
} ?
''
:
'default '
),
"brace style: '$braces'"
;
}
my
$max_len
= 0;
my
$min_len
= -1;
foreach
my
$name
(
$self
->column_names)
{
$max_len
=
length
(
$name
)
if
(
length
$name
>
$max_len
);
$min_len
=
length
(
$name
)
if
(
length
$name
<
$min_len
||
$min_len
< 0);
}
my
@col_defs
;
no
warnings
'uninitialized'
;
foreach
my
$column
(
sort
__by_rank
$self
->columns)
{
push
(
@col_defs
,
$column
->perl_hash_definition(
inline
=> 1,
name_padding
=>
$max_len
));
}
$cb
=
$for_setup
?
'],'
:
');'
;
my
$perl
=
$def_start
.
join
(
",\n"
,
map
{
"$indent$_"
}
@col_defs
) .
",\n$cb\n"
;
if
(
$for_setup
)
{
for
(
$perl
)
{
s/^/
$indent
/mg;
s/\n\z//;
s/^[ \t]+$//mg;
}
}
return
$perl
;
}
sub
__by_rank
{
my
$pos1
=
$a
->ordinal_position;
my
$pos2
=
$b
->ordinal_position;
if
(!
$Sort_Columns_Alphabetically
&&
defined
$pos1
&&
defined
$pos2
)
{
return
$pos1
<=>
$pos2
||
lc
(
$a
->name) cmp
lc
(
$b
->name);
}
return
lc
(
$a
->name) cmp
lc
(
$b
->name);
}
sub
perl_foreign_keys_definition
{
my
(
$self
,
%args
) =
@_
;
my
$indent
=
defined
$args
{
'indent'
} ?
$args
{
'indent'
} :
$self
->default_perl_indent;
my
$braces
=
defined
$args
{
'braces'
} ?
$args
{
'braces'
} :
$self
->default_perl_braces;
unless
(
$indent
=~ /^\d+$/)
{
Carp::croak
'Invalid '
, (
defined
$args
{
'indent'
} ?
''
:
'default '
),
"indent size: '$braces'"
;
}
my
$indent_txt
=
' '
x
$indent
;
my
$for_setup
=
$args
{
'for_setup'
};
my
$def
=
$for_setup
?
$indent_txt
.
'foreign_keys => '
:
'__PACKAGE__->meta->foreign_keys'
;
my
$ob
=
$for_setup
?
'['
:
'('
;
my
$cb
=
$for_setup
?
']'
:
')'
;
if
(
$braces
eq
'bsd'
)
{
$def
.=
"\n$ob\n"
;
}
elsif
(
$braces
eq
'k&r'
)
{
$def
.=
"$ob\n"
;
}
else
{
Carp::croak
'Invalid '
, (
defined
$args
{
'braces'
} ?
''
:
'default '
),
"brace style: '$braces'"
;
}
my
@fk_defs
;
foreach
my
$fk
(
$self
->foreign_keys)
{
push
(
@fk_defs
,
$fk
->perl_hash_definition(
indent
=>
$indent
,
braces
=>
$braces
));
}
return
''
unless
(
@fk_defs
);
foreach
my
$fk_def
(
@fk_defs
)
{
for
(
$fk_def
)
{
s/^/
$indent_txt
/mg;
s/^[ \t]+$//mg;
}
$def
.=
"$fk_def,\n"
. (
$fk_def
eq
$fk_defs
[-1] ?
''
:
"\n"
);
}
if
(
$for_setup
)
{
$def
.=
"],\n"
;
for
(
$def
)
{
s/^/
$indent_txt
/mg;
s/\n\z//;
s/\A
$indent_txt
//;
s/^[ \t]+$//mg;
}
return
$def
;
}
else
{
return
$def
.
");\n"
;
}
}
sub
perl_relationships_definition
{
my
(
$self
,
%args
) =
@_
;
my
$indent
=
defined
$args
{
'indent'
} ?
$args
{
'indent'
} :
$self
->default_perl_indent;
my
$braces
=
defined
$args
{
'braces'
} ?
$args
{
'braces'
} :
$self
->default_perl_braces;
unless
(
$indent
=~ /^\d+$/)
{
Carp::croak
'Invalid '
, (
defined
$args
{
'indent'
} ?
''
:
'default '
),
"indent size: '$braces'"
;
}
my
$indent_txt
=
' '
x
$indent
;
my
$for_setup
=
$args
{
'for_setup'
};
my
$def
=
$for_setup
?
$indent_txt
.
'relationships => '
:
'__PACKAGE__->meta->relationships'
;
my
$ob
=
$for_setup
?
'['
:
'('
;
my
$cb
=
$for_setup
?
']'
:
')'
;
if
(
$braces
eq
'bsd'
)
{
$def
.=
"\n$ob\n"
;
}
elsif
(
$braces
eq
'k&r'
)
{
$def
.=
"$ob\n"
;
}
else
{
Carp::croak
'Invalid '
, (
defined
$args
{
'braces'
} ?
''
:
'default '
),
"brace style: '$braces'"
;
}
my
@rel_defs
;
foreach
my
$rel
(
$self
->relationships)
{
next
if
(
$rel
->can(
'foreign_key'
) &&
$rel
->foreign_key);
push
(
@rel_defs
,
$rel
->perl_hash_definition(
indent
=>
$indent
,
braces
=>
$braces
));
}
return
''
unless
(
@rel_defs
);
foreach
my
$rel_def
(
@rel_defs
)
{
for
(
$rel_def
)
{
s/^/
$indent_txt
/mg;
s/^[ \t]+$//mg;
}
$def
.=
"$rel_def,\n"
. (
$rel_def
eq
$rel_defs
[-1] ?
''
:
"\n"
);
}
if
(
$for_setup
)
{
$def
.=
"],\n"
;
for
(
$def
)
{
s/^/
$indent_txt
/mg;
s/\n\z//;
s/\A
$indent_txt
//;
s/^[ \t]+$//mg;
}
return
$def
;
}
else
{
return
$def
.
");\n"
;
}
}
sub
perl_unique_keys_definition
{
my
(
$self
,
%args
) =
@_
;
my
$style
=
defined
$args
{
'style'
} ?
$args
{
'style'
} :
$self
->default_perl_unique_key_style;
my
$indent
=
defined
$args
{
'indent'
} ?
$args
{
'indent'
} :
$self
->default_perl_indent;
my
$braces
=
defined
$args
{
'braces'
} ?
$args
{
'braces'
} :
$self
->default_perl_braces;
unless
(
$indent
=~ /^\d+$/)
{
Carp::croak
'Invalid '
, (
defined
$args
{
'indent'
} ?
''
:
'default '
),
"indent size: '$braces'"
;
}
$indent
=
' '
x
$indent
;
my
$uk_perl_method
;
if
(
$style
eq
'array'
)
{
$uk_perl_method
=
'perl_array_definition'
;
}
elsif
(
$style
eq
'object'
)
{
$uk_perl_method
=
'perl_object_definition'
;
}
else
{
Carp::croak
'Invalid '
, (
defined
$args
{
'style'
} ?
''
:
'default '
),
"unique key style: '$style'"
;
}
my
@uk_defs
;
foreach
my
$uk
(
$self
->unique_keys)
{
push
(
@uk_defs
,
$uk
->
$uk_perl_method
());
}
return
''
unless
(
@uk_defs
);
my
$for_setup
=
$args
{
'for_setup'
};
my
$def_start
=
$for_setup
?
$indent
.
'unique_keys => '
:
'__PACKAGE__->meta->unique_keys'
;
my
$ob
=
$for_setup
?
'['
:
'('
;
my
$cb
=
$for_setup
?
']'
:
')'
;
if
(
@uk_defs
== 1)
{
$def_start
.=
$ob
;
}
elsif
(
$braces
eq
'bsd'
)
{
$def_start
.=
"\n$ob\n"
;
}
elsif
(
$braces
eq
'k&r'
)
{
$def_start
.=
"$ob\n"
;
}
else
{
Carp::croak
'Invalid '
, (
defined
$args
{
'braces'
} ?
''
:
'default '
),
"brace style: '$braces'"
;
}
if
(
$for_setup
)
{
if
(
@uk_defs
== 1)
{
$def_start
=~ s/^(\s*)unique_keys/$1unique_key/;
for
(
$uk_defs
[0])
{
s/\A\[ //;
s/ \]\z//;
}
return
"$def_start $uk_defs[0] ],"
;
}
else
{
my
$perl
=
$def_start
.
join
(
",\n"
,
map
{
"$indent$_"
}
@uk_defs
) .
",\n],"
;
for
(
$perl
)
{
s/^/
$indent
/mg;
s/\A
$indent
//;
s/^[ \t]+$//mg;
}
return
$perl
;
}
}
else
{
if
(
@uk_defs
== 1)
{
return
"$def_start$uk_defs[0]);\n"
;
}
else
{
return
$def_start
.
join
(
",\n"
,
map
{
"$indent$_"
}
@uk_defs
) .
",\n);\n"
;
}
}
}
sub
perl_metadata_attributes
{
my
(
$self
,
%args
) =
@_
;
my
$for_setup
=
$args
{
'for_setup'
};
my
$indent
=
defined
$args
{
'indent'
} ?
$args
{
'indent'
} :
$self
->default_perl_indent;
$indent
=
$for_setup
? (
' '
x
$indent
) :
''
;
my
@attrs
;
foreach
my
$attr
(
qw(allow_inline_column_values)
)
{
no
strict
'refs'
;
if
(
my
$value
=
$self
->
$attr
())
{
if
(
$for_setup
)
{
push
(
@attrs
,
"$attr => "
.
$self
->perl_quote_value(
$value
) .
','
);
}
else
{
push
(
@attrs
,
"__PACKAGE__->meta->$attr("
.
$self
->perl_quote_value(
$value
) .
');'
);
}
}
}
return
@attrs
? (
join
(
"\n"
,
map
{
"$indent$_"
}
@attrs
) . (
$for_setup
?
''
:
"\n"
)) :
''
;
}
sub
perl_quote_value
{
my
(
$self
,
$value
) =
@_
;
return
$value
if
(
$value
=~ /^\d+$/);
for
(
$value
)
{
s/\\/\\\\/g;
s/
'/\\'
/g;
}
return
qq('$value')
;
}
sub
perl_table_definition
{
my
(
$self
,
%args
) =
@_
;
my
$for_setup
=
$args
{
'for_setup'
};
my
$indent
=
defined
$args
{
'indent'
} ?
$args
{
'indent'
} :
$self
->default_perl_indent;
my
$table
=
$self
->table;
$table
=~ s/
'/\\'
/;
if
(
$args
{
'for_setup'
})
{
$indent
=
' '
x
$indent
;
return
qq(${indent}table => '$table',)
;
}
return
qq(__PACKAGE__->meta->table('$table')
;);
}
sub
perl_primary_key_columns_definition
{
my
(
$self
,
%args
) =
@_
;
my
@pk_cols
=
$self
->primary_key->column_names;
Carp::croak
"No primary key columns found for class "
,
ref
(
$self
)
unless
(
@pk_cols
);
if
(
$args
{
'for_setup'
})
{
my
$indent
=
defined
$args
{
'indent'
} ?
$args
{
'indent'
} :
$self
->default_perl_indent;
$indent
=
' '
x
$indent
;
return
$indent
.
'primary_key_columns => '
.
$self
->primary_key->perl_array_definition .
','
;
}
else
{
return
'__PACKAGE__->meta->primary_key_columns('
.
$self
->primary_key->perl_array_definition .
");\n"
;
}
}
sub
perl_class_definition
{
my
(
$self
,
%args
) =
@_
;
my
$indent
=
defined
$args
{
'indent'
} ?
$args
{
'indent'
} :
$self
->default_perl_indent;
my
$braces
=
defined
$args
{
'braces'
} ?
$args
{
'braces'
} :
$self
->default_perl_braces;
my
$class
=
$self
->class;
no
strict
'refs'
;
my
$isa
=
delete
$args
{
'isa'
} || [ ${
"${class}::ISA"
}[0] ||
'Rose::DB::Object'
];
$isa
= [
$isa
]
unless
(
ref
$isa
);
my
%use
;
foreach
my
$fk
(
$self
->foreign_keys)
{
$use
{
$fk
->class}++;
}
foreach
my
$rel
(
$self
->relationships)
{
if
(
$rel
->can(
'map_class'
))
{
$use
{
$rel
->map_class}++;
}
else
{
$use
{
$rel
->class}++;
}
}
my
$foreign_modules
=
''
;
if
(
%use
&& !
$self
->auto_load_related_classes)
{
$foreign_modules
=
"\n\n"
.
join
(
"\n"
,
map
{
"use $_;"
}
sort
keys
%use
);
}
if
(
defined
$args
{
'use_setup'
} && !
$args
{
'use_setup'
})
{
return
<<"EOF";
package $class;
use strict;
use base qw(@$isa);$foreign_modules
@{[ $self->perl_table_definition(%args) ]}
@{[join("\n", grep { /\S/ } $self->perl_columns_definition(%args),
$self->perl_primary_key_columns_definition(%args),
$self->perl_unique_keys_definition(%args),
$self->perl_metadata_attributes(%args),
$self->perl_foreign_keys_definition(%args),
$self->perl_relationships_definition(%args))]}
__PACKAGE__->meta->initialize;
1;
EOF
}
else
{
my
$setup_start
=
'__PACKAGE__->meta->setup'
;
if
(
$braces
eq
'bsd'
)
{
$setup_start
.=
"\n("
;
}
elsif
(
$braces
eq
'k&r'
)
{
$setup_start
.=
"("
;
}
else
{
Carp::croak
'Invalid '
, (
defined
$args
{
'braces'
} ?
''
:
'default '
),
"brace style: '$braces'"
;
}
$args
{
'for_setup'
} = 1;
$indent
=
' '
x
$indent
;
return
<<"EOF";
package $class;
use strict;
use base qw(@$isa);$foreign_modules
$setup_start
@{[join("\n\n", grep { /\S/ } $self->perl_table_definition(%args),
$self->perl_columns_definition(%args),
$self->perl_primary_key_columns_definition(%args),
$self->perl_unique_keys_definition(%args),
$self->perl_metadata_attributes(%args),
$self->perl_foreign_keys_definition(%args),
$self->perl_relationships_definition(%args))]}
);
1;
EOF
}
}
sub
auto_generate_unique_keys {
die
"Override in subclass"
}
sub
auto_init_unique_keys
{
my
(
$self
,
%args
) =
@_
;
return
if
(
exists
$args
{
'with_unique_keys'
} && !
$args
{
'with_unique_keys'
});
my
$pk_cols
=
join
(
"\0"
,
$self
->primary_key_columns);
unless
(
length
$pk_cols
)
{
$pk_cols
=
join
(
"\0"
,
$self
->auto_retrieve_primary_key_column_names);
}
my
$auto_unique_keys
=
$self
->auto_generate_unique_keys;
my
$existing_unique_keys
=
$self
->unique_keys;
if
(!
$args
{
'replace_existing'
} &&
@$auto_unique_keys
!=
@$existing_unique_keys
)
{
KEY:
foreach
my
$key
(
@$auto_unique_keys
)
{
my
$id
=
join
(
"\0"
,
sort
map
{
lc
}
$key
->column_names);
foreach
my
$existing_key
(
@$existing_unique_keys
)
{
next
KEY
if
(
$id
eq
join
(
"\0"
,
sort
map
{
lc
}
$existing_key
->column_names));
}
next
KEY
if
(
$pk_cols
eq
join
(
"\0"
,
$key
->column_names));
$self
->add_unique_key(
$key
);
}
}
elsif
(
$args
{
'replace_existing'
} || !
@$existing_unique_keys
)
{
$self
->unique_keys(
@$auto_unique_keys
);
}
return
;
}
sub
auto_init_foreign_keys
{
my
(
$self
,
%args
) =
@_
;
if
(
exists
$args
{
'with_foreign_keys'
} && !
$args
{
'with_foreign_keys'
})
{
$self
->initialized_foreign_keys(1);
return
;
}
my
$auto_foreign_keys
=
$self
->auto_generate_foreign_keys(
%args
);
my
$existing_foreign_keys
=
$self
->foreign_keys;
if
(!
$args
{
'replace_existing'
} &&
@$auto_foreign_keys
!=
@$existing_foreign_keys
)
{
KEY:
foreach
my
$key
(
@$auto_foreign_keys
)
{
my
$id
= __fk_key_to_id(
$key
);
foreach
my
$existing_key
(
@$existing_foreign_keys
)
{
next
KEY
if
(
$id
eq __fk_key_to_id(
$existing_key
));
}
$self
->add_foreign_key(
$key
);
}
}
elsif
(
$args
{
'replace_existing'
} || !
@$existing_foreign_keys
)
{
$self
->foreign_keys(
@$auto_foreign_keys
);
}
$self
->initialized_foreign_keys(1);
return
;
}
sub
__fk_key_to_id
{
my
(
$fk
) =
shift
;
my
$key_columns
=
$fk
->key_columns;
return
join
(
"\0"
,
map
{
join
(
"\1"
,
$_
,
$key_columns
->{
$_
}) }
sort
keys
%$key_columns
);
}
sub
auto_init_primary_key_columns
{
my
(
$self
) =
shift
;
my
$primary_key_columns
=
$self
->auto_retrieve_primary_key_column_names;
unless
(
$primary_key_columns
&&
@$primary_key_columns
)
{
if
(
$Missing_PK_OK
)
{
$primary_key_columns
= [];
}
else
{
Carp::croak
"Could not retrieve primary key columns for class "
,
ref
(
$self
);
}
}
$self
->primary_key_columns(
@$primary_key_columns
);
return
;
}
my
%Auto_Rel_Types
;
sub
auto_init_relationships
{
my
(
$self
) =
shift
;
my
(
%args
) =
@_
;
my
$type_map
=
$self
->relationship_type_classes;
my
@all_types
=
keys
%$type_map
;
my
%types
;
if
(
delete
$args
{
'restore_types'
})
{
if
(
my
$types
=
$Auto_Rel_Types
{
$self
->class})
{
$args
{
'types'
} =
$types
;
}
}
if
(
exists
$args
{
'relationship_types'
} ||
exists
$args
{
'types'
} ||
exists
$args
{
'with_relationships'
})
{
my
$types
=
exists
$args
{
'relationship_types'
} ?
delete
$args
{
'relationship_types'
} :
exists
$args
{
'types'
} ?
delete
$args
{
'types'
} :
exists
$args
{
'with_relationships'
} ?
delete
$args
{
'with_relationships'
} : 1;
if
(
ref
$types
)
{
%types
=
map
{
$_
=> 1 }
@$types
;
$Auto_Rel_Types
{
$self
->class} =
$types
;
}
elsif
(
$types
)
{
%types
=
map
{
$_
=> 1 }
@all_types
;
}
else
{
$Auto_Rel_Types
{
$self
->class} = [];
}
}
else
{
%types
=
map
{
$_
=> 1 }
@all_types
;
}
if
(
delete
$args
{
'replace_existing'
})
{
foreach
my
$rel
(
$self
->relationships)
{
next
unless
(
$types
{
$rel
->type});
$self
->delete_relationship(
$rel
->name);
}
}
foreach
my
$type
(
sort
{
$self
->sort_relationship_types(
$a
,
$b
) }
keys
%types
)
{
my
$type_name
=
$type
;
for
(
$type_name
)
{
s/ /_/g;
s/\W+//g;
}
my
$method
=
'auto_init_'
.
$type_name
.
'_relationships'
;
if
(
$self
->can(
$method
))
{
$self
->
$method
(
@_
);
}
}
return
;
}
sub
sort_relationship_types
{
my
(
$self
,
$a
,
$b
) =
@_
;
return
$self
->relationship_type_rank(
$a
) <=>
$self
->relationship_type_rank(
$b
);
}
sub
auto_init_one_to_one_relationships
{
my
(
$self
,
%args
) =
@_
;
my
$class
=
$self
->class;
FK:
foreach
my
$fk
(
$self
->foreign_keys)
{
my
$f_class
=
$fk
->class;
next
unless
(
$f_class
&& UNIVERSAL::isa(
$f_class
,
'Rose::DB::Object'
));
my
$f_meta
=
$f_class
->meta;
my
$key_cols
=
$fk
->key_columns;
my
$local_key
=
join
(
"\0"
,
sort
keys
%$key_cols
);
my
$remote_key
=
join
(
"\0"
,
sort
values
%$key_cols
);
my
(
$local_unique
,
$remote_unique
);
my
$local_meta
=
$class
->meta;
foreach
my
$uk
(
$local_meta
->primary_key,
$local_meta
->unique_keys)
{
my
$key
=
join
(
"\0"
,
sort
$uk
->columns);
if
(
$key
eq
$local_key
)
{
$local_unique
= 1;
last
;
}
}
foreach
my
$uk
(
$f_meta
->primary_key,
$f_meta
->unique_keys)
{
my
$key
=
join
(
"\0"
,
sort
$uk
->columns);
if
(
$key
eq
$remote_key
)
{
$remote_unique
= 1;
last
;
}
}
unless
(
$local_unique
&&
$remote_unique
)
{
next
FK;
}
$fk
->relationship_type(
'one to one'
);
foreach
my
$rel
(
$self
->relationships)
{
next
unless
(
$rel
->can(
'foreign_key'
));
my
$rel_fk
=
$rel
->foreign_key or
next
;
if
(
$rel_fk
eq
$fk
)
{
my
$new_rel
=
$self
->_build_relationship(
name
=>
$rel
->name,
type
=>
'one to one'
,
info
=>
{
class
=>
$rel
->class,
column_map
=>
scalar
$rel
->column_map,
});
$new_rel
->foreign_key(
$fk
);
$self
->relationship(
$rel
->
name
=>
$new_rel
);
}
}
my
$cm
=
$f_meta
->convention_manager;
if
(
$cm
->is_map_class(
$class
) && !
$args
{
'include_map_class_relationships'
})
{
$Debug
&&
warn
"$f_class - Refusing to make one to one relationship "
,
"to map class to $class\n"
;
next
FK;
}
my
$name
=
$cm
->auto_relationship_name_one_to_one(
$self
->table,
$class
);
my
$relationship
=
$f_meta
->_build_relationship(
name
=>
$name
,
type
=>
'one to one'
,
info
=>
{
class
=>
$class
,
column_map
=> {
reverse
%$key_cols
},
});
foreach
my
$rel
(
$f_meta
->relationships)
{
next
FK
if
(
$relationship
->id eq
$rel
->id);
}
unless
(
$f_meta
->relationship(
$name
))
{
$Debug
&&
warn
"$f_class - Adding one to one relationship "
,
"'$name' to $class\n"
;
$f_meta
->add_relationship(
$relationship
);
}
$f_meta
->make_relationship_methods(
name
=>
$name
,
preserve_existing
=> 1);
}
return
;
}
sub
auto_init_many_to_one_relationships { }
sub
auto_init_one_to_many_relationships
{
my
(
$self
,
%args
) =
@_
;
my
$class
=
$self
->class;
FK:
foreach
my
$fk
(
$self
->foreign_keys)
{
my
$f_class
=
$fk
->class;
next
unless
(
$f_class
&& UNIVERSAL::isa(
$f_class
,
'Rose::DB::Object'
));
my
$f_meta
=
$f_class
->meta;
my
$key_cols
=
$fk
->key_columns;
REL:
foreach
my
$rel
(
$f_meta
->relationships)
{
if
(
$rel
->can(
'map_class'
))
{
next
unless
(
$rel
->map_class eq
$class
);
}
else
{
next
unless
(
$rel
->class eq
$class
);
}
if
(
$rel
->type eq
'one to one'
&& !
$rel
->foreign_key)
{
my
$skip
= 1;
my
$col_map
=
$rel
->column_map or
next
REL;
foreach
my
$remote_col
(
values
%$col_map
)
{
$skip
= 0
unless
(
$key_cols
->{
$remote_col
});
}
next
FK
if
(
$skip
);
}
}
my
$local_key
=
join
(
"\0"
,
sort
keys
%$key_cols
);
my
$remote_key
=
join
(
"\0"
,
sort
values
%$key_cols
);
my
(
$local_unique
,
$remote_unique
);
my
$local_meta
=
$class
->meta;
foreach
my
$uk
(
$local_meta
->primary_key,
$local_meta
->unique_keys)
{
my
$key
=
join
(
"\0"
,
sort
$uk
->columns);
if
(
$key
eq
$local_key
)
{
$local_unique
= 1;
last
;
}
}
foreach
my
$uk
(
$f_meta
->primary_key,
$f_meta
->unique_keys)
{
my
$key
=
join
(
"\0"
,
sort
$uk
->columns);
if
(
$key
eq
$remote_key
)
{
$remote_unique
= 1;
last
;
}
}
if
(
$local_unique
&&
$remote_unique
)
{
next
FK;
}
my
$cm
=
$f_meta
->convention_manager;
if
(
$cm
->is_map_class(
$class
) && !
$args
{
'include_map_class_relationships'
})
{
$Debug
&&
warn
"$f_class - Refusing to make one to many relationship "
,
"to map class to $class\n"
;
next
FK;
}
my
$name
=
$cm
->auto_relationship_name_one_to_many(
$self
->table,
$class
);
my
$relationship
=
$f_meta
->_build_relationship(
name
=>
$name
,
type
=>
'one to many'
,
info
=>
{
class
=>
$class
,
column_map
=> {
reverse
%$key_cols
},
});
foreach
my
$rel
(
$f_meta
->relationships)
{
next
FK
if
(
$relationship
->id eq
$rel
->id);
}
unless
(
$f_meta
->relationship(
$name
))
{
$Debug
&&
warn
"$f_class - Adding one to many relationship "
,
"'$name' to $class\n"
;
$f_meta
->add_relationship(
$relationship
);
}
$f_meta
->make_relationship_methods(
name
=>
$name
,
preserve_existing
=> 1);
}
return
;
}
sub
auto_init_many_to_many_relationships
{
my
(
$self
,
%args
) =
@_
;
my
$class
=
$self
->class;
my
$cm
=
$self
->convention_manager;
return
unless
(
$cm
->is_map_class(
$class
));
my
@fks
=
$self
->foreign_keys;
return
unless
(
@fks
== 2);
my
$key_cols1
=
$fks
[0]->key_columns;
my
$key_cols2
=
$fks
[1]->key_columns;
return
unless
(
$key_cols1
&&
keys
%$key_cols1
&&
$key_cols2
&&
keys
%$key_cols2
);
my
$map_class
=
$class
;
PAIR:
foreach
my
$pair
([
@fks
], [
reverse
@fks
])
{
my
(
$fk1
,
$fk2
) =
@$pair
;
my
$class1
=
$fk1
->class;
my
$class2
=
$fk2
->class;
my
$meta
=
$class1
->meta;
my
$name
=
$cm
->auto_relationship_name_many_to_many(
$fk2
,
$map_class
);
my
$relationship
=
$meta
->_build_relationship(
name
=>
$name
,
type
=>
'many to many'
,
info
=>
{
map_class
=>
$map_class
,
map_from
=>
$fk1
->name,
map_to
=>
$fk2
->name,
});
foreach
my
$rel
(
$meta
->relationships)
{
next
PAIR
if
(
$relationship
->id eq
$rel
->id);
}
unless
(
$meta
->relationship(
$name
))
{
$Debug
&&
warn
"$class1 - Adding many to many relationship '$name' "
,
"through $map_class to $class2\n"
;
$meta
->add_relationship(
$relationship
);
}
$meta
->make_relationship_methods(
name
=>
$name
,
preserve_existing
=> 1);
}
return
;
}
sub
auto_init_metadata_attributes
{
my
(
$self
,
%args
) =
@_
;
foreach
my
$column
(
$self
->columns)
{
no
warnings
'uninitialized'
;
if
(
$column
->
default
=~ /^\w+\(.*\)$/)
{
$self
->allow_inline_column_values(1);
last
;
}
}
}
sub
auto_initialize
{
my
(
$self
) =
shift
;
my
(
%args
) =
@_
;
$self
->auto_init_args({
%args
});
$self
->allow_auto_initialization(1);
$self
->is_auto_initializating(1);
$self
->auto_init_columns(
@_
);
$self
->auto_init_primary_key_columns;
$self
->auto_init_unique_keys(
@_
);
$self
->auto_init_foreign_keys(
@_
);
$self
->auto_init_relationships(
@_
);
$self
->auto_init_metadata_attributes(
@_
);
$self
->initialize(
@_
);
unless
(
$args
{
'stay_connected'
})
{
my
$meta_class
=
ref
$self
;
$meta_class
->clear_all_dbs;
}
$self
->is_auto_initializating(0);
$self
->was_auto_initialized(1);
return
;
}
1;