use
vars
qw( $NAME $BELONGS_TO @INCORPORATES_L $BGCOLOR $_DEBUG )
;
my
%fields
= (
INCORPORATES
=>
undef
,
LABELS_L
=>
undef
,
);
sub
new {
my
$proto
=
shift
;
my
$class
=
ref
(
$proto
) ||
$proto
;
my
$self
=
bless
(
$class
->SUPER::new(
'PRIMARY'
,
shift
),
$class
);
for
my
$element
(
keys
%fields
) {
$self
->{_PERMITTED}->{
$element
} =
$fields
{
$element
};
}
@{
$self
}{
keys
%fields
} =
values
%fields
;
my
$table
=
shift
;
$self
->belongs_to(
$table
);
my
(
@bad
,
@labels
);
if
(
defined
(
$_
[0]) ) {
my
@columns
=
$table
->attribute_names;
@labels
= @{
$_
[0]};
for
my
$label
(
@labels
) {
push
(
@bad
,
$label
)
unless
grep
(/^
$label
$/,
@columns
);
}
die
"label column(s) '@bad' do not exist in '"
,
$table
->name,
"'"
if
@bad
;
}
else
{
@labels
=
$table
->attribute_names;
}
$self
->labels_l(\
@labels
);
$self
->bgcolor(
'#00ff00'
);
return
$self
;
}
sub
as_sql {
my
$self
= attr
shift
;
return
"PRIMARY KEY ("
.
join
(
','
,
$self
->attribute_names) .
")"
;
}
sub
html_select_field {
my
$self
= attr
shift
;
my
@labels
=
$_
[0] || @{
$self
->labels_l};
my
$multiple
=
$_
[1];
my
$default
=
$multiple
?
$_
[2] :
$_
[2]->[0];
my
$name
=
$_
[3];
my
@pk_columns
=
$self
->attribute_names;
my
$pk
=
join
(
','
,
@pk_columns
);
my
@columns
= (
@pk_columns
,
@labels
);
my
(
%tables
,
%where
);
my
$table_name
=
$self
->BELONGS_TO->name;
@{
$tables
{
$table_name
}} =
@pk_columns
;
my
$order
=
'ORDER BY '
;
for
my
$label
(
@labels
) {
my
(
$table_name
,
@labels
);
my
(
$attribute
) =
$BELONGS_TO
->get_attributes(
$label
);
if
(
my
(
$fk
) =
$BELONGS_TO
->in_foreign_key(
$attribute
) ) {
$table_name
=
$fk
->references->belongs_to->name;
@labels
= @{
$fk
->references->labels_l};
$where
{
$table_name
} =
$fk
->sql_where;
}
else
{
$table_name
=
$BELONGS_TO
->name;
@labels
= (
$label
);
}
push
@{
$tables
{
$table_name
}},
@labels
;
for
(
@labels
) {
$order
.=
"$table_name.$_,"
}
}
chop
$order
;
my
$from
=
'FROM '
.
join
(
','
,
keys
(
%tables
));
my
$select
=
'SELECT '
;
for
( @{
$tables
{
$table_name
}} ) {
$select
.=
"$table_name.$_,"
}
delete
$tables
{
$table_name
};
while
(
my
(
$table
,
$col_ref
) =
each
%tables
) {
for
(
@$col_ref
) {
$select
.=
"$table.$_,"
}
}
chop
$select
;
my
@where
=
values
(
%where
);
my
$where
=
@where
?
'WHERE '
:
''
;
for
(
my
$i
= 0;
$i
<=
$#where
;
$i
++ ) {
$where
.=
' AND '
if
$i
;
$where
.=
$where
[
$i
];
}
my
$sql
=
"$select\n$from\n$where\n$order\n"
;
print
STDERR
$sql
if
$_DEBUG
;
my
$sth
= DbFramework::Util::do_sql(
$BELONGS_TO
->dbh,
$sql
);
my
(
@pk_values
,
%labels
,
@row
);
my
$i
= 0;
$pk_values
[
$i
++] =
''
;
$labels
{
''
} =
'** Any Value **'
;
$pk_values
[
$i
++] =
'NULL'
;
$labels
{
'NULL'
} =
'NULL'
;
while
(
my
$row_ref
=
$sth
->fetchrow_arrayref ) {
@row
= @{
$row_ref
};
my
$pk
=
join
(
','
,
@row
[0..
$#pk_columns
]); # pk fields
$pk_values
[
$i
++] =
$pk
;
for
(
@row
[
$#pk_columns
+1..
$#row
] ) {
$labels
{
$pk
} .=
' '
if
defined
(
$labels
{
$pk
});
$labels
{
$pk
} .=
defined
(
$_
) ?
$_
:
'NULL'
;
}
}
$name
=
$pk
unless
$name
;
my
$html
;
my
$cgi
= new CGI(
''
);
if
(
$multiple
) {
$html
=
$cgi
->scrolling_list(
-name
=>
$name
,
-values
=>\
@pk_values
,
-labels
=>\
%labels
,
-multiple
=>
'true'
,
-default
=>
$default
,
);
}
else
{
$html
=
$cgi
->popup_menu(
-name
=>
$name
,
-values
=>\
@pk_values
,
-labels
=>\
%labels
,
-default
=>
$default
,
);
}
return
$html
;
}
sub
_input_template {
my
(
$self
,
@fk_attributes
) =
@_
;
attr
$self
;
print
STDERR
"$self: _input_template(@fk_attributes)\n"
if
$_DEBUG
;
my
$t_name
=
$BELONGS_TO
?
$BELONGS_TO
->name :
'UNKNOWN_TABLE'
;
my
$in
;
for
my
$attribute
(
@INCORPORATES_L
) {
my
$a_name
=
$attribute
->name;
unless
(
grep
(/^
$a_name
$/,
@fk_attributes
) ) {
print
STDERR
"Adding $a_name to input template for pk in $t_name\n"
if
$_DEBUG
;
$in
.=
qq{<TD><DbField ${t_name}
.${a_name}></TD>
};
}
}
$in
;
}
sub
_output_template {
my
(
$self
,
@fk_attributes
) =
@_
;
attr
$self
;
my
$t_name
=
$BELONGS_TO
?
$BELONGS_TO
->name :
'UNKNOWN_TABLE'
;
my
$out
;
for
(
@INCORPORATES_L
) {
my
$a_name
=
$_
->name;
unless
(
grep
(/^
$a_name
$/,
@fk_attributes
) ) {
$out
.=
qq{<TD BGCOLOR='$BGCOLOR'><DbValue ${t_name}
.${a_name}></TD>};
}
}
$out
;
}
sub
as_html_heading {
my
$self
= attr
shift
;
my
@fk_attributes
=
@_
;
my
@attributes
;
for
(
@INCORPORATES_L
) {
my
$a_name
=
$_
->name;
push
(
@attributes
,
$_
)
unless
grep
(/^
$a_name
$/,
@fk_attributes
);
}
return
''
unless
@attributes
;
my
$html
=
"<TD BGCOLOR='$BGCOLOR' COLSPAN="
.
scalar
(
@attributes
).
">"
;
for
(
@attributes
) {
my
$a_name
=
$_
->name;
my
$extra
=
$_
->references->extra
?
' ('
.
$_
->references->extra.
')'
:
''
;
$html
.=
"$a_name$extra,"
;
}
chop
(
$html
);
"$html</TD>"
;
}
sub
as_query_string {
my
$self
= attr
shift
;
my
%values
=
$_
[0] ? %{
$_
[0]} : ();
my
$qs
;
for
(
$self
->attribute_names ) {
my
$value
=
$values
{
$_
} ?
$values
{
$_
} :
''
;
$qs
.=
"$_=$value&"
;
}
chop
(
$qs
);
uri_escape(
$qs
);
}
sub
as_hidden_html {
my
$self
= attr
shift
;
my
%values
=
$_
[0] ? %{
$_
[0]} : ();
my
$table_name
=
$self
->BELONGS_TO->name;
my
$html
;
for
(
$self
->attribute_names ) {
my
$value
=
defined
(
$values
{
$_
}) ?
$values
{
$_
} :
''
;
$html
.=
qq{<input type="hidden" name="pk_$_" value="$value">\n}
;
}
$html
;
}
1;