Initial commit.
This commit is contained in:
273
forms/dbforms.cgi
Executable file
273
forms/dbforms.cgi
Executable file
@@ -0,0 +1,273 @@
|
||||
#!/usr/local/bin/perl -I../..
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
dbforms.cgi - Forms interface to DbFramework databases
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
http://foo/cgi_bin/dbforms.cgi?db=foo&db_dsn=mysql:database=foo&c_dsn=mysql:database=dbframework_catalog
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
B<dbforms.cgi> presents a simple HTML forms interface to any database
|
||||
configured to work with B<DbFramework>. The database B<must> have the
|
||||
appropriate catalog entries in the catalog database before it will
|
||||
work with this script (see L<DbFramework::Catalog/"The Catalog">.)
|
||||
|
||||
=head2 Query string arguments
|
||||
|
||||
The following arguments are supported in the query string. Mandatory
|
||||
arguments are shown in B<bold>.
|
||||
|
||||
=over 4
|
||||
|
||||
=item B<db>
|
||||
|
||||
The name of the database.
|
||||
|
||||
=item B<db_dsn>
|
||||
|
||||
The portion of the DBI DSN after 'DBI:' to be used to connect to the
|
||||
database e.g. 'mysql:database=foo'.
|
||||
|
||||
=item B<c_dsn>
|
||||
|
||||
The portion of the DBI DSN after 'DBI:' to be used to connect to the
|
||||
catalog database e.g. 'mysql:database=dbframework_catalog'.
|
||||
|
||||
=item B<host>
|
||||
|
||||
The host on which the database is located (default = 'localhost'.)
|
||||
|
||||
=back
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<DbFramework::Catalog>.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Paul Sharpe E<lt>paul@miraclefish.comE<gt>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 1999 Paul Sharpe. England. All rights reserved. This
|
||||
program is free software; you can redistribute it and/or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
|
||||
use lib '../..';
|
||||
use DbFramework::Util;
|
||||
use DbFramework::Persistent;
|
||||
use DbFramework::DataModel;
|
||||
use DbFramework::Template;
|
||||
use DbFramework::Catalog;
|
||||
use CGI qw/:standard/;
|
||||
use URI::Escape;
|
||||
|
||||
$cgi = new CGI;
|
||||
$db = $cgi->param('db') || die "No database specified";
|
||||
$db_dsn = $cgi->param('db_dsn') || die "No database DBI string specified";
|
||||
$c_dsn = $cgi->param('c_dsn') || die "No catalog DBI string specified";
|
||||
$host = $cgi->param('host') || undef;
|
||||
$form = $cgi->param('form') || 'input';
|
||||
$action = $cgi->param('action') || 'select';
|
||||
$dsn = "DBI:$db_dsn";
|
||||
$dsn = "$dsn;host=$host" if $host;
|
||||
$dm = new DbFramework::DataModel($db,$dsn);
|
||||
$dm->dbh->{PrintError} = 0; # ePerl chokes on STDERR
|
||||
$dbh = $dm->dbh; $dbh->{PrintError} = 0;
|
||||
$dm->init_db_metadata("DBI:$c_dsn");
|
||||
|
||||
@tables = @{$dm->collects_table_l};
|
||||
$class = $table = $cgi->param('table') || $tables[0]->name;
|
||||
$template = new DbFramework::Template(undef,\@tables);
|
||||
$template->default($table);
|
||||
|
||||
$code = DbFramework::Persistent->make_class($class);
|
||||
eval $code;
|
||||
|
||||
package main;
|
||||
($t) = $dm->collects_table_h_byname($table);
|
||||
$catalog = new DbFramework::Catalog("DBI:$c_dsn");
|
||||
$thing = new $class($t,$dbh,$catalog);
|
||||
cgi_set_attributes($thing);
|
||||
|
||||
# unless ( $form eq 'input' ) {
|
||||
# $thing->init_pk;
|
||||
# $thing->table->read_form($form);
|
||||
# }
|
||||
|
||||
# unpack composite column name parameters
|
||||
for my $param ( $cgi->param ) {
|
||||
if ( $param =~ /,/ ) {
|
||||
my @columns = split /,/,$param;
|
||||
my @values = split /,/,$cgi->param($param);
|
||||
for ( my $i = 0; $i <= $#columns; $i++ ) {
|
||||
$cgi->param($columns[$i],$values[$i]);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub cgi_set_attributes {
|
||||
my $thing = shift;
|
||||
my %attributes;
|
||||
for ( $thing->table->attribute_names ) {
|
||||
$attributes{$_} = $cgi->param($_) ne '' ? $cgi->param($_) : undef;
|
||||
}
|
||||
$thing->attributes_h([%attributes]);
|
||||
}
|
||||
|
||||
sub error {
|
||||
my $message = shift;
|
||||
print "<font color=#ff0000><strong>ERROR!</strong><p>$message</font>\n";
|
||||
}
|
||||
|
||||
print $cgi->header;
|
||||
print <<EOF;
|
||||
<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML//EN">
|
||||
<html>
|
||||
<head>
|
||||
<title>$db: $table</title>
|
||||
</head>
|
||||
|
||||
<body>
|
||||
<table border=1>
|
||||
<tr>
|
||||
<td valign=top>
|
||||
<table>
|
||||
<tr>
|
||||
<td valign=top>
|
||||
<h1>db: $db</h1>
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td>
|
||||
<h4>Tables</h4>
|
||||
<ul>
|
||||
EOF
|
||||
|
||||
for ( @{$dm->collects_table_l} ) {
|
||||
my $table = $_->name;
|
||||
print "<li><a href=",$cgi->url,"?db=$db&driver=$driver&db_dsn=$db_dsn&c_dsn=$c_dsn&host=$host&table=$table>$table</a>\n";
|
||||
}
|
||||
|
||||
print <<EOF;
|
||||
</ul>
|
||||
</td>
|
||||
</tr>
|
||||
</table>
|
||||
</td>
|
||||
<td valign=top>
|
||||
<table border=0>
|
||||
<tr>
|
||||
<td colspan=2 align=middle>
|
||||
<h1>$table</h1>
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td>
|
||||
EOF
|
||||
|
||||
if ( $form eq 'input' ) {
|
||||
my $self_url = $cgi->self_url;
|
||||
print "<form method=post action=$self_url>\n";
|
||||
for ( qw(host driver db db_dsn c_dsn table form) ) {
|
||||
print "<input type=hidden name=$_ value=",$$_,">\n";
|
||||
}
|
||||
my $values_hashref = $thing->table_qualified_attribute_hashref;
|
||||
print $thing->table->as_html_heading,"\n<tr>\n";
|
||||
print $template->fill($values_hashref);
|
||||
for ( 'select','insert' ) {
|
||||
print "<td><input type=radio name=action value=$_";
|
||||
print ' checked' if /^$action$/;
|
||||
print "> $_</td>\n";
|
||||
}
|
||||
print <<EOF;
|
||||
<td><input type=submit value="Submit"></td>
|
||||
</form>
|
||||
EOF
|
||||
}
|
||||
print <<EOF;
|
||||
</tr>
|
||||
</td>
|
||||
</tr>
|
||||
EOF
|
||||
|
||||
my $action = $cgi->param('action') || '';
|
||||
|
||||
SWITCH: {
|
||||
$action eq 'select' &&
|
||||
do {
|
||||
my @names = $thing->table->attribute_names;
|
||||
my $conditions;
|
||||
for ( @names ) {
|
||||
if ( $cgi->param($_) ) {
|
||||
$conditions .= " AND " if $conditions;
|
||||
if ( $thing->table->in_foreign_key($thing->table->contains_h_byname($_)) ) {
|
||||
$conditions .= "$_ = " . $cgi->param($_);
|
||||
} else {
|
||||
$conditions .= "$_ " . $cgi->param($_);
|
||||
}
|
||||
}
|
||||
}
|
||||
my @things = eval { $thing->select($conditions) };
|
||||
if ( $@ ) {
|
||||
error($@);
|
||||
} else {
|
||||
if ( @things ) {
|
||||
for my $thing ( @things ) {
|
||||
my %attributes = %{$thing->attributes_h};
|
||||
my $url = $cgi->url . "?db=$db&db_dsn=$db_dsn&c_dsn=$c_dsn&host=$host&table=$table&form=$form&action=update";
|
||||
for ( keys(%attributes) ) {
|
||||
$url .= uri_escape("&$_=$attributes{$_}");
|
||||
}
|
||||
# fill template
|
||||
my $values_hashref = $thing->attributes_h;
|
||||
print "<form method=post action=",$cgi->self_url,">\n";
|
||||
for ( qw(host driver db db_dsn c_dsn table form) ) {
|
||||
print "<input type=hidden name=$_ value=",$$_,">\n";
|
||||
}
|
||||
print $thing->table->is_identified_by->as_hidden_html($values_hashref);
|
||||
print "<TR>",$template->fill($thing->table_qualified_attribute_hashref),"\n";
|
||||
print "<td><input type=radio name=action value=update",($action eq 'select') ? ' checked>' : '',"update</td>\n";
|
||||
print "<td><input type=radio name=action value=delete>",($action eq 'delete') ? ' checked' : '',"delete</td>\n";
|
||||
print "<td><input type=submit value='Submit'></td></tr></form>\n";
|
||||
}
|
||||
} else {
|
||||
print "<TR><TD><strong>No rows matched your query</strong></TD></TR>\n";
|
||||
}
|
||||
}
|
||||
last SWITCH;
|
||||
};
|
||||
$action =~ /^(insert|update|delete)$/ &&
|
||||
do {
|
||||
my %attributes;
|
||||
if ( $action =~ /update/ ) {
|
||||
# make update condition from current pk
|
||||
for my $param ( $cgi->param ) {
|
||||
if ( my($pk_column) = $param =~ /^pk_(\w+)$/ ) {
|
||||
$attributes{$pk_column} = $cgi->param($param);
|
||||
}
|
||||
}
|
||||
}
|
||||
cgi_set_attributes($thing);
|
||||
eval { $thing->$action(\%attributes); };
|
||||
error($@) if $@;
|
||||
}
|
||||
}
|
||||
$dm->dbh->disconnect;
|
||||
$dbh->disconnect;
|
||||
|
||||
print <<EOF;
|
||||
</table>
|
||||
</td>
|
||||
</tr>
|
||||
</table>
|
||||
</body>
|
||||
</html>
|
||||
EOF
|
||||
Reference in New Issue
Block a user