commit ca4eef314f0b91c34806ad232cd77939bf19b59a Author: 依瑪貓 Date: Mon Feb 8 00:21:11 2021 +0800 Initial commit. diff --git a/AUTHORS b/AUTHORS new file mode 100644 index 0000000..785f9cc --- /dev/null +++ b/AUTHORS @@ -0,0 +1,3 @@ +Version since 1.11 maintained by imacat + +Version 1.10 and earlier written by Paul Sharpe . diff --git a/Artistic b/Artistic new file mode 100644 index 0000000..5f22124 --- /dev/null +++ b/Artistic @@ -0,0 +1,131 @@ + + + + + The "Artistic License" + + Preamble + +The intent of this document is to state the conditions under which a +Package may be copied, such that the Copyright Holder maintains some +semblance of artistic control over the development of the package, +while giving the users of the package the right to use and distribute +the Package in a more-or-less customary fashion, plus the right to make +reasonable modifications. + +Definitions: + + "Package" refers to the collection of files distributed by the + Copyright Holder, and derivatives of that collection of files + created through textual modification. + + "Standard Version" refers to such a Package if it has not been + modified, or has been modified in accordance with the wishes + of the Copyright Holder as specified below. + + "Copyright Holder" is whoever is named in the copyright or + copyrights for the package. + + "You" is you, if you're thinking about copying or distributing + this Package. + + "Reasonable copying fee" is whatever you can justify on the + basis of media cost, duplication charges, time of people involved, + and so on. (You will not be required to justify it to the + Copyright Holder, but only to the computing community at large + as a market that must bear the fee.) + + "Freely Available" means that no fee is charged for the item + itself, though there may be fees involved in handling the item. + It also means that recipients of the item may redistribute it + under the same conditions they received it. + +1. You may make and give away verbatim copies of the source form of the +Standard Version of this Package without restriction, provided that you +duplicate all of the original copyright notices and associated disclaimers. + +2. You may apply bug fixes, portability fixes and other modifications +derived from the Public Domain or from the Copyright Holder. A Package +modified in such a way shall still be considered the Standard Version. + +3. You may otherwise modify your copy of this Package in any way, provided +that you insert a prominent notice in each changed file stating how and +when you changed that file, and provided that you do at least ONE of the +following: + + a) place your modifications in the Public Domain or otherwise make them + Freely Available, such as by posting said modifications to Usenet or + an equivalent medium, or placing the modifications on a major archive + site such as uunet.uu.net, or by allowing the Copyright Holder to include + your modifications in the Standard Version of the Package. + + b) use the modified Package only within your corporation or organization. + + c) rename any non-standard executables so the names do not conflict + with standard executables, which must also be provided, and provide + a separate manual page for each non-standard executable that clearly + documents how it differs from the Standard Version. + + d) make other distribution arrangements with the Copyright Holder. + +4. You may distribute the programs of this Package in object code or +executable form, provided that you do at least ONE of the following: + + a) distribute a Standard Version of the executables and library files, + together with instructions (in the manual page or equivalent) on where + to get the Standard Version. + + b) accompany the distribution with the machine-readable source of + the Package with your modifications. + + c) give non-standard executables non-standard names, and clearly + document the differences in manual pages (or equivalent), together + with instructions on where to get the Standard Version. + + d) make other distribution arrangements with the Copyright Holder. + +5. You may charge a reasonable copying fee for any distribution of this +Package. You may charge any fee you choose for support of this +Package. You may not charge a fee for this Package itself. However, +you may distribute this Package in aggregate with other (possibly +commercial) programs as part of a larger (possibly commercial) software +distribution provided that you do not advertise this Package as a +product of your own. You may embed this Package's interpreter within +an executable of yours (by linking); this shall be construed as a mere +form of aggregation, provided that the complete Standard Version of the +interpreter is so embedded. + +6. The scripts and library files supplied as input to or produced as +output from the programs of this Package do not automatically fall +under the copyright of this Package, but belong to whoever generated +them, and may be sold commercially, and may be aggregated with this +Package. If such scripts or library files are aggregated with this +Package via the so-called "undump" or "unexec" methods of producing a +binary executable image, then distribution of such an image shall +neither be construed as a distribution of this Package nor shall it +fall under the restrictions of Paragraphs 3 and 4, provided that you do +not represent such an executable image as a Standard Version of this +Package. + +7. C subroutines (or comparably compiled subroutines in other +languages) supplied by you and linked into this Package in order to +emulate subroutines and variables of the language defined by this +Package shall not be considered part of this Package, but are the +equivalent of input as in Paragraph 6, provided these subroutines do +not change the language in any way that would cause it to fail the +regression tests for the language. + +8. Aggregation of this Package with a commercial distribution is always +permitted provided that the use of this Package is embedded; that is, +when no overt attempt is made to make this Package's interfaces visible +to the end user of the commercial distribution. Such use shall not be +construed as a distribution of this Package. + +9. The name of the Copyright Holder may not be used to endorse or promote +products derived from this software without specific prior written permission. + +10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED +WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. + + The End diff --git a/Build.PL b/Build.PL new file mode 100755 index 0000000..cffb144 --- /dev/null +++ b/Build.PL @@ -0,0 +1,309 @@ +#! /usr/bin/perl -w +use Module::Build; +use lib qw(lib); +use DbFramework::Util; +require 't/util.pl'; + +$catalog_db = 'dbframework_catalog'; +%keytypes = (primary => 0, foreign => 1, index => 2); + +Module::Build->prompt(<prompt("$config exists, use it?", "Y") =~ /^y/i ) { + # select drivers to test + my @drivers = grep eval "require DBD::$_; 1;", qw/mysql mSQL Pg/; + my $drivers = Module::Build->prompt("Enter (space seperated) DBI drivers to test:", join(" ", @drivers)); + @drivers = split /\s/,$drivers; + $test_db = 'test'; + + my %driver; + for my $driver ( @drivers ) { + $test_db = Module::Build->prompt("\nConfiguring for driver 'DBI:$driver'\nEnter the name of your test database:", $test_db); + print "\n"; + for my $db ( $catalog_db, $test_db ) { + print "Configuring database '$db'\n"; + my $dsn; + if ($driver eq "mysql") { + $dsn = "database=$db"; + } elsif ($driver eq "mSQL") { + $dsn = "database=$db"; + } elsif ($driver eq "Pg") { + $dsn = "dbname=$db"; + } else { + die "unknown DBI driver: $db"; + } + $_ = Module::Build->prompt(qq{Enter the portion of the DSN that DBD::$driver will use to connect() +to $db i.e. 'DBI:$driver:[dsn_string]':}, $db); + $driver{$driver}->{$db}->{dsn} = "DBI:$driver:$_"; + ($driver{$driver}->{$db}->{u},$driver{$driver}->{$db}->{p}) + = DbFramework::Util::get_auth(); + if ( $db eq $catalog_db ) { + if ( Module::Build->prompt("Create schema for '$catalog_db' in DBI:$driver?", "N") !~ /^n/i ) { + # create catalog schema + my %sql = %{catalog_schema()}; + # default to mysql DDL syntax + $ddl = (exists $sql{$driver}) ? $driver : 'mysql'; + $dsn = $driver{$driver}->{$db}->{dsn}; + $u = $driver{$driver}->{$db}->{u}; + $p = $driver{$driver}->{$db}->{p}; + my $dbh = DbFramework::Util::get_dbh($dsn,$u,$p); + $dbh->{PrintError} = 0; + for my $table ( qw/c_db c_key c_relationship c_table/ ) { + drop_create($catalog_db,$table,undef,$sql{$ddl}->{$table},$dbh); + } + my($t1,$t2) = ('foo','bar'); + + ## set db + my $sql = qq{ + INSERT INTO c_db + VALUES('$test_db')}; + my $sth = do_sql($dbh,$sql); $sth->finish; + + ## set tables + $sql = qq{ + INSERT INTO c_table + VALUES('$t1','$test_db','bar')}; + $sth = do_sql($dbh,$sql); $sth->finish; + $sql = qq{ + INSERT INTO c_table + VALUES('$t2','$test_db',NULL)}; + $sth = do_sql($dbh,$sql); $sth->finish; + + ## set primary keys + $sql = qq{ + INSERT INTO c_key + VALUES('$test_db','$t1','primary',$keytypes{primary},'foo:bar')}; + $sth = do_sql($dbh,$sql); $sth->finish; + $sql = qq{ + INSERT INTO c_key + VALUES('$test_db','$t2','primary',$keytypes{primary},'foo')}; + $sth = do_sql($dbh,$sql); $sth->finish; + + ## set keys (indexes) + $sql = qq{ + INSERT INTO c_key + VALUES('$test_db','$t1','foo',$keytypes{index},'bar:baz')}; + $sth = do_sql($dbh,$sql); $sth->finish; + $sql = qq{ + INSERT INTO c_key + VALUES('$test_db','$t1','bar',$keytypes{index},'baz:quux')}; + $sth = do_sql($dbh,$sql); $sth->finish; + + ## set foreign keys + $sql = qq{ + INSERT INTO c_key + VALUES('$test_db','$t2','f_foo',$keytypes{foreign},'foo_foo:foo_bar')}; + $sth = do_sql($dbh,$sql); $sth->finish; + $sql = qq{ + INSERT INTO c_relationship + VALUES('$test_db','$t2','f_foo','$t1') + }; + $sth = do_sql($dbh,$sql); $sth->finish; + print "Done.\n"; + $dbh->disconnect; + } + } + } + } + + open(CONFIG,">$config") || die "Couldn't open config file: $config: $!"; + print "Writing config file: $config\n"; + print CONFIG qq{package t::Config; + +\$test_db = '$test_db'; +\@drivers = qw/@drivers/; +\%driver = (}; + + while ( my($k,$v) = each %driver ) { + print CONFIG "$k => { \n"; + while ( my($k,$v) = each %$v ) { + print CONFIG "$k => { \n"; + while ( my($k,$v) = each %$v ) { + print CONFIG "$k => '$v',"; + } + print CONFIG "},\n"; + } + print CONFIG "},\n"; + } + + print CONFIG qq{); + +1; + +}; + + close CONFIG; + print < { c_db => q{ +CREATE TABLE c_db ( + db_name varchar(50) DEFAULT '' NOT NULL, + PRIMARY KEY (db_name) + ) +}, + c_key => q{ +CREATE TABLE c_key ( + db_name varchar(50) DEFAULT '' NOT NULL, + table_name varchar(50) DEFAULT '' NOT NULL, + key_name varchar(50) DEFAULT '' NOT NULL, + key_type int DEFAULT '0' NOT NULL, + key_columns varchar(255) DEFAULT '' NOT NULL, + PRIMARY KEY (db_name,table_name,key_name) + ) +}, + c_relationship => q{ +CREATE TABLE c_relationship ( + db_name varchar(50) DEFAULT '' NOT NULL, + fk_table varchar(50) DEFAULT '' NOT NULL, + fk_key varchar(50) DEFAULT '' NOT NULL, + pk_table varchar(50) DEFAULT '' NOT NULL, + PRIMARY KEY (db_name,fk_table,fk_key,pk_table) + ) +}, + c_table => q{ +CREATE TABLE c_table ( + table_name varchar(50) DEFAULT '' NOT NULL, + db_name varchar(50) DEFAULT '' NOT NULL, + labels varchar(127) DEFAULT '', + PRIMARY KEY (table_name,db_name) + ) +} }, + CSV => { c_db => q{ +CREATE TABLE c_db ( + db_name varchar(50) + ) +}, + c_key => q{ +CREATE TABLE c_key ( + db_name varchar(50), + table_name varchar(50), + key_name varchar(50), + key_type int, + key_columns varchar(255) + ) +}, + c_relationship => q{ +CREATE TABLE c_relationship ( + db_name varchar(50), + fk_table varchar(50), + fk_key varchar(50), + pk_table varchar(50) + ) +}, + c_table => q{ +CREATE TABLE c_table ( + table_name varchar(50), + db_name varchar(50), + labels varchar(127) + ) +} }, + mysql => { c_db => q{ +CREATE TABLE c_db ( + db_name varchar(50) DEFAULT '' NOT NULL, + PRIMARY KEY (db_name) + ) +}, + c_key => q{ +CREATE TABLE c_key ( + db_name varchar(50) DEFAULT '' NOT NULL, + table_name varchar(50) DEFAULT '' NOT NULL, + key_name varchar(50) DEFAULT '' NOT NULL, + key_type int DEFAULT '0' NOT NULL, + key_columns varchar(255) DEFAULT '' NOT NULL, + PRIMARY KEY (db_name,table_name,key_name) + ) +}, + c_relationship => q{ +CREATE TABLE c_relationship ( + db_name varchar(50) DEFAULT '' NOT NULL, + fk_table varchar(50) DEFAULT '' NOT NULL, + fk_key varchar(50) DEFAULT '' NOT NULL, + pk_table varchar(50) DEFAULT '' NOT NULL, + PRIMARY KEY (db_name,fk_table,fk_key,pk_table) + ) +}, + c_table => q{ +CREATE TABLE c_table ( + table_name varchar(50) DEFAULT '' NOT NULL, + db_name varchar(50) DEFAULT '' NOT NULL, + labels varchar(127) DEFAULT '' NULL, + PRIMARY KEY (table_name,db_name) + ) +} }, + mSQL => { c_db => q{ +CREATE TABLE c_db ( + db_name char(50) NOT NULL + ) +}, + c_key => q{ +CREATE TABLE c_key ( + db_name char(50) NOT NULL, + table_name char(50) NOT NULL, + key_name char(50) NOT NULL, + key_type int NOT NULL, + key_columns char(255) NOT NULL +) +}, + c_relationship => q{ +CREATE TABLE c_relationship ( + db_name char(50) NOT NULL, + fk_table char(50) NOT NULL, + fk_key char(50) NOT NULL, + pk_table char(50) NOT NULL + ) +}, + c_table => q{ +CREATE TABLE c_table ( + table_name char(50) NOT NULL, + db_name char(50) NOT NULL, + labels char(127) + ) +} } + } +} + +my $build = Module::Build->new( + dist_name => "DbFramework", + dist_version => "1.12", + dist_abstract => "Classes for Manipulating DBI Databases, Based on the CDIF Data Model Subject Area", + dist_author => "imacat ", + license => "perl", + sign => 1, + + requires => { + "Alias" => 0, + "DBI" => 1.06, + "CGI" => 0, + "Text::FillIn" => 0, + "URI::Escape" => 0, + "Term::ReadKey" => 0, + }, + build_requires => { + "Module::Signature" => 0, + }, + add_to_cleanup => [ "t/Config.pm", "TAGS" ], +); + +$build->create_build_script; + +__END__ diff --git a/COPYING b/COPYING new file mode 100644 index 0000000..94a9ed0 --- /dev/null +++ b/COPYING @@ -0,0 +1,674 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + Copyright (C) + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +. diff --git a/Changes b/Changes new file mode 100644 index 0000000..6b7858f --- /dev/null +++ b/Changes @@ -0,0 +1,345 @@ +DbFramework change log + +2008-05-03 + 1. Makefile.PL and Build.PL: Automatic checks and lists only + the available DBD drivers for tests. + +2008-05-03 version 1.12 + 1. Makefile.PL and Build.PL: Provide a valid default DSN for + DBD::mysql, DBD::mSQL and DBD::Pg. + 2. Makefile.PL and Build.PL: Do not create the schema if + answer is "no". + +2008-04-21 + 1. Changes: Updated. + 2. Build.PL: Renamed test database from "dbframework_test" to + "test", to adapt the convention of MySQL and PostgreSQL. + 3. TODO: Added. + 4. AUTHORS: Added. + 5. Artistic and COPYING: Added. + 6. Makefile.PL: Added PL_FILES to disable PL files searching + behavior, in order to work with ExtUtils::MakeMaker earlier + than 6.25 that treats Build.PL as one of the PL files to run. + +2008-04-20 + 1. Added lib and lib/DbFramework subdirectory. Move everything + inside, to make the directory cleaner. + 2. Makefile.PL: Clean up. Removed PMLIBDIRS since it is not + required anymore. Removed linkext. linkext is only needed + for ExtUtils::MakeMaker before version 5. That is too old + today. + 3. Makefile.PL and Build.PL: Use "use lib qw(lib); + use DbFramework::Util;" instead of "require "./Util.pm"", in + order to be more portable on different platforms. + 4. Makefile.PL: Renamed test database from "dbframework_test" to + "test", to adapt the convention of MySQL and PostgreSQL. + 5. README: Moved Paul's BackPen URL to the previous line. + +2008-04-19 + 1. Added lib and lib/DbFramework subdirectory. Move everything + inside, to make the directory cleaner. + 2. Changes: Added, with contents from original Paul's README file. + This is to adapt the Perl module convention. + +2008-04-19 version 1.11 + Maintainance taken over by imacat. + 1. Makefile.PL: Updated to use prompt() from ExtUtils::MakeMaker + instead of reading STDIN directly, in order to prevent infinite + loop with automated CPAN testers. (RT#34538) + 2. t/util.pl: Subroutine yn() removed. It is not used anymore, + due to the prompt() fix. + 3. README: Add notice about the distribution ownership change. + 4. Makefile.PL: ABSTRACT, AUTHOR, LICENSE and SIGN added to the + WriteMakefile() arguments. VERSION is added in replace of + VERSION_FROM. + 5. SIGNATURE: Digital signature added. + 6. META.yml: YAML distribution meta-nformation added. + 7. Build.PL: Module::Build build support added. + +Original change log by Paul Sharpe follows. +================================== +History +======= + +15-05-1999 Paul Sharpe +-------------------------------------------------------------------- +RELEASE 1.10 + +Added support for PostgreSQL. + +INTERFACE CHANGES + PrimaryKey:: + - New method as_hidden_html() + +30-04-1999 Paul Sharpe +-------------------------------------------------------------------- +RELEASE 1.09 + +dbforms.cgi + - Can now update primary keys. + - Removed dependency on ePerl. + - Now takes dsn arguments to cater for variance between DBDs. + +INTERFACE CHANGES + Catalog:: + - set_primary_key() now sets labels if defined in the catalog. + DataModel:: + - New method dsn(). + - new() now requires name to be the database name as pattern match + to get database name forgot that this part of a DBI DSN is *non + standard* + - init_db_metadata() now requires DSN for catalog as it varies + between drivers. Also now allows username/password for authentication + against catalog database. + ForeignKey:: + - New method sql_where(). + Makefile.PL + - Moved most of the catalog initialisation here. + - Manual creation of databases now required as there's no standard + for creating databases. Each driver can use an arbitrarily named + database for testing. + Persistent:: + - new() now requires a Catalog object. + - update now takes %attributes argument so that a primary key can be + updated. The current object state is used to update the row WHERE the + primary key matches the values in %attributes. + PrimaryKey:: + - html_select_field() now has 'Any' *and* 'NULL' entries. I have a + feeling this still isn't quite right. + - New method as_hidden_html() + - Signature to new() has changed now that label columns are + supported by the catalog. + - html_select_field() now follows label columns which are foreign + keys back to their associated primary key table and uses the label + columns from that table. This gives more meaningful select fields. + Table:: + - init_db_metadata() now requires catalog object argument. This + should improve performance as a new catalog object (which involves a + database connect()) won't be created every time this method is called. + - in_foreign_key() now returns a list of foreign keys containing + $attribute + DataType::ANSII:: + - Signature to new() has changed. Now requires $ansii_type + argument. All data type objects will need to return their closest + ANSII types as this is the $type which needs to be supplied to + $dbh->quote($value,$type). + - New method ansii_type(). + +1-04-1999 Paul Sharpe +-------------------------------------------------------------------- +RELEASE 1.08 + +BUG FIX + - Test database wasn't being created which was causing tests to + fail. + +28-03-1999 Paul Sharpe +-------------------------------------------------------------------- +RELEASE 1.07 + +Highlights +========== + + Support for Msql (and potentially all DBI drivers.) + + Improved template support. + += API + Attribute:: + -- BUG FIXES + - as_html_form_field() was producing invalid HTML for date fields. + - as_html_heading() now takes $bgcolor argument. + Catalog.pm (NEW CLASS) + DataModel:: + - new() now takes data source name to move away from dependence on Mysql. + - init_db_metadata() now needs to be called explicity (not called in + new()). + - New methods driver() and db(). + DataType::ANSII:: (NEW CLASS) + DataType/Mysql:: (NEW CLASS) + ForeignKey:: + -- BUG FIX + - as_html_form_field() was using pk attribute names to select + defaults in select field. Should use fk attribute names. + Table:: + - read_form now takes ($name,$path) arguments. + - get_dbh() now takes data source name to move away from dependence on + Mysql. + Persistent:: + - New method init_pk() + - New method table_qualified_attribute_hashref() + - Removed method fill_template(). Templates now handled by Template.pm. + - select() now takes extra argument $order. + PrimaryKey:: + - New method as_query_string() + - html_select_field() sets null value labels to the string 'NULL'. + Table:: + -- BUG FIXES + - insert() should only try to insert values which are defined. + - Don't try to update columns where the value is undefined. + - as_html_heading() required more specific pattern match. + - Quoting in insert() and update() required type to correctly quote + numeric fields. + - new() was using wrong argument in belongs_to() + + - new() now takes optional DataModel argument + - New method belongs_to() + - get_attribute_names renamed attribute_names() + - New method select_loh() + - @columns in select() and select_loh() can contain references to + database functions to be applied to the column. + - removed methods set_templates(), read_form() and fill_templates() + as template handling is now done in Template.pm + - as_html_heading() now adds one heading for each key attribute. + - insert() returns -1 for non auto increment columns. + Template:: (NEW CLASS) + Util:: + - Removed get_db() as it was Mysql specific. The database name can + be retrieved from DbFramework::DataModel::db + - New sub do_sql() + - get_dbh() now takes data source name to move away from + dependence on Mysql. + += Makefile.PL configures drivers to test at 'make test' stage. + += dbforms.cgi + - Now accepts DBI driver CGI parameter (default is Mysql.) + += Overhaul of test scripts. + + +12-1-1999 Paul Sharpe +------------------------------------------------------------------------------- +RELEASE 1.06 + += UI + Default input templates now produce 'datasheet' view. + += API + Attribute:: + - New method as_html_heading() + Key:: + - New method as_html_heading() + PrimaryKey:: + - New method as_html_heading() + Table:: + - New method as_html_heading() + + +6-1-1999 Paul Sharpe +------------------------------------------------------------------------------- +RELEASE 1.05 + += INTERFACE + Table + - New method dbh($dbh) (added pod for AUTOLOAD() method) + = Improved form and template support + - new() now takes list of forms rather than template definitions and + evals configuration from config.pl files. + - New method read_form() + - More pod + - Default output templates now handle foreign keys by replacing them + with columns from the related table. + - template tag can now contain a list of attributes to be + substituted for values. + dbforms.cgi + - fills values from related table for foreign keys in default + output template. + - Now handles user-defined forms. + +18-Dec-1998 Paul Sharpe +------------------------------------------------------------------------------- +RELEASE 1.04 + += INTERFACE + ForeignKey + - New method as_html_form_field(\%values) + Table + - as_html_form() now returns fields for foreign keys too. + - fill_template() now creates selection boxes for tags. + += dbforms.cgi + New experimental UI separating search and modify. + Catches and displays SQL errors. + +11-Dec-1998 Paul Sharpe +------------------------------------------------------------------------------- +RELEASE 1.03 +- Bug fixes. + +11-Dec-1998 Paul Sharpe +------------------------------------------------------------------------------- +RELEASE 1.02 +- dbforms.cgi HTML forms application +- Bug fixes: Table::select(), Attribute::as_html_form_field() +- INTERFACE + *_h_byname() methods take an array rather than an arrayref + Persistent + - New method make_class() + - New method fill_template() + - New method as_html_form() + - fill_template() now takes $name argument + Table + - New method in_foreign_key() + - as_html_form() doesn't return
container so doesn't + require $action argument. + - New method in_key() + - New method in_primary_key() + - New method in_any_key() + - New method non_key_attributes() + - Removed method html_pk_select_field() + - New attribute/methods HAS_FOREIGN_KEYS_H + - fill_template() now supports placeholders. + Key + - New method belongs_to() + - new() now takes a reference to a hash of templates. + - fill_template() now takes a template name and reference to a hash of + values. + - templates() removed + - New method set_templates() + - New method bgcolor() + Attribute + - New method _input_template() + - New method _output_template() + - New method bgcolor() + PrimaryKey + - New method html_select_field() + +26-Nov-1998 Paul Sharpe +------------------------------------------------------------------------------- +RELEASE 1.01 (FIRST PUBLIC RELEASE) + + +To do +===== + +* BUG: dbforms.cgi delete on row consisting of all foreign keys silently fails. + +* Improve dbforms.cgi interface. Perhaps a rename is in order too. +I'm thinking of having a single record interface with record +navigation. The form can then be designed and specified as an +argument. + +* Fri Jan 8, 1999 + BUG - >1 fk relating to the same pk table in a single table is not + handled by dbforms.cgi + +4/1/1999 + - User-defined templates specify attributes to be used for foreign keys + and ordering + - Allow relationships between the same table (in different roles). + Needs documenting + +* Make Bundle::DbFramework + +* Schema grammar + - might be better off using Jeeves (from the Panther book) + - should handle relationships of degree >2 + - could be CDIF compliant + +* Attributes of relationships should be stored so that full schema + including attributes of relationships can be built from meta-data. + +* add support for UNIQUE columns (different to ordinary KEYs) + +* make primary key in grammar optional (1:1 relationships) + +* make relationships optional in grammar diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..f2931a8 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,36 @@ +Artistic +AUTHORS +Build.PL +Changes +COPYING +forms/dbforms.cgi +lib/DbFramework/Attribute.pm +lib/DbFramework/Catalog.pm +lib/DbFramework/DataModel.pm +lib/DbFramework/DataModelObject.pm +lib/DbFramework/DataType/ANSII.pm +lib/DbFramework/DataType/Mysql.pm +lib/DbFramework/DefinitionObject.pm +lib/DbFramework/ForeignKey.pm +lib/DbFramework/Key.pm +lib/DbFramework/Persistent.pm +lib/DbFramework/PrimaryKey.pm +lib/DbFramework/Relationship.pm +lib/DbFramework/Table.pm +lib/DbFramework/Template.pm +lib/DbFramework/Util.pm +Makefile.PL +MANIFEST This list of files +META.yml +README +SIGNATURE +t/10base.t +t/15catalog.t +t/17datatype.t +t/20table.t +t/30persistent.t +t/40template.t +t/template +t/test/foo/foo.form +t/util.pl +TODO diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..09ce68a --- /dev/null +++ b/META.yml @@ -0,0 +1,19 @@ +--- #YAML:1.0 +name: DbFramework +version: 1.12 +abstract: Classes for Manipulating DBI Databases, Based on the CDIF Data Model Subject Area +license: perl +author: + - imacat +generated_by: ExtUtils::MakeMaker version 6.44 +distribution_type: module +requires: + Alias: 0 + CGI: 0 + DBI: 1.06 + Term::ReadKey: 0 + Text::FillIn: 0 + URI::Escape: 0 +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.3.html + version: 1.3 diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..b1f51a6 --- /dev/null +++ b/Makefile @@ -0,0 +1,912 @@ +# This Makefile is for the DbFramework extension to perl. +# +# It was generated automatically by MakeMaker version +# 6.44 (Revision: 54639) from the contents of +# Makefile.PL. Don't edit this file, edit Makefile.PL instead. +# +# ANY CHANGES MADE HERE WILL BE LOST! +# +# MakeMaker ARGV: () +# +# MakeMaker Parameters: + +# ABSTRACT => q[Classes for Manipulating DBI Databases, Based on the CDIF Data Model Subject Area] +# AUTHOR => q[imacat ] +# LICENSE => q[perl] +# NAME => q[DbFramework] +# PL_FILES => { } +# PREREQ_PM => { Alias=>q[0], URI::Escape=>q[0], Text::FillIn=>q[0], Term::ReadKey=>q[0], CGI=>q[0], DBI=>q[1.06] } +# SIGN => q[1] +# VERSION => q[1.12] +# clean => { FILES=>q[t/Config.pm TAGS] } +# dist => { COMPRESS=>q[gzip -9], SUFFIX=>q[.gz] } + +# --- MakeMaker post_initialize section: + + +# --- MakeMaker const_config section: + +# These definitions are from config.sh (via /usr/lib/perl5/5.8.8/x86_64-linux-thread-multi-ld/Config.pm). +# They may have been overridden via Makefile.PL or on the command line. +AR = ar +CC = gcc +CCCDLFLAGS = -fPIC +CCDLFLAGS = -Wl,-E -Wl,-rpath,/usr/lib/perl5/5.8.8/x86_64-linux-thread-multi-ld/CORE +DLEXT = so +DLSRC = dl_dlopen.xs +EXE_EXT = +FULL_AR = /usr/bin/ar +LD = gcc +LDDLFLAGS = -shared -L/usr/local/lib +LDFLAGS = -L/usr/local/lib +LIBC = /lib/libc-2.3.6.so +LIB_EXT = .a +OBJ_EXT = .o +OSNAME = linux +OSVERS = 2.6.22.10 +RANLIB = : +SITELIBEXP = /usr/lib/perl5/site_perl/5.8.8 +SITEARCHEXP = /usr/lib/perl5/site_perl/5.8.8/x86_64-linux-thread-multi-ld +SO = so +VENDORARCHEXP = +VENDORLIBEXP = + + +# --- MakeMaker constants section: +AR_STATIC_ARGS = cr +DIRFILESEP = / +DFSEP = $(DIRFILESEP) +NAME = DbFramework +NAME_SYM = DbFramework +VERSION = 1.12 +VERSION_MACRO = VERSION +VERSION_SYM = 1_12 +DEFINE_VERSION = -D$(VERSION_MACRO)=\"$(VERSION)\" +XS_VERSION = 1.12 +XS_VERSION_MACRO = XS_VERSION +XS_DEFINE_VERSION = -D$(XS_VERSION_MACRO)=\"$(XS_VERSION)\" +INST_ARCHLIB = blib/arch +INST_SCRIPT = blib/script +INST_BIN = blib/bin +INST_LIB = blib/lib +INST_MAN1DIR = blib/man1 +INST_MAN3DIR = blib/man3 +MAN1EXT = 1 +MAN3EXT = 3 +INSTALLDIRS = site +DESTDIR = +PREFIX = $(SITEPREFIX) +PERLPREFIX = /usr +SITEPREFIX = /usr +VENDORPREFIX = +INSTALLPRIVLIB = /usr/lib/perl5/5.8.8 +DESTINSTALLPRIVLIB = $(DESTDIR)$(INSTALLPRIVLIB) +INSTALLSITELIB = /usr/lib/perl5/site_perl/5.8.8 +DESTINSTALLSITELIB = $(DESTDIR)$(INSTALLSITELIB) +INSTALLVENDORLIB = +DESTINSTALLVENDORLIB = $(DESTDIR)$(INSTALLVENDORLIB) +INSTALLARCHLIB = /usr/lib/perl5/5.8.8/x86_64-linux-thread-multi-ld +DESTINSTALLARCHLIB = $(DESTDIR)$(INSTALLARCHLIB) +INSTALLSITEARCH = /usr/lib/perl5/site_perl/5.8.8/x86_64-linux-thread-multi-ld +DESTINSTALLSITEARCH = $(DESTDIR)$(INSTALLSITEARCH) +INSTALLVENDORARCH = +DESTINSTALLVENDORARCH = $(DESTDIR)$(INSTALLVENDORARCH) +INSTALLBIN = /usr/bin +DESTINSTALLBIN = $(DESTDIR)$(INSTALLBIN) +INSTALLSITEBIN = /usr/bin +DESTINSTALLSITEBIN = $(DESTDIR)$(INSTALLSITEBIN) +INSTALLVENDORBIN = +DESTINSTALLVENDORBIN = $(DESTDIR)$(INSTALLVENDORBIN) +INSTALLSCRIPT = /usr/bin +DESTINSTALLSCRIPT = $(DESTDIR)$(INSTALLSCRIPT) +INSTALLSITESCRIPT = /usr/bin +DESTINSTALLSITESCRIPT = $(DESTDIR)$(INSTALLSITESCRIPT) +INSTALLVENDORSCRIPT = +DESTINSTALLVENDORSCRIPT = $(DESTDIR)$(INSTALLVENDORSCRIPT) +INSTALLMAN1DIR = /usr/share/man/man1 +DESTINSTALLMAN1DIR = $(DESTDIR)$(INSTALLMAN1DIR) +INSTALLSITEMAN1DIR = /usr/share/man/man1 +DESTINSTALLSITEMAN1DIR = $(DESTDIR)$(INSTALLSITEMAN1DIR) +INSTALLVENDORMAN1DIR = +DESTINSTALLVENDORMAN1DIR = $(DESTDIR)$(INSTALLVENDORMAN1DIR) +INSTALLMAN3DIR = /usr/share/man/man3 +DESTINSTALLMAN3DIR = $(DESTDIR)$(INSTALLMAN3DIR) +INSTALLSITEMAN3DIR = /usr/share/man/man3 +DESTINSTALLSITEMAN3DIR = $(DESTDIR)$(INSTALLSITEMAN3DIR) +INSTALLVENDORMAN3DIR = +DESTINSTALLVENDORMAN3DIR = $(DESTDIR)$(INSTALLVENDORMAN3DIR) +PERL_LIB = /usr/lib/perl5/5.8.8 +PERL_ARCHLIB = /usr/lib/perl5/5.8.8/x86_64-linux-thread-multi-ld +LIBPERL_A = libperl.a +FIRST_MAKEFILE = Makefile +MAKEFILE_OLD = Makefile.old +MAKE_APERL_FILE = Makefile.aperl +PERLMAINCC = $(CC) +PERL_INC = /usr/lib/perl5/5.8.8/x86_64-linux-thread-multi-ld/CORE +PERL = /usr/bin/perl +FULLPERL = /usr/bin/perl +ABSPERL = $(PERL) +PERLRUN = $(PERL) +FULLPERLRUN = $(FULLPERL) +ABSPERLRUN = $(ABSPERL) +PERLRUNINST = $(PERLRUN) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" +FULLPERLRUNINST = $(FULLPERLRUN) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" +ABSPERLRUNINST = $(ABSPERLRUN) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" +PERL_CORE = 0 +PERM_RW = 644 +PERM_RWX = 755 + +MAKEMAKER = /usr/lib/perl5/5.8.8/ExtUtils/MakeMaker.pm +MM_VERSION = 6.44 +MM_REVISION = 54639 + +# FULLEXT = Pathname for extension directory (eg Foo/Bar/Oracle). +# BASEEXT = Basename part of FULLEXT. May be just equal FULLEXT. (eg Oracle) +# PARENT_NAME = NAME without BASEEXT and no trailing :: (eg Foo::Bar) +# DLBASE = Basename part of dynamic library. May be just equal BASEEXT. +MAKE = make +FULLEXT = DbFramework +BASEEXT = DbFramework +PARENT_NAME = +DLBASE = $(BASEEXT) +VERSION_FROM = +OBJECT = +LDFROM = $(OBJECT) +LINKTYPE = dynamic +BOOTDEP = + +# Handy lists of source code files: +XS_FILES = +C_FILES = +O_FILES = +H_FILES = +MAN1PODS = +MAN3PODS = lib/DbFramework/Attribute.pm \ + lib/DbFramework/Catalog.pm \ + lib/DbFramework/DataModel.pm \ + lib/DbFramework/DataModelObject.pm \ + lib/DbFramework/DataType/ANSII.pm \ + lib/DbFramework/DataType/Mysql.pm \ + lib/DbFramework/DefinitionObject.pm \ + lib/DbFramework/ForeignKey.pm \ + lib/DbFramework/Key.pm \ + lib/DbFramework/Persistent.pm \ + lib/DbFramework/PrimaryKey.pm \ + lib/DbFramework/Table.pm \ + lib/DbFramework/Template.pm \ + lib/DbFramework/Util.pm + +# Where is the Config information that we are using/depend on +CONFIGDEP = $(PERL_ARCHLIB)$(DFSEP)Config.pm $(PERL_INC)$(DFSEP)config.h + +# Where to build things +INST_LIBDIR = $(INST_LIB) +INST_ARCHLIBDIR = $(INST_ARCHLIB) + +INST_AUTODIR = $(INST_LIB)/auto/$(FULLEXT) +INST_ARCHAUTODIR = $(INST_ARCHLIB)/auto/$(FULLEXT) + +INST_STATIC = +INST_DYNAMIC = +INST_BOOT = + +# Extra linker info +EXPORT_LIST = +PERL_ARCHIVE = +PERL_ARCHIVE_AFTER = + + +TO_INST_PM = lib/DbFramework/Attribute.pm \ + lib/DbFramework/Catalog.pm \ + lib/DbFramework/DataModel.pm \ + lib/DbFramework/DataModelObject.pm \ + lib/DbFramework/DataType/ANSII.pm \ + lib/DbFramework/DataType/Mysql.pm \ + lib/DbFramework/DefinitionObject.pm \ + lib/DbFramework/ForeignKey.pm \ + lib/DbFramework/Key.pm \ + lib/DbFramework/Persistent.pm \ + lib/DbFramework/PrimaryKey.pm \ + lib/DbFramework/Relationship.pm \ + lib/DbFramework/Table.pm \ + lib/DbFramework/Template.pm \ + lib/DbFramework/Util.pm + +PM_TO_BLIB = lib/DbFramework/PrimaryKey.pm \ + blib/lib/DbFramework/PrimaryKey.pm \ + lib/DbFramework/DataModelObject.pm \ + blib/lib/DbFramework/DataModelObject.pm \ + lib/DbFramework/ForeignKey.pm \ + blib/lib/DbFramework/ForeignKey.pm \ + lib/DbFramework/DataType/ANSII.pm \ + blib/lib/DbFramework/DataType/ANSII.pm \ + lib/DbFramework/Util.pm \ + blib/lib/DbFramework/Util.pm \ + lib/DbFramework/DataModel.pm \ + blib/lib/DbFramework/DataModel.pm \ + lib/DbFramework/Persistent.pm \ + blib/lib/DbFramework/Persistent.pm \ + lib/DbFramework/Template.pm \ + blib/lib/DbFramework/Template.pm \ + lib/DbFramework/Key.pm \ + blib/lib/DbFramework/Key.pm \ + lib/DbFramework/DataType/Mysql.pm \ + blib/lib/DbFramework/DataType/Mysql.pm \ + lib/DbFramework/Relationship.pm \ + blib/lib/DbFramework/Relationship.pm \ + lib/DbFramework/Catalog.pm \ + blib/lib/DbFramework/Catalog.pm \ + lib/DbFramework/Table.pm \ + blib/lib/DbFramework/Table.pm \ + lib/DbFramework/Attribute.pm \ + blib/lib/DbFramework/Attribute.pm \ + lib/DbFramework/DefinitionObject.pm \ + blib/lib/DbFramework/DefinitionObject.pm + + +# --- MakeMaker platform_constants section: +MM_Unix_VERSION = 6.44 +PERL_MALLOC_DEF = -DPERL_EXTMALLOC_DEF -Dmalloc=Perl_malloc -Dfree=Perl_mfree -Drealloc=Perl_realloc -Dcalloc=Perl_calloc + + +# --- MakeMaker tool_autosplit section: +# Usage: $(AUTOSPLITFILE) FileToSplit AutoDirToSplitInto +AUTOSPLITFILE = $(ABSPERLRUN) -e 'use AutoSplit; autosplit($$ARGV[0], $$ARGV[1], 0, 1, 1)' -- + + + +# --- MakeMaker tool_xsubpp section: + + +# --- MakeMaker tools_other section: +SHELL = /bin/sh +CHMOD = chmod +CP = cp +MV = mv +NOOP = $(SHELL) -c true +NOECHO = @ +RM_F = rm -f +RM_RF = rm -rf +TEST_F = test -f +TOUCH = touch +UMASK_NULL = umask 0 +DEV_NULL = > /dev/null 2>&1 +MKPATH = $(ABSPERLRUN) "-MExtUtils::Command" -e mkpath +EQUALIZE_TIMESTAMP = $(ABSPERLRUN) "-MExtUtils::Command" -e eqtime +ECHO = echo +ECHO_N = echo -n +UNINST = 0 +VERBINST = 0 +MOD_INSTALL = $(ABSPERLRUN) -MExtUtils::Install -e 'install({@ARGV}, '\''$(VERBINST)'\'', 0, '\''$(UNINST)'\'');' -- +DOC_INSTALL = $(ABSPERLRUN) "-MExtUtils::Command::MM" -e perllocal_install +UNINSTALL = $(ABSPERLRUN) "-MExtUtils::Command::MM" -e uninstall +WARN_IF_OLD_PACKLIST = $(ABSPERLRUN) "-MExtUtils::Command::MM" -e warn_if_old_packlist +MACROSTART = +MACROEND = +USEMAKEFILE = -f +FIXIN = $(PERLRUN) "-MExtUtils::MY" -e "MY->fixin(shift)" + + +# --- MakeMaker makemakerdflt section: +makemakerdflt : all + $(NOECHO) $(NOOP) + + +# --- MakeMaker dist section: +TAR = tar +TARFLAGS = cvf +ZIP = zip +ZIPFLAGS = -r +COMPRESS = gzip -9 +SUFFIX = .gz +SHAR = shar +PREOP = $(NOECHO) $(NOOP) +POSTOP = $(NOECHO) $(NOOP) +TO_UNIX = $(NOECHO) $(NOOP) +CI = ci -u +RCS_LABEL = rcs -Nv$(VERSION_SYM): -q +DIST_CP = best +DIST_DEFAULT = tardist +DISTNAME = DbFramework +DISTVNAME = DbFramework-1.12 + + +# --- MakeMaker macro section: + + +# --- MakeMaker depend section: + + +# --- MakeMaker cflags section: + + +# --- MakeMaker const_loadlibs section: + + +# --- MakeMaker const_cccmd section: + + +# --- MakeMaker post_constants section: + + +# --- MakeMaker pasthru section: + +PASTHRU = LIBPERL_A="$(LIBPERL_A)"\ + LINKTYPE="$(LINKTYPE)"\ + PREFIX="$(PREFIX)" + + +# --- MakeMaker special_targets section: +.SUFFIXES : .xs .c .C .cpp .i .s .cxx .cc $(OBJ_EXT) + +.PHONY: all config static dynamic test linkext manifest blibdirs clean realclean disttest distdir + + + +# --- MakeMaker c_o section: + + +# --- MakeMaker xs_c section: + + +# --- MakeMaker xs_o section: + + +# --- MakeMaker top_targets section: +all :: pure_all manifypods + $(NOECHO) $(NOOP) + + +pure_all :: config pm_to_blib subdirs linkext + $(NOECHO) $(NOOP) + +subdirs :: $(MYEXTLIB) + $(NOECHO) $(NOOP) + +config :: $(FIRST_MAKEFILE) blibdirs + $(NOECHO) $(NOOP) + +help : + perldoc ExtUtils::MakeMaker + + +# --- MakeMaker blibdirs section: +blibdirs : $(INST_LIBDIR)$(DFSEP).exists $(INST_ARCHLIB)$(DFSEP).exists $(INST_AUTODIR)$(DFSEP).exists $(INST_ARCHAUTODIR)$(DFSEP).exists $(INST_BIN)$(DFSEP).exists $(INST_SCRIPT)$(DFSEP).exists $(INST_MAN1DIR)$(DFSEP).exists $(INST_MAN3DIR)$(DFSEP).exists + $(NOECHO) $(NOOP) + +# Backwards compat with 6.18 through 6.25 +blibdirs.ts : blibdirs + $(NOECHO) $(NOOP) + +$(INST_LIBDIR)$(DFSEP).exists :: Makefile.PL + $(NOECHO) $(MKPATH) $(INST_LIBDIR) + $(NOECHO) $(CHMOD) 755 $(INST_LIBDIR) + $(NOECHO) $(TOUCH) $(INST_LIBDIR)$(DFSEP).exists + +$(INST_ARCHLIB)$(DFSEP).exists :: Makefile.PL + $(NOECHO) $(MKPATH) $(INST_ARCHLIB) + $(NOECHO) $(CHMOD) 755 $(INST_ARCHLIB) + $(NOECHO) $(TOUCH) $(INST_ARCHLIB)$(DFSEP).exists + +$(INST_AUTODIR)$(DFSEP).exists :: Makefile.PL + $(NOECHO) $(MKPATH) $(INST_AUTODIR) + $(NOECHO) $(CHMOD) 755 $(INST_AUTODIR) + $(NOECHO) $(TOUCH) $(INST_AUTODIR)$(DFSEP).exists + +$(INST_ARCHAUTODIR)$(DFSEP).exists :: Makefile.PL + $(NOECHO) $(MKPATH) $(INST_ARCHAUTODIR) + $(NOECHO) $(CHMOD) 755 $(INST_ARCHAUTODIR) + $(NOECHO) $(TOUCH) $(INST_ARCHAUTODIR)$(DFSEP).exists + +$(INST_BIN)$(DFSEP).exists :: Makefile.PL + $(NOECHO) $(MKPATH) $(INST_BIN) + $(NOECHO) $(CHMOD) 755 $(INST_BIN) + $(NOECHO) $(TOUCH) $(INST_BIN)$(DFSEP).exists + +$(INST_SCRIPT)$(DFSEP).exists :: Makefile.PL + $(NOECHO) $(MKPATH) $(INST_SCRIPT) + $(NOECHO) $(CHMOD) 755 $(INST_SCRIPT) + $(NOECHO) $(TOUCH) $(INST_SCRIPT)$(DFSEP).exists + +$(INST_MAN1DIR)$(DFSEP).exists :: Makefile.PL + $(NOECHO) $(MKPATH) $(INST_MAN1DIR) + $(NOECHO) $(CHMOD) 755 $(INST_MAN1DIR) + $(NOECHO) $(TOUCH) $(INST_MAN1DIR)$(DFSEP).exists + +$(INST_MAN3DIR)$(DFSEP).exists :: Makefile.PL + $(NOECHO) $(MKPATH) $(INST_MAN3DIR) + $(NOECHO) $(CHMOD) 755 $(INST_MAN3DIR) + $(NOECHO) $(TOUCH) $(INST_MAN3DIR)$(DFSEP).exists + + + +# --- MakeMaker linkext section: + +linkext :: $(LINKTYPE) + $(NOECHO) $(NOOP) + + +# --- MakeMaker dlsyms section: + + +# --- MakeMaker dynamic section: + +dynamic :: $(FIRST_MAKEFILE) $(INST_DYNAMIC) $(INST_BOOT) + $(NOECHO) $(NOOP) + + +# --- MakeMaker dynamic_bs section: + +BOOTSTRAP = + + +# --- MakeMaker dynamic_lib section: + + +# --- MakeMaker static section: + +## $(INST_PM) has been moved to the all: target. +## It remains here for awhile to allow for old usage: "make static" +static :: $(FIRST_MAKEFILE) $(INST_STATIC) + $(NOECHO) $(NOOP) + + +# --- MakeMaker static_lib section: + + +# --- MakeMaker manifypods section: + +POD2MAN_EXE = $(PERLRUN) "-MExtUtils::Command::MM" -e pod2man "--" +POD2MAN = $(POD2MAN_EXE) + + +manifypods : pure_all \ + lib/DbFramework/PrimaryKey.pm \ + lib/DbFramework/DataModelObject.pm \ + lib/DbFramework/ForeignKey.pm \ + lib/DbFramework/DataType/ANSII.pm \ + lib/DbFramework/Util.pm \ + lib/DbFramework/DataModel.pm \ + lib/DbFramework/Persistent.pm \ + lib/DbFramework/Template.pm \ + lib/DbFramework/Key.pm \ + lib/DbFramework/DataType/Mysql.pm \ + lib/DbFramework/Catalog.pm \ + lib/DbFramework/Table.pm \ + lib/DbFramework/Attribute.pm \ + lib/DbFramework/DefinitionObject.pm + $(NOECHO) $(POD2MAN) --section=3 --perm_rw=$(PERM_RW) \ + lib/DbFramework/PrimaryKey.pm $(INST_MAN3DIR)/DbFramework::PrimaryKey.$(MAN3EXT) \ + lib/DbFramework/DataModelObject.pm $(INST_MAN3DIR)/DbFramework::DataModelObject.$(MAN3EXT) \ + lib/DbFramework/ForeignKey.pm $(INST_MAN3DIR)/DbFramework::ForeignKey.$(MAN3EXT) \ + lib/DbFramework/DataType/ANSII.pm $(INST_MAN3DIR)/DbFramework::DataType::ANSII.$(MAN3EXT) \ + lib/DbFramework/Util.pm $(INST_MAN3DIR)/DbFramework::Util.$(MAN3EXT) \ + lib/DbFramework/DataModel.pm $(INST_MAN3DIR)/DbFramework::DataModel.$(MAN3EXT) \ + lib/DbFramework/Persistent.pm $(INST_MAN3DIR)/DbFramework::Persistent.$(MAN3EXT) \ + lib/DbFramework/Template.pm $(INST_MAN3DIR)/DbFramework::Template.$(MAN3EXT) \ + lib/DbFramework/Key.pm $(INST_MAN3DIR)/DbFramework::Key.$(MAN3EXT) \ + lib/DbFramework/DataType/Mysql.pm $(INST_MAN3DIR)/DbFramework::DataType::Mysql.$(MAN3EXT) \ + lib/DbFramework/Catalog.pm $(INST_MAN3DIR)/DbFramework::Catalog.$(MAN3EXT) \ + lib/DbFramework/Table.pm $(INST_MAN3DIR)/DbFramework::Table.$(MAN3EXT) \ + lib/DbFramework/Attribute.pm $(INST_MAN3DIR)/DbFramework::Attribute.$(MAN3EXT) \ + lib/DbFramework/DefinitionObject.pm $(INST_MAN3DIR)/DbFramework::DefinitionObject.$(MAN3EXT) + + + + +# --- MakeMaker processPL section: + + +# --- MakeMaker installbin section: + + +# --- MakeMaker subdirs section: + +# none + +# --- MakeMaker clean_subdirs section: +clean_subdirs : + $(NOECHO) $(NOOP) + + +# --- MakeMaker clean section: + +# Delete temporary files but do not touch installed files. We don't delete +# the Makefile here so a later make realclean still has a makefile to use. + +clean :: clean_subdirs + - $(RM_F) \ + *$(LIB_EXT) core \ + core.[0-9] $(INST_ARCHAUTODIR)/extralibs.all \ + core.[0-9][0-9] $(BASEEXT).bso \ + pm_to_blib.ts core.[0-9][0-9][0-9][0-9] \ + $(BASEEXT).x $(BOOTSTRAP) \ + perl$(EXE_EXT) tmon.out \ + *$(OBJ_EXT) pm_to_blib \ + $(INST_ARCHAUTODIR)/extralibs.ld blibdirs.ts \ + core.[0-9][0-9][0-9][0-9][0-9] *perl.core \ + core.*perl.*.? $(MAKE_APERL_FILE) \ + perl $(BASEEXT).def \ + core.[0-9][0-9][0-9] mon.out \ + lib$(BASEEXT).def perlmain.c \ + perl.exe so_locations \ + $(BASEEXT).exp + - $(RM_RF) \ + t/Config.pm blib \ + TAGS + - $(MV) $(FIRST_MAKEFILE) $(MAKEFILE_OLD) $(DEV_NULL) + + +# --- MakeMaker realclean_subdirs section: +realclean_subdirs : + $(NOECHO) $(NOOP) + + +# --- MakeMaker realclean section: +# Delete temporary files (via clean) and also delete dist files +realclean purge :: clean realclean_subdirs + - $(RM_F) \ + $(MAKEFILE_OLD) $(FIRST_MAKEFILE) + - $(RM_RF) \ + $(DISTVNAME) + + +# --- MakeMaker metafile section: +metafile : create_distdir + $(NOECHO) $(ECHO) Generating META.yml + $(NOECHO) $(ECHO) '--- #YAML:1.0' > META_new.yml + $(NOECHO) $(ECHO) 'name: DbFramework' >> META_new.yml + $(NOECHO) $(ECHO) 'version: 1.12' >> META_new.yml + $(NOECHO) $(ECHO) 'abstract: Classes for Manipulating DBI Databases, Based on the CDIF Data Model Subject Area' >> META_new.yml + $(NOECHO) $(ECHO) 'license: perl' >> META_new.yml + $(NOECHO) $(ECHO) 'author: ' >> META_new.yml + $(NOECHO) $(ECHO) ' - imacat ' >> META_new.yml + $(NOECHO) $(ECHO) 'generated_by: ExtUtils::MakeMaker version 6.44' >> META_new.yml + $(NOECHO) $(ECHO) 'distribution_type: module' >> META_new.yml + $(NOECHO) $(ECHO) 'requires: ' >> META_new.yml + $(NOECHO) $(ECHO) ' Alias: 0' >> META_new.yml + $(NOECHO) $(ECHO) ' CGI: 0' >> META_new.yml + $(NOECHO) $(ECHO) ' DBI: 1.06' >> META_new.yml + $(NOECHO) $(ECHO) ' Term::ReadKey: 0' >> META_new.yml + $(NOECHO) $(ECHO) ' Text::FillIn: 0' >> META_new.yml + $(NOECHO) $(ECHO) ' URI::Escape: 0' >> META_new.yml + $(NOECHO) $(ECHO) 'meta-spec:' >> META_new.yml + $(NOECHO) $(ECHO) ' url: http://module-build.sourceforge.net/META-spec-v1.3.html' >> META_new.yml + $(NOECHO) $(ECHO) ' version: 1.3' >> META_new.yml + -$(NOECHO) $(MV) META_new.yml $(DISTVNAME)/META.yml + + +# --- MakeMaker signature section: +signature : + cpansign -s + + +# --- MakeMaker dist_basics section: +distclean :: realclean distcheck + $(NOECHO) $(NOOP) + +distcheck : + $(PERLRUN) "-MExtUtils::Manifest=fullcheck" -e fullcheck + +skipcheck : + $(PERLRUN) "-MExtUtils::Manifest=skipcheck" -e skipcheck + +manifest : + $(PERLRUN) "-MExtUtils::Manifest=mkmanifest" -e mkmanifest + +veryclean : realclean + $(RM_F) *~ */*~ *.orig */*.orig *.bak */*.bak *.old */*.old + + + +# --- MakeMaker dist_core section: + +dist : $(DIST_DEFAULT) $(FIRST_MAKEFILE) + $(NOECHO) $(ABSPERLRUN) -l -e 'print '\''Warning: Makefile possibly out of date with $(VERSION_FROM)'\''' \ + -e ' if -e '\''$(VERSION_FROM)'\'' and -M '\''$(VERSION_FROM)'\'' < -M '\''$(FIRST_MAKEFILE)'\'';' -- + +tardist : $(DISTVNAME).tar$(SUFFIX) + $(NOECHO) $(NOOP) + +uutardist : $(DISTVNAME).tar$(SUFFIX) + uuencode $(DISTVNAME).tar$(SUFFIX) $(DISTVNAME).tar$(SUFFIX) > $(DISTVNAME).tar$(SUFFIX)_uu + +$(DISTVNAME).tar$(SUFFIX) : distdir + $(PREOP) + $(TO_UNIX) + $(TAR) $(TARFLAGS) $(DISTVNAME).tar $(DISTVNAME) + $(RM_RF) $(DISTVNAME) + $(COMPRESS) $(DISTVNAME).tar + $(POSTOP) + +zipdist : $(DISTVNAME).zip + $(NOECHO) $(NOOP) + +$(DISTVNAME).zip : distdir + $(PREOP) + $(ZIP) $(ZIPFLAGS) $(DISTVNAME).zip $(DISTVNAME) + $(RM_RF) $(DISTVNAME) + $(POSTOP) + +shdist : distdir + $(PREOP) + $(SHAR) $(DISTVNAME) > $(DISTVNAME).shar + $(RM_RF) $(DISTVNAME) + $(POSTOP) + + +# --- MakeMaker distdir section: +create_distdir : + $(RM_RF) $(DISTVNAME) + $(PERLRUN) "-MExtUtils::Manifest=manicopy,maniread" \ + -e "manicopy(maniread(),'$(DISTVNAME)', '$(DIST_CP)');" + +distdir : create_distdir distmeta distsignature + $(NOECHO) $(NOOP) + + + +# --- MakeMaker dist_test section: +disttest : distdir + cd $(DISTVNAME) && $(ABSPERLRUN) Makefile.PL + cd $(DISTVNAME) && $(MAKE) $(PASTHRU) + cd $(DISTVNAME) && $(MAKE) test $(PASTHRU) + + + +# --- MakeMaker dist_ci section: + +ci : + $(PERLRUN) "-MExtUtils::Manifest=maniread" \ + -e "@all = keys %{ maniread() };" \ + -e "print(qq{Executing $(CI) @all\n}); system(qq{$(CI) @all});" \ + -e "print(qq{Executing $(RCS_LABEL) ...\n}); system(qq{$(RCS_LABEL) @all});" + + +# --- MakeMaker distmeta section: +distmeta : create_distdir metafile + $(NOECHO) cd $(DISTVNAME) && $(ABSPERLRUN) -MExtUtils::Manifest=maniadd -e 'eval { maniadd({q{META.yml} => q{Module meta-data (added by MakeMaker)}}) } ' \ + -e ' or print "Could not add META.yml to MANIFEST: $${'\''@'\''}\n"' -- + + + +# --- MakeMaker distsignature section: +distsignature : create_distdir + $(NOECHO) cd $(DISTVNAME) && $(ABSPERLRUN) -MExtUtils::Manifest=maniadd -e 'eval { maniadd({q{SIGNATURE} => q{Public-key signature (added by MakeMaker)}}) } ' \ + -e ' or print "Could not add SIGNATURE to MANIFEST: $${'\''@'\''}\n"' -- + $(NOECHO) cd $(DISTVNAME) && $(TOUCH) SIGNATURE + cd $(DISTVNAME) && cpansign -s + + + +# --- MakeMaker install section: + +install :: all pure_install doc_install + $(NOECHO) $(NOOP) + +install_perl :: all pure_perl_install doc_perl_install + $(NOECHO) $(NOOP) + +install_site :: all pure_site_install doc_site_install + $(NOECHO) $(NOOP) + +install_vendor :: all pure_vendor_install doc_vendor_install + $(NOECHO) $(NOOP) + +pure_install :: pure_$(INSTALLDIRS)_install + $(NOECHO) $(NOOP) + +doc_install :: doc_$(INSTALLDIRS)_install + $(NOECHO) $(NOOP) + +pure__install : pure_site_install + $(NOECHO) $(ECHO) INSTALLDIRS not defined, defaulting to INSTALLDIRS=site + +doc__install : doc_site_install + $(NOECHO) $(ECHO) INSTALLDIRS not defined, defaulting to INSTALLDIRS=site + +pure_perl_install :: + $(NOECHO) $(MOD_INSTALL) \ + read $(PERL_ARCHLIB)/auto/$(FULLEXT)/.packlist \ + write $(DESTINSTALLARCHLIB)/auto/$(FULLEXT)/.packlist \ + $(INST_LIB) $(DESTINSTALLPRIVLIB) \ + $(INST_ARCHLIB) $(DESTINSTALLARCHLIB) \ + $(INST_BIN) $(DESTINSTALLBIN) \ + $(INST_SCRIPT) $(DESTINSTALLSCRIPT) \ + $(INST_MAN1DIR) $(DESTINSTALLMAN1DIR) \ + $(INST_MAN3DIR) $(DESTINSTALLMAN3DIR) + $(NOECHO) $(WARN_IF_OLD_PACKLIST) \ + $(SITEARCHEXP)/auto/$(FULLEXT) + + +pure_site_install :: + $(NOECHO) $(MOD_INSTALL) \ + read $(SITEARCHEXP)/auto/$(FULLEXT)/.packlist \ + write $(DESTINSTALLSITEARCH)/auto/$(FULLEXT)/.packlist \ + $(INST_LIB) $(DESTINSTALLSITELIB) \ + $(INST_ARCHLIB) $(DESTINSTALLSITEARCH) \ + $(INST_BIN) $(DESTINSTALLSITEBIN) \ + $(INST_SCRIPT) $(DESTINSTALLSITESCRIPT) \ + $(INST_MAN1DIR) $(DESTINSTALLSITEMAN1DIR) \ + $(INST_MAN3DIR) $(DESTINSTALLSITEMAN3DIR) + $(NOECHO) $(WARN_IF_OLD_PACKLIST) \ + $(PERL_ARCHLIB)/auto/$(FULLEXT) + +pure_vendor_install :: + $(NOECHO) $(MOD_INSTALL) \ + read $(VENDORARCHEXP)/auto/$(FULLEXT)/.packlist \ + write $(DESTINSTALLVENDORARCH)/auto/$(FULLEXT)/.packlist \ + $(INST_LIB) $(DESTINSTALLVENDORLIB) \ + $(INST_ARCHLIB) $(DESTINSTALLVENDORARCH) \ + $(INST_BIN) $(DESTINSTALLVENDORBIN) \ + $(INST_SCRIPT) $(DESTINSTALLVENDORSCRIPT) \ + $(INST_MAN1DIR) $(DESTINSTALLVENDORMAN1DIR) \ + $(INST_MAN3DIR) $(DESTINSTALLVENDORMAN3DIR) + +doc_perl_install :: + $(NOECHO) $(ECHO) Appending installation info to $(DESTINSTALLARCHLIB)/perllocal.pod + -$(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB) + -$(NOECHO) $(DOC_INSTALL) \ + "Module" "$(NAME)" \ + "installed into" "$(INSTALLPRIVLIB)" \ + LINKTYPE "$(LINKTYPE)" \ + VERSION "$(VERSION)" \ + EXE_FILES "$(EXE_FILES)" \ + >> $(DESTINSTALLARCHLIB)/perllocal.pod + +doc_site_install :: + $(NOECHO) $(ECHO) Appending installation info to $(DESTINSTALLARCHLIB)/perllocal.pod + -$(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB) + -$(NOECHO) $(DOC_INSTALL) \ + "Module" "$(NAME)" \ + "installed into" "$(INSTALLSITELIB)" \ + LINKTYPE "$(LINKTYPE)" \ + VERSION "$(VERSION)" \ + EXE_FILES "$(EXE_FILES)" \ + >> $(DESTINSTALLARCHLIB)/perllocal.pod + +doc_vendor_install :: + $(NOECHO) $(ECHO) Appending installation info to $(DESTINSTALLARCHLIB)/perllocal.pod + -$(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB) + -$(NOECHO) $(DOC_INSTALL) \ + "Module" "$(NAME)" \ + "installed into" "$(INSTALLVENDORLIB)" \ + LINKTYPE "$(LINKTYPE)" \ + VERSION "$(VERSION)" \ + EXE_FILES "$(EXE_FILES)" \ + >> $(DESTINSTALLARCHLIB)/perllocal.pod + + +uninstall :: uninstall_from_$(INSTALLDIRS)dirs + $(NOECHO) $(NOOP) + +uninstall_from_perldirs :: + $(NOECHO) $(UNINSTALL) $(PERL_ARCHLIB)/auto/$(FULLEXT)/.packlist + +uninstall_from_sitedirs :: + $(NOECHO) $(UNINSTALL) $(SITEARCHEXP)/auto/$(FULLEXT)/.packlist + +uninstall_from_vendordirs :: + $(NOECHO) $(UNINSTALL) $(VENDORARCHEXP)/auto/$(FULLEXT)/.packlist + + +# --- MakeMaker force section: +# Phony target to force checking subdirectories. +FORCE : + $(NOECHO) $(NOOP) + + +# --- MakeMaker perldepend section: + + +# --- MakeMaker makefile section: +# We take a very conservative approach here, but it's worth it. +# We move Makefile to Makefile.old here to avoid gnu make looping. +$(FIRST_MAKEFILE) : Makefile.PL $(CONFIGDEP) + $(NOECHO) $(ECHO) "Makefile out-of-date with respect to $?" + $(NOECHO) $(ECHO) "Cleaning current config before rebuilding Makefile..." + -$(NOECHO) $(RM_F) $(MAKEFILE_OLD) + -$(NOECHO) $(MV) $(FIRST_MAKEFILE) $(MAKEFILE_OLD) + - $(MAKE) $(USEMAKEFILE) $(MAKEFILE_OLD) clean $(DEV_NULL) + $(PERLRUN) Makefile.PL + $(NOECHO) $(ECHO) "==> Your Makefile has been rebuilt. <==" + $(NOECHO) $(ECHO) "==> Please rerun the $(MAKE) command. <==" + false + + + +# --- MakeMaker staticmake section: + +# --- MakeMaker makeaperl section --- +MAP_TARGET = perl +FULLPERL = /usr/bin/perl + +$(MAP_TARGET) :: static $(MAKE_APERL_FILE) + $(MAKE) $(USEMAKEFILE) $(MAKE_APERL_FILE) $@ + +$(MAKE_APERL_FILE) : $(FIRST_MAKEFILE) pm_to_blib + $(NOECHO) $(ECHO) Writing \"$(MAKE_APERL_FILE)\" for this $(MAP_TARGET) + $(NOECHO) $(PERLRUNINST) \ + Makefile.PL DIR= \ + MAKEFILE=$(MAKE_APERL_FILE) LINKTYPE=static \ + MAKEAPERL=1 NORECURS=1 CCCDLFLAGS= + + +# --- MakeMaker test section: + +TEST_VERBOSE=0 +TEST_TYPE=test_$(LINKTYPE) +TEST_FILE = test.pl +TEST_FILES = t/*.t +TESTDB_SW = -d + +testdb :: testdb_$(LINKTYPE) + +test :: $(TEST_TYPE) subdirs-test + +subdirs-test :: + $(NOECHO) $(NOOP) + + +test_dynamic :: pure_all + PERL_DL_NONLAZY=1 $(FULLPERLRUN) "-MExtUtils::Command::MM" "-e" "test_harness($(TEST_VERBOSE), '$(INST_LIB)', '$(INST_ARCHLIB)')" $(TEST_FILES) + +testdb_dynamic :: pure_all + PERL_DL_NONLAZY=1 $(FULLPERLRUN) $(TESTDB_SW) "-I$(INST_LIB)" "-I$(INST_ARCHLIB)" $(TEST_FILE) + +test_ : test_dynamic + +test_static :: test_dynamic +testdb_static :: testdb_dynamic + + +# --- MakeMaker ppd section: +# Creates a PPD (Perl Package Description) for a binary distribution. +ppd : + $(NOECHO) $(ECHO) '' > $(DISTNAME).ppd + $(NOECHO) $(ECHO) ' $(DISTNAME)' >> $(DISTNAME).ppd + $(NOECHO) $(ECHO) ' Classes for Manipulating DBI Databases, Based on the CDIF Data Model Subject Area' >> $(DISTNAME).ppd + $(NOECHO) $(ECHO) ' imacat <imacat@mail.imacat.idv.tw>' >> $(DISTNAME).ppd + $(NOECHO) $(ECHO) ' ' >> $(DISTNAME).ppd + $(NOECHO) $(ECHO) ' ' >> $(DISTNAME).ppd + $(NOECHO) $(ECHO) ' ' >> $(DISTNAME).ppd + $(NOECHO) $(ECHO) ' ' >> $(DISTNAME).ppd + $(NOECHO) $(ECHO) ' ' >> $(DISTNAME).ppd + $(NOECHO) $(ECHO) ' ' >> $(DISTNAME).ppd + $(NOECHO) $(ECHO) ' ' >> $(DISTNAME).ppd + $(NOECHO) $(ECHO) ' ' >> $(DISTNAME).ppd + $(NOECHO) $(ECHO) ' ' >> $(DISTNAME).ppd + $(NOECHO) $(ECHO) ' ' >> $(DISTNAME).ppd + $(NOECHO) $(ECHO) ' ' >> $(DISTNAME).ppd + $(NOECHO) $(ECHO) '' >> $(DISTNAME).ppd + + +# --- MakeMaker pm_to_blib section: + +pm_to_blib : $(TO_INST_PM) + $(NOECHO) $(ABSPERLRUN) -MExtUtils::Install -e 'pm_to_blib({@ARGV}, '\''$(INST_LIB)/auto'\'', '\''$(PM_FILTER)'\'')' -- \ + lib/DbFramework/PrimaryKey.pm blib/lib/DbFramework/PrimaryKey.pm \ + lib/DbFramework/DataModelObject.pm blib/lib/DbFramework/DataModelObject.pm \ + lib/DbFramework/ForeignKey.pm blib/lib/DbFramework/ForeignKey.pm \ + lib/DbFramework/DataType/ANSII.pm blib/lib/DbFramework/DataType/ANSII.pm \ + lib/DbFramework/Util.pm blib/lib/DbFramework/Util.pm \ + lib/DbFramework/DataModel.pm blib/lib/DbFramework/DataModel.pm \ + lib/DbFramework/Persistent.pm blib/lib/DbFramework/Persistent.pm \ + lib/DbFramework/Template.pm blib/lib/DbFramework/Template.pm \ + lib/DbFramework/Key.pm blib/lib/DbFramework/Key.pm \ + lib/DbFramework/DataType/Mysql.pm blib/lib/DbFramework/DataType/Mysql.pm \ + lib/DbFramework/Relationship.pm blib/lib/DbFramework/Relationship.pm \ + lib/DbFramework/Catalog.pm blib/lib/DbFramework/Catalog.pm \ + lib/DbFramework/Table.pm blib/lib/DbFramework/Table.pm \ + lib/DbFramework/Attribute.pm blib/lib/DbFramework/Attribute.pm \ + lib/DbFramework/DefinitionObject.pm blib/lib/DbFramework/DefinitionObject.pm + $(NOECHO) $(TOUCH) pm_to_blib + + +# --- MakeMaker selfdocument section: + + +# --- MakeMaker postamble section: + + +# End. diff --git a/Makefile.PL b/Makefile.PL new file mode 100755 index 0000000..f6ea994 --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,318 @@ +#! /usr/bin/perl -w +# See lib/ExtUtils/MakeMaker.pm for details of how to influence +# the contents of the Makefile that is written. +use ExtUtils::MakeMaker; +use lib qw(lib); +use DbFramework::Util; +require 't/util.pl'; + +$catalog_db = 'dbframework_catalog'; +%keytypes = (primary => 0, foreign => 1, index => 2); + +prompt(<{$db}->{dsn} = "DBI:$driver:$_"; + ($driver{$driver}->{$db}->{u},$driver{$driver}->{$db}->{p}) + = DbFramework::Util::get_auth(); + if ( $db eq $catalog_db ) { + if ( prompt("Create schema for '$catalog_db' in DBI:$driver?", "N") !~ /^n/i ) { + # create catalog schema + my %sql = %{catalog_schema()}; + # default to mysql DDL syntax + $ddl = (exists $sql{$driver}) ? $driver : 'mysql'; + $dsn = $driver{$driver}->{$db}->{dsn}; + $u = $driver{$driver}->{$db}->{u}; + $p = $driver{$driver}->{$db}->{p}; + my $dbh = DbFramework::Util::get_dbh($dsn,$u,$p); + $dbh->{PrintError} = 0; + for my $table ( qw/c_db c_key c_relationship c_table/ ) { + drop_create($catalog_db,$table,undef,$sql{$ddl}->{$table},$dbh); + } + my($t1,$t2) = ('foo','bar'); + + ## set db + my $sql = qq{ + INSERT INTO c_db + VALUES('$test_db')}; + my $sth = do_sql($dbh,$sql); $sth->finish; + + ## set tables + $sql = qq{ + INSERT INTO c_table + VALUES('$t1','$test_db','bar')}; + $sth = do_sql($dbh,$sql); $sth->finish; + $sql = qq{ + INSERT INTO c_table + VALUES('$t2','$test_db',NULL)}; + $sth = do_sql($dbh,$sql); $sth->finish; + + ## set primary keys + $sql = qq{ + INSERT INTO c_key + VALUES('$test_db','$t1','primary',$keytypes{primary},'foo:bar')}; + $sth = do_sql($dbh,$sql); $sth->finish; + $sql = qq{ + INSERT INTO c_key + VALUES('$test_db','$t2','primary',$keytypes{primary},'foo')}; + $sth = do_sql($dbh,$sql); $sth->finish; + + ## set keys (indexes) + $sql = qq{ + INSERT INTO c_key + VALUES('$test_db','$t1','foo',$keytypes{index},'bar:baz')}; + $sth = do_sql($dbh,$sql); $sth->finish; + $sql = qq{ + INSERT INTO c_key + VALUES('$test_db','$t1','bar',$keytypes{index},'baz:quux')}; + $sth = do_sql($dbh,$sql); $sth->finish; + + ## set foreign keys + $sql = qq{ + INSERT INTO c_key + VALUES('$test_db','$t2','f_foo',$keytypes{foreign},'foo_foo:foo_bar')}; + $sth = do_sql($dbh,$sql); $sth->finish; + $sql = qq{ + INSERT INTO c_relationship + VALUES('$test_db','$t2','f_foo','$t1') + }; + $sth = do_sql($dbh,$sql); $sth->finish; + print "Done.\n"; + $dbh->disconnect; + } + } + } + } + + open(CONFIG,">$config") || die "Couldn't open config file: $config: $!"; + print "Writing config file: $config\n"; + print CONFIG qq{package t::Config; + +\$test_db = '$test_db'; +\@drivers = qw/@drivers/; +\%driver = (}; + + while ( my($k,$v) = each %driver ) { + print CONFIG "$k => { \n"; + while ( my($k,$v) = each %$v ) { + print CONFIG "$k => { \n"; + while ( my($k,$v) = each %$v ) { + print CONFIG "$k => '$v',"; + } + print CONFIG "},\n"; + } + print CONFIG "},\n"; + } + + print CONFIG qq{); + +1; + +}; + + close CONFIG; + print < { c_db => q{ +CREATE TABLE c_db ( + db_name varchar(50) DEFAULT '' NOT NULL, + PRIMARY KEY (db_name) + ) +}, + c_key => q{ +CREATE TABLE c_key ( + db_name varchar(50) DEFAULT '' NOT NULL, + table_name varchar(50) DEFAULT '' NOT NULL, + key_name varchar(50) DEFAULT '' NOT NULL, + key_type int DEFAULT '0' NOT NULL, + key_columns varchar(255) DEFAULT '' NOT NULL, + PRIMARY KEY (db_name,table_name,key_name) + ) +}, + c_relationship => q{ +CREATE TABLE c_relationship ( + db_name varchar(50) DEFAULT '' NOT NULL, + fk_table varchar(50) DEFAULT '' NOT NULL, + fk_key varchar(50) DEFAULT '' NOT NULL, + pk_table varchar(50) DEFAULT '' NOT NULL, + PRIMARY KEY (db_name,fk_table,fk_key,pk_table) + ) +}, + c_table => q{ +CREATE TABLE c_table ( + table_name varchar(50) DEFAULT '' NOT NULL, + db_name varchar(50) DEFAULT '' NOT NULL, + labels varchar(127) DEFAULT '', + PRIMARY KEY (table_name,db_name) + ) +} }, + CSV => { c_db => q{ +CREATE TABLE c_db ( + db_name varchar(50) + ) +}, + c_key => q{ +CREATE TABLE c_key ( + db_name varchar(50), + table_name varchar(50), + key_name varchar(50), + key_type int, + key_columns varchar(255) + ) +}, + c_relationship => q{ +CREATE TABLE c_relationship ( + db_name varchar(50), + fk_table varchar(50), + fk_key varchar(50), + pk_table varchar(50) + ) +}, + c_table => q{ +CREATE TABLE c_table ( + table_name varchar(50), + db_name varchar(50), + labels varchar(127) + ) +} }, + mysql => { c_db => q{ +CREATE TABLE c_db ( + db_name varchar(50) DEFAULT '' NOT NULL, + PRIMARY KEY (db_name) + ) +}, + c_key => q{ +CREATE TABLE c_key ( + db_name varchar(50) DEFAULT '' NOT NULL, + table_name varchar(50) DEFAULT '' NOT NULL, + key_name varchar(50) DEFAULT '' NOT NULL, + key_type int DEFAULT '0' NOT NULL, + key_columns varchar(255) DEFAULT '' NOT NULL, + PRIMARY KEY (db_name,table_name,key_name) + ) +}, + c_relationship => q{ +CREATE TABLE c_relationship ( + db_name varchar(50) DEFAULT '' NOT NULL, + fk_table varchar(50) DEFAULT '' NOT NULL, + fk_key varchar(50) DEFAULT '' NOT NULL, + pk_table varchar(50) DEFAULT '' NOT NULL, + PRIMARY KEY (db_name,fk_table,fk_key,pk_table) + ) +}, + c_table => q{ +CREATE TABLE c_table ( + table_name varchar(50) DEFAULT '' NOT NULL, + db_name varchar(50) DEFAULT '' NOT NULL, + labels varchar(127) DEFAULT '' NULL, + PRIMARY KEY (table_name,db_name) + ) +} }, + mSQL => { c_db => q{ +CREATE TABLE c_db ( + db_name char(50) NOT NULL + ) +}, + c_key => q{ +CREATE TABLE c_key ( + db_name char(50) NOT NULL, + table_name char(50) NOT NULL, + key_name char(50) NOT NULL, + key_type int NOT NULL, + key_columns char(255) NOT NULL +) +}, + c_relationship => q{ +CREATE TABLE c_relationship ( + db_name char(50) NOT NULL, + fk_table char(50) NOT NULL, + fk_key char(50) NOT NULL, + pk_table char(50) NOT NULL + ) +}, + c_table => q{ +CREATE TABLE c_table ( + table_name char(50) NOT NULL, + db_name char(50) NOT NULL, + labels char(127) + ) +} } + } +} + +# LICENSE is only availabe since ExtUtils::MakeMaker 6.30_01 +use vars qw(%license $eummver); +%license = qw(); +$eummver = $ExtUtils::MakeMaker::VERSION; +$eummver =~ s/_//; +%license = (LICENSE => "perl") if $eummver > 6.30; + +WriteMakefile( + NAME => "DbFramework", + VERSION => "1.12", + ABSTRACT => "Classes for Manipulating DBI Databases, Based on the CDIF Data Model Subject Area", + AUTHOR => "imacat ", + %license, + PREREQ_PM => { + "Alias" => 0, + "DBI" => 1.06, + "CGI" => 0, + "Text::FillIn" => 0, + "URI::Escape" => 0, + "Term::ReadKey" => 0, + }, + PL_FILES => { }, + SIGN => 1, + + dist => { + COMPRESS => "gzip -9", + SUFFIX => ".gz", + }, + clean => { + FILES => "t/Config.pm TAGS", + }, +); diff --git a/README b/README new file mode 100644 index 0000000..f8c11e5 --- /dev/null +++ b/README @@ -0,0 +1,78 @@ +DbFramework is a collection of classes for manipulating DBI databases. +The classes are loosely based on the CDIF Data Model Subject Area. + +Note: Do not use DbFramework. I believe it is outdated and not working +anymore. I obtained its ownership only to keep it clean until it is +retired. If you were using DbFramework, consider other, more recent +solutions like XML instead. + +The last release 1.10 of DbFramework is due 1999-05-13, even before Perl +5.005_03. As today is 2008-04-19, that is NINE years ago. It is not +suprising DbFramework does not work now. If you are still using CDIF +Data Model Subject Area, it might be easier to migrate your code to use +XML, than to make DbFramework working. Besides, DbFramework takes +a CPAN root namespace, DbFramework::*, which is not right, too. + +DbFramework was written by Paul Sharpe (paul@miraclefish.com, CPAN ID: +PSHARPE). If you are looking for older versions, see Paul's BackPen +directory: http://backpan.perl.org/authors/id/P/PS/PSHARPE/ + +Please report bugs to rt.cpan.org. Even that I may not fix them, they +are still public records that could help the others understanding them. + +By imacat , written 2008-04-19. +============= +DbFramework is a collection of classes for manipulating DBI databases. +The classes are loosely based on the CDIF Data Model Subject Area. + +This module will help you to + + - Present data model objects (tables, columns) as HTML + - Add persistency to your Perl objects + - Manipulate DBI databases through an HTML forms interface + +See the POD for further details. + +Prerequisites +============= + + Perl 5.005 + Alias + CGI + URI::Escape + DBI 1.06 + Text::FillIn + Term::ReadKey + +DbFramework has been successfully built and tested on (at least) the +following configurations. In general the driver version is VERY +IMPORTANT as DbFramework makes use of some of the newer DBI metadata +methods which may only be implemented in development branches of +certain drivers. + + OS Driver Database + ================ ========================== =================== + RedHat Linux 5.1 Msql-Mysql-modules-1.21_15 Mysql 3.22.14-gamma + Msql-Mysql-modules-1.21_15 Msql 2.0.8 + DBD-Pg-0.91 PostgreSQL 6.4.2 + +Note that DBD::CSV is unlikely to be supported in the near future due +to the limitations of this driver. + +Installation +============ + + 1) Ensure you have installed the prerequisites above. + + 2) perl Makefile.PL + Select each DBD driver you wish to test DbFramework against. + make + make test + You will need permission to create the databases 'dbframework_test' + and 'dbframework_catalog' for each DBI driver you chose to test. + make install + +To use forms/dbforms.cgi, install it in a CGI directory then 'perldoc +forms/dbforms.cgi'. + +paul@miraclefish.com diff --git a/SIGNATURE b/SIGNATURE new file mode 100644 index 0000000..1b2ee6e --- /dev/null +++ b/SIGNATURE @@ -0,0 +1,58 @@ +This file contains message digests of all files listed in MANIFEST, +signed via the Module::Signature module, version 0.55. + +To verify the content in this distribution, first make sure you have +Module::Signature installed, then type: + + % cpansign -v + +It will check each file's integrity, as well as the signature's +validity. If "==> Signature verified OK! <==" is not displayed, +the distribution may already have been compromised, and you should +not run its Makefile.PL or Build.PL. + +-----BEGIN PGP SIGNED MESSAGE----- +Hash: SHA1 + +SHA1 a679d98cb7145fb68be7570425370ce6224689c0 AUTHORS +SHA1 be0627fff2e8aef3d2a14d5d7486babc8a4873ba Artistic +SHA1 357d0bf457b5d3f7e5ffa264745b0ca936ec1800 Build.PL +SHA1 8624bcdae55baeef00cd11d5dfcfa60f68710a02 COPYING +SHA1 a286ec26956d71dbff229e86bea7e989943822a6 Changes +SHA1 f571fb7a3ede932cd7af4464f53e307b0ef0a345 MANIFEST +SHA1 4ed7c30f29bcfb84abded747fc65d57439f9c0d5 META.yml +SHA1 e5b82da01a02ce61f3eefa98d0fcf370c918fd07 Makefile.PL +SHA1 819243ec435702f419673c0b0e52074928091c02 README +SHA1 069311923a9a5ce342bed8daafcead7a173ada4a TODO +SHA1 d738fc0c4750e5cca4c5331a7f81b642c74c6ca8 forms/dbforms.cgi +SHA1 3838d1387f5d1d4587a75d720069a6a9dd40d71b lib/DbFramework/Attribute.pm +SHA1 66566a46862c7335d4cca4dcce86f6628c8e6ab7 lib/DbFramework/Catalog.pm +SHA1 7eeebafc4dddc5f0821bee571ece66460e08f4d0 lib/DbFramework/DataModel.pm +SHA1 b55df0160345f967d3a620d761e952f8b06e8121 lib/DbFramework/DataModelObject.pm +SHA1 bbfba57d46163b15cba222875987da0fa35874fa lib/DbFramework/DataType/ANSII.pm +SHA1 e2bb3c108f3f8e5c415a000a077a95c9a28de12c lib/DbFramework/DataType/Mysql.pm +SHA1 03b5b99f872e57e69d3c9c51221d4135a1fa7b61 lib/DbFramework/DefinitionObject.pm +SHA1 007da37acd0b05d39eb5a22722067c7c1d5a3627 lib/DbFramework/ForeignKey.pm +SHA1 bea535189a79352154d8bd3fcabfd9766042ca45 lib/DbFramework/Key.pm +SHA1 607f0330f2f423df32eb77dd357f0eb3371e690f lib/DbFramework/Persistent.pm +SHA1 93cf31db275578e1dd81543aff64227b4bda30c8 lib/DbFramework/PrimaryKey.pm +SHA1 337e27a37b0ebf173b1307af3ce4899c3b93f635 lib/DbFramework/Relationship.pm +SHA1 73e4b0973cd54cde69dc8313bf3daaa3816d0953 lib/DbFramework/Table.pm +SHA1 d295442819c677ea01b3f1c0fb1903a473c9d5d9 lib/DbFramework/Template.pm +SHA1 7d6b52232e52dcd4026ac52176ba53790ade83c0 lib/DbFramework/Util.pm +SHA1 025178ab79a02175f0078661ead7aa978b1a48a4 t/10base.t +SHA1 038c3ed12c48d1ccb523cb29c41c88a24803a0cd t/15catalog.t +SHA1 360cef80c3cafeefcd47717d75d868a89a9f33f6 t/17datatype.t +SHA1 f13586408a7e059991b0191b6d7cb4f496693df7 t/20table.t +SHA1 2e11ee0000d5eac1ec349be010ee6e5d8dc81ce3 t/30persistent.t +SHA1 61d3a46315dc447e8e1d1976676fe57ac992b063 t/40template.t +SHA1 ed7b13a575d7eb7b31eb1530976030c2a990fb30 t/template +SHA1 f7888dea771f14b105c2628711bc112b79a90737 t/test/foo/foo.form +SHA1 567aa1bf40d2fd42957d0ca95d815790c35f8752 t/util.pl +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.4.9 (GNU/Linux) + +iEYEARECAAYFAkgbyqYACgkQi9gubzC5S1zXHwCfai7eg9AkpEUizI/5fCnbrZIa +hqsAn29CM3sA5/bmzC4zMcoM8iQVGEDO +=KWYc +-----END PGP SIGNATURE----- diff --git a/TODO b/TODO new file mode 100644 index 0000000..4d0ad4d --- /dev/null +++ b/TODO @@ -0,0 +1,22 @@ +DbFramework TODO list + +- Moved the test tables creation from Makefile.PL/Build.PL to the + test suite, and clean up the test tables after the test suite + finished. +- Remove the Makefile.PL/Build.PL dependency to DbFramework::Util, + and hence Term::ReadKey. It does not make sense that + Makefile.PL/Build.PL fails to run. CPAN and CPANPLUS shells + cannot install with this, too. +- Rename t/util.pl to t/util.pm, and remove Makefile.PL/Build.PL + dependency to it, too. +- Dealing with the installation of forms/dbforms.cgi. +- Seperate INSTALL from README. +- Register a proper name space and drop the unused. +- Transfer the primary maintainer of DbFramework::CandidateKey, + DbFramework::Catalog, DbFramework::DataModelObject, + DbFramework::DataType::ANSII, DbFramework::DataType::Mysql, + DbFramework::DefinitionObject, DbFramework::Relationship and + DbFramework::Template to me. +- Remove "UNAUTHORIZED RELEASE" from search.cpan.org. +- Maybe make DbFramework working again. +- Retire DbFramework. diff --git a/forms/dbforms.cgi b/forms/dbforms.cgi new file mode 100755 index 0000000..29b5c97 --- /dev/null +++ b/forms/dbforms.cgi @@ -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 presents a simple HTML forms interface to any database +configured to work with B. The database B have the +appropriate catalog entries in the catalog database before it will +work with this script (see L.) + +=head2 Query string arguments + +The following arguments are supported in the query string. Mandatory +arguments are shown in B. + +=over 4 + +=item B + +The name of the database. + +=item B + +The portion of the DBI DSN after 'DBI:' to be used to connect to the +database e.g. 'mysql:database=foo'. + +=item B + +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 + +The host on which the database is located (default = 'localhost'.) + +=back + +=head1 SEE ALSO + +L. + +=head1 AUTHOR + +Paul Sharpe Epaul@miraclefish.comE + +=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 "ERROR!

$message\n"; +} + +print $cgi->header; +print < + + + $db: $table + + + + + + + }; +} + +##---------------------------------------------------------------------------- + +sub _output_template { + my($self,$t_name) = (attr shift,shift); + return qq{}; +} + +#----------------------------------------------------------------------------- + +=head2 as_html_heading($bgcolor) + +Returns a string for use as a column heading cell in an HTML table. +I<$bgcolor> is the background colour to use for the heading. + +=cut + +sub as_html_heading { + my $self = attr shift; + my $bgcolor = shift || $BGCOLOR; + my $text = $NAME; + $text .= ' ('.$REFERENCES->extra.')' if $REFERENCES->extra; + qq{}; +} + +1; + +=head1 SEE ALSO + +L and L. + +=head1 AUTHOR + +Paul Sharpe Epaul@miraclefish.comE + +=head1 COPYRIGHT + +Copyright (c) 1997,1998,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 diff --git a/lib/DbFramework/Catalog.pm b/lib/DbFramework/Catalog.pm new file mode 100644 index 0000000..4c8fdda --- /dev/null +++ b/lib/DbFramework/Catalog.pm @@ -0,0 +1,326 @@ +=head1 NAME + +DbFramework::Catalog - Catalog class + +=head1 SYNOPSIS + + use DbFramework::Catalog; + my $c = new DbFramework::Catalog($dsn,$user,$password); + $c->set_primary_key($table); + $c->set_keys($table); + $c->set_foreign_keys($dm); + +=head1 DESCRIPTION + +B is a class for manipulating the catalog +database used by various DbFramework modules and scripts. + +=head2 The Catalog + +DbFramework retrieves as much metadata as possible using DBI. It aims +to store the metadata B provided by DBI in a consistent manner +across all DBI drivers by using a catalog database called +I. Each database you use with DbFramework +B corresponding key information added to the catalog. The +I database will be created for each driver you +test when you build DbFramework. Entries in the catalog only need to +be modified when the corresponding database schema changes. + +The following (Mysql) SQL creates the catalog database schema. + + CREATE TABLE c_db ( + db_name varchar(50) DEFAULT '' NOT NULL, + PRIMARY KEY (db_name) + ); + + CREATE TABLE c_key ( + db_name varchar(50) DEFAULT '' NOT NULL, + table_name varchar(50) DEFAULT '' NOT NULL, + key_name varchar(50) DEFAULT '' NOT NULL, + key_type int(11) DEFAULT '0' NOT NULL, + key_columns varchar(255) DEFAULT '' NOT NULL, + PRIMARY KEY (db_name,table_name,key_name) + ); + + CREATE TABLE c_relationship ( + db_name varchar(50) DEFAULT '' NOT NULL, + fk_table varchar(50) DEFAULT '' NOT NULL, + fk_key varchar(50) DEFAULT '' NOT NULL, + pk_table varchar(50) DEFAULT '' NOT NULL, + PRIMARY KEY (db_name,fk_table,fk_key,pk_table) + ); + + CREATE TABLE c_table ( + table_name varchar(50) DEFAULT '' NOT NULL, + db_name varchar(50) DEFAULT '' NOT NULL, + labels varchar(127) DEFAULT '', + PRIMARY KEY (table_name,db_name) + ); + +The example below shows the creation of a simple Mysql database and +the corresponding catalog entries required by DbFramework. + + CREATE DATABASE foo; + use foo; + + CREATE TABLE foo ( + foo integer not null, + bar varchar(50), + KEY var(bar), + PRIMARY KEY (foo) + ); + + CREATE TABLE bar ( + bar integer not null, + # foreign key to table foo + foo integer not null, + PRIMARY KEY (bar) + ); + + use dbframework_catalog; + + # catalog entry for database 'foo' + INSERT INTO c_db VALUES('foo'); + + # catalog entries for table 'foo' + INSERT INTO c_table VALUES('foo','foo','bar'); + # primary key type = 0 + INSERT INTO c_key VALUES('foo','foo','primary',0,'foo'); + # index type = 2 + INSERT INTO c_key VALUES('foo','foo','bar_index',2,'bar'); + + # catalog entries for table 'bar' + INSERT INTO c_table VALUES('bar','foo',NULL); + # primary key type = 0 + INSERT INTO c_key VALUES('foo','bar','primary',0,'bar'); + # foreign key type = 1 + INSERT INTO c_key VALUES('foo','bar','foreign_foo',2,'foo'); + # relationship between 'bar' and 'foo' + INSERT INTO c_relationship VALUES('foo','bar','foreign_foo','foo'); + +=head1 SUPERCLASSES + +B + +=cut + +package DbFramework::Catalog; +use strict; +use base qw(DbFramework::Util); +use DbFramework::PrimaryKey; +use DbFramework::ForeignKey; +use Alias; +use Carp; +use vars qw($DBH $_DEBUG %keytypes $db); + +## CLASS DATA + +my %fields = ( + DBH => undef, + ); + +$db = 'dbframework_catalog'; +%keytypes = (primary => 0, foreign => 1, index => 2); + +##----------------------------------------------------------------------------- +## CLASS METHODS +##----------------------------------------------------------------------------- + +=head1 CLASS METHODS + +=head2 new($dsn,$user,$password) + +Create a new B object. I<$dsn> is the DBI data +source name containing the catalog database (default is +'dbframework_catalog'). I<$user> and I<$password> are optional +arguments specifying the username and password to use when connecting +to the database. + +=cut + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + + my $self = bless({},$class); + for my $element (keys %fields) { + $self->{_PERMITTED}->{$element} = $fields{$element}; + } + @{$self}{keys %fields} = values %fields; + $self->dbh(DbFramework::Util::get_dbh(@_)); + $self->dbh->{PrintError} = 0; + return $self; +} + +##----------------------------------------------------------------------------- +## OBJECT METHODS +##----------------------------------------------------------------------------- + +=head1 OBJECT METHODS + +=head2 set_primary_key($table) + +Set the primary key for the B object I<$table>. +The catalog column B may contain a colon seperated +list of column names to be used as 'labels' (see +L.) + +=cut + +sub set_primary_key { + my $self = attr shift; + my $table = shift; + my $sth = $self->_get_key_columns($table,'primary'); + if ( $sth->rows == 0 ) { + $sth->finish; + carp "Can't get primary key for ",$table->name,"\n" + } + my($name,$columns) = @{$sth->fetchrow_arrayref}; + $sth->finish; + my @attributes = $table->get_attributes(split /:/,$columns); + + # get label columns + my $table_name = $DBH->quote($table->name); + my $db_name = $DBH->quote($table->belongs_to->db); + my $sql = qq{ +SELECT labels +FROM c_table +WHERE db_name = $db_name +AND table_name = $table_name +}; + print STDERR "$sql\n" if $_DEBUG; + $sth = $DBH->prepare($sql) || die($DBH->errstr); + my $rv = $sth->execute || die($sth->errstr); + my($labels) = $sth->fetchrow_array; + my $labels_ref = undef; + @$labels_ref = split /:/,$labels if defined $labels && $labels ne ''; + $sth->finish; + print STDERR "$table_name.pk: $columns\n" if $_DEBUG; + my $pk = new DbFramework::PrimaryKey(\@attributes,$table,$labels_ref); + $table->is_identified_by($pk); +} + +##----------------------------------------------------------------------------- + +=head2 set_keys($table) + +Set the keys (indexes) for the B object I<$table>. + +=cut + +sub set_keys { + my $self = attr shift; + my $table = shift; + my $sth = $self->_get_key_columns($table,'index'); + my @keys; + while ( my $rowref = $sth->fetchrow_arrayref ) { + my($name,$columns) = @$rowref; + print STDERR "$name $columns\n" if $_DEBUG; + my @attributes = $table->get_attributes(split /:/,$columns); + my $key = new DbFramework::Key($name,\@attributes); + $key->belongs_to($table); + push(@keys,$key); + } + $table->is_accessed_using_l(\@keys); + $sth->finish; +} + +##----------------------------------------------------------------------------- + +=head2 set_foreign_keys($dm) + +Set the foreign keys for the B object I<$dm>. + +=cut + +sub set_foreign_keys { + my $self = attr shift; + my $dm = shift; + my $db_name = $DBH->quote($dm->db); + for my $table ( @{$dm->collects_table_l} ) { + my $table_name = $DBH->quote($table->name); + my $sql; + if ( $dm->driver eq 'CSV' ) { + $sql = qq{ +SELECT key_name,key_columns,pk_table +FROM c_relationship,c_key WHERE c_relationship.db_name = $db_name +AND c_relationship.fk_table = $table_name +AND c_relationsihp.db_name = c_key.db_name +AND c_relationship.fk_table = c_key.table_name +AND c_relationship.fk_key = c_key.key_name +}; + } else { + $sql = qq{ +SELECT k.key_name,k.key_columns,r.pk_table +FROM c_relationship r, c_key k +WHERE r.db_name = $db_name +AND r.fk_table = $table_name +AND r.db_name = k.db_name +AND r.fk_table = k.table_name +AND r.fk_key = k.key_name +}; + } + print STDERR "$sql\n" if $_DEBUG; + my $sth = DbFramework::Util::do_sql($DBH,$sql); + while ( my $rowref = $sth->fetchrow_arrayref ) { + my($name,$columns,$pk_table_name) = @$rowref; + print STDERR "name = $name, columns = $columns, pk_table = $pk_table_name)\n" if $_DEBUG; + my @attributes = $table->get_attributes(split /:/,$columns); + my $pk_table = $table->belongs_to->collects_table_h_byname($pk_table_name); + + my $fk = new DbFramework::ForeignKey($name, + \@attributes, + $pk_table->is_identified_by); + $fk->belongs_to($table); + $table->has_foreign_keys_l_add($fk); # by number + $table->has_foreign_keys_h_add({$fk->name => $fk}); # by name + $pk_table->is_identified_by->incorporates($fk); # pk ref + } + $sth->finish; + + $table->validate_foreign_keys; + # default templates need updating after setting foreign keys + #$table->_templates; + } +} + +##----------------------------------------------------------------------------- + +sub _get_key_columns { + my $self = attr shift; + my($table,$key_type) = @_; + my $table_name = $DBH->quote($table->name); + my $db_name = $DBH->quote($table->belongs_to->db); + my $sql = qq{ +SELECT key_name,key_columns +FROM c_key +WHERE db_name = $db_name +AND table_name = $table_name +AND key_type = $keytypes{$key_type} +}; + print STDERR "$sql\n" if $_DEBUG; + my $sth = $DBH->prepare($sql) || die($DBH->errstr); + my $rv = $sth->execute || die($sth->errstr); + return $sth; +} + +##----------------------------------------------------------------------------- + +sub DESTROY { + my $self = attr shift; + $DBH->disconnect; +} + +1; + +=head1 AUTHOR + +Paul Sharpe Epaul@miraclefish.comE + +=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 diff --git a/lib/DbFramework/DataModel.pm b/lib/DbFramework/DataModel.pm new file mode 100644 index 0000000..097c8bb --- /dev/null +++ b/lib/DbFramework/DataModel.pm @@ -0,0 +1,195 @@ +=head1 NAME + +DbFramework::DataModel - Data Model class + +=head1 SYNOPSIS + + use DbFramework::DataModel; + $dm = new DbFramework::DataModel($name,$dsn,$user,$password); + $dm->init_db_metadata($catalog_dsn,$user,$password); + @tables = @{$dm->collects_table_l}; + %tables = %{$dm->collects_table_h}; + @tables = @{$dm->collects_table_h_byname(@tables)}; + $sql = $dm->as_sql; + $db = $dm->db; + $driver = $dm->driver; + +=head1 DESCRIPTION + +A B object represents a database schema. It +can be initialised using the metadata provided by a DBI driver and a +catalog database (see L). + +=head1 SUPERCLASSES + +B + +=cut + +package DbFramework::DataModel; +use strict; +use vars qw( $NAME $_DEBUG @COLLECTS_TABLE_L $DBH $DSN ); +use base qw(DbFramework::Util); +use DbFramework::Table; +use DbFramework::ForeignKey; +use DBI; +use Alias; + +## CLASS DATA + +my %fields = ( + NAME => undef, + # DataModel 0:N Collects 0:N DataModelObject + COLLECTS_L => undef, + # DataModel 0:N Collects 0:N Table + COLLECTS_TABLE_L => undef, + COLLECTS_TABLE_H => undef, + DBH => undef, + DSN => undef, + DRIVER => undef, + DB => undef, + TYPE_INFO_L => undef, +); + +# arbitrary number to add to SQL type numbers as they can be negative +# and we want to store them in an array +my $_sql_type_adjust = 1000; + +############################################################################### +# CLASS METHODS +############################################################################### + +=head1 CLASS METHODS + +=head2 new($name,$dsn,$user,$password) + +Create a new B object. I<$name> is the name of +the database associated with the data model. I<$dsn> is the DBI data +source name associated with the data model. I<$user> and I<$password> +are optional arguments specifying the username and password to use +when connecting to the database. + +=cut + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = bless { _PERMITTED => \%fields, %fields, }, $class; + $self->name(shift); + $self->dbh(DbFramework::Util::get_dbh(@_)); + #$self->init_db_metadata; + # hack to record driver/db name until I confirm whether $dbh->{Name} + # has been implemented for mSQL and Mysql + $self->dsn($_[0]); + $self->driver($_[0] =~ /DBI:(.*):/); + $self->db($self->name); + # cache type_info here as it's an expensive function for ODBC + $self->type_info_l([$self->dbh->type_info($DBI::SQL_ALL_TYPES)]); + return $self; +} + +############################################################################### +# OBJECT METHODS +############################################################################### + +=head1 OBJECT METHODS + +A data model has a number of tables. These tables can be accessed +using the methods I and I. See +L for the accessor methods for these +attributes. + +=head2 name($name) + +If I<$name> is supplied sets the name of the database associated with +the data model. Returns the database name. + +=head2 dsn() + +Returns the DBI DSN of the database associated with the data model. + +=head2 db() + +Synonym for name(). + +=head2 driver() + +Returns the name of the driver associated with the data model. + +=head2 as_sql() + +Returns a SQL string which can be used to create the tables which make +up the data model. + +=cut + +sub as_sql { + my $self = attr shift; + my $sql; + for ( @COLLECTS_TABLE_L ) { $sql .= $_->as_sql($DBH) . ";\n" } + return $sql; +} + +#------------------------------------------------------------------------------ + +=head2 init_db_metadata($catalog_dsn,$user,$password) + +Returns a B object configured using metadata +from the database handle returned by dbh() and the catalog (see +L). I<$catalog_dsn> is the DBI data source name +associated with the catalog. I<$user> and I<$password> are used for +authorisation against the catalog database. Foreign keys will be +automatically configured for tables in the data model but this method +will die() unless the number of attributes in each foreign and related +primary key match. + +=cut + +sub init_db_metadata { + my $self = attr shift; + my $c = new DbFramework::Catalog(@_); + + # add tables + my($table,@tables,@byname); + my $sth = $DBH->table_info; + while ( my @table_info = $sth->fetchrow_array ) { + my $table_name = $table_info[2]; + print STDERR "table: $table_name, table_info = @table_info\n" if $_DEBUG; + my $table = DbFramework::Table->new($table_name,undef,undef,$DBH,$self); + push(@tables,$table->init_db_metadata($c)); + print STDERR "table: ",$table->name," pk: ",join(',',$table->is_identified_by->attribute_names),"\n" if $_DEBUG; + } + $self->collects_table_l(\@tables); + for ( @tables ) { push(@byname,($_->name,$_)) } + $self->collects_table_h(\@byname); + + # add foreign keys + $c->set_foreign_keys($self); + + return $self; +} + +#------------------------------------------------------------------------------ + +=head1 SEE ALSO + +L, L and +L. + +=head1 AUTHOR + +Paul Sharpe Epaul@miraclefish.comE + +=head1 COPYRIGHT + +Copyright (c) 1997,1998 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. + +=head1 ACKNOWLEDGEMENTS + +This module was inspired by B. + +=cut + +1; diff --git a/lib/DbFramework/DataModelObject.pm b/lib/DbFramework/DataModelObject.pm new file mode 100644 index 0000000..c92f05e --- /dev/null +++ b/lib/DbFramework/DataModelObject.pm @@ -0,0 +1,56 @@ +=head1 NAME + +DbFramework::DataModelObject - DataModelObject class + +=head1 SYNOPSIS + + use DbFramework::DataModelObject; + +=head1 DESCRIPTION + +Abstract class for CDIF Data Model objects. + +=head1 SUPERCLASSES + +B + +=cut + +package DbFramework::DataModelObject; +use strict; +use vars qw( $NAME ); +use base qw(DbFramework::Util); +use Alias; + +## CLASS DATA + +my %fields = ( + # DataModelObject 1:1 ActsAs 0:N RolePlayer + ACTS_AS => undef, + ); + +##----------------------------------------------------------------------------- +## CLASS METHODS +##----------------------------------------------------------------------------- + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = bless { _PERMITTED => \%fields, %fields, }, $class; + $self->name(shift); + return $self; +} + +1; + +=head1 AUTHOR + +Paul Sharpe Epaul@miraclefish.comE + +=head1 COPYRIGHT + +Copyright (c) 1998 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 diff --git a/lib/DbFramework/DataType/ANSII.pm b/lib/DbFramework/DataType/ANSII.pm new file mode 100644 index 0000000..a5f1012 --- /dev/null +++ b/lib/DbFramework/DataType/ANSII.pm @@ -0,0 +1,142 @@ +=head1 NAME + +DbFramework::DataType::ANSII - ANSII data type class + +=head1 SYNOPSIS + + use DbFramework::DataType::ANSII; + $dt = new DbFramework::DataType::ANSII($dm,$type,$ansii_type,$length); + $name = $dt->name($name); + $type = $type($type); + $length = $dt->length($length); + $extra = $dt->extra($extra); + $ansii = $dt->ansii_type; + +=head1 DESCRIPTION + +A B object represents an ANSII data type. + +=head1 SUPERCLASSES + +B + +=cut + +package DbFramework::DataType::ANSII; +use strict; +use base qw(DbFramework::DefinitionObject); +use Alias; +use vars qw(); + +## CLASS DATA + +my %fields = ( + LENGTH => undef, + EXTRA => undef, + TYPES_L => undef, + TYPE => undef, + ANSII_TYPE => undef, + ); + +# arbitrary number to add to SQL type numbers as they can be negative +# and we want to store them in an array +my $_sql_type_adjust = 1000; + +##----------------------------------------------------------------------------- +## CLASS METHODS +##----------------------------------------------------------------------------- + +=head1 CLASS METHODS + +=head2 new($dm,$type,$ansii_type,$length) + +Create a new B object. I<$dm> is a +B object. I<$type> is a numeric ANSII type +e.g. a type contained in the array reference returned by $sth->{TYPE}. +This method will die() unless I<$type> is a member of the set of ANSII +types supported by the DBI driver. I<$ansii_type> is the same as +I<$type>. I<$length> is the length of the data type. + +=cut + +sub new { + my $_debug = 0; + my $proto = shift; + my $class = ref($proto) || $proto; + my $dm = shift; + my $realtype = shift; + shift; # ansii_type is the same as type + my $type = $realtype + $_sql_type_adjust; + + my(@types,@type_names); + print "type_info_l = ",@{$dm->type_info_l},"\n" if $_debug; + for my $t ( @{$dm->type_info_l} ) { + # first DATA_TYPE returned should be the ANSII type + unless ( $types[$t->{DATA_TYPE} + $_sql_type_adjust] ) { + $types[$t->{DATA_TYPE} + $_sql_type_adjust] = $t; + $type_names[$t->{DATA_TYPE} + $_sql_type_adjust] = uc($t->{TYPE_NAME}); + print $type_names[$t->{DATA_TYPE} + $_sql_type_adjust],"\n" if $_debug; + } + } + print STDERR "type = $type ($type_names[$type])\n" if $_debug; + $types[$type] || die "Invalid ANSII data type: $type"; + + my $self = bless($class->SUPER::new($type_names[$type]),$class); + for my $element (keys %fields) { + $self->{_PERMITTED}->{$element} = $fields{$element}; + } + @{$self}{keys %fields} = values %fields; + + $self->ansii_type($self->type($realtype)); + $self->types_l(\@types); + $self->length(shift); + $self->extra('IDENTITY(0,1)') if $self->types_l->[$type]->{AUTO_INCREMENT}; + return $self; +} + +##----------------------------------------------------------------------------- +## OBJECT METHODS +##----------------------------------------------------------------------------- + +=head2 name($name) + +If I<$name> is supplied, sets the name of the ANSII data type. +Returns the name of the data type. + +=head2 type($type) + +If I<$type> is supplied, sets the number of the ANSII data type. +Returns the numeric data type. + +=head2 ansii_type($ansii_type) + +Returns the same type as type(). + +=head2 length($length) + +If I<$length> is supplied, sets the length of the data type. Returns +the length of the data type. + +=head2 extra($extra) + +If I<$extra> is supplied, sets any extra information which applies to +the data type e.g. I. Returns the extra information +which applies to the data type. + +=head1 SEE ALSO + +L + +=head1 AUTHOR + +Paul Sharpe Epaul@miraclefish.comE + +=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 + +1; diff --git a/lib/DbFramework/DataType/Mysql.pm b/lib/DbFramework/DataType/Mysql.pm new file mode 100644 index 0000000..5991f82 --- /dev/null +++ b/lib/DbFramework/DataType/Mysql.pm @@ -0,0 +1,140 @@ +=head1 NAME + +DbFramework::DataType::Mysql - Mysql data type class + +=head1 SYNOPSIS + + use DbFramework::DataType::Mysql; + $dt = new DbFramework::DataType::ANSII($dm,$type,$ansii_type,$length); + $name = $dt->name($name); + $type = $dt->type($type); + $length = $dt->length($length); + $extra = $dt->extra($extra); + $ansii = $dt->ansii_type; + +=head1 DESCRIPTION + +A B object represents a Mysql data type. + +=head1 SUPERCLASSES + +B + +=cut + +package DbFramework::DataType::Mysql; +use strict; +use base qw(DbFramework::DefinitionObject); +use Alias; +use vars qw(); + +## CLASS DATA + +my %fields = ( + LENGTH => undef, + EXTRA => undef, + TYPES_L => undef, + TYPE => undef, + ANSII_TYPE => undef, + ); + +##----------------------------------------------------------------------------- +## CLASS METHODS +##----------------------------------------------------------------------------- + +=head1 CLASS METHODS + +=head2 new($dm,$type,$ansii_type,$length,$extra) + +Create a new B object. I<$dm> is a +B object. I<$type> is a numeric Mysql type +e.g. a type containd in the array reference returned by +$sth->{mysql_type}. This method will die() unless I<$type> is a +member of the set of types supported by B. I<$ansii_type> +is the ANSII type that most closely resembles the native Mysql type. +I<$length> is the length of the data type. I<$extra> is any extra +stuff which applies to the type e.g. 'AUTO_INCREMENT'. + +=cut + +sub new { + my $_debug = 0; + my $proto = shift; + my $class = ref($proto) || $proto; + my($dm,$type,$ansii_type) = (shift,shift,shift); + + my(@types,@type_names); + for my $t ( @{$dm->type_info_l} ) { + $types[$t->{mysql_native_type}] = $t; + $type_names[$t->{mysql_native_type}] = uc($t->{TYPE_NAME}); + print STDERR "$t->{mysql_native_type}, $type_names[$t->{mysql_native_type}]\n" if $_debug + } + $types[$type] || die "Invalid Mysql data type: $type\n"; + print STDERR "\ntype = $type ($type_names[$type])\n\n" if $_debug; + + my $self = bless($class->SUPER::new($type_names[$type]),$class); + for my $element (keys %fields) { + $self->{_PERMITTED}->{$element} = $fields{$element}; + } + @{$self}{keys %fields} = values %fields; + + $self->type($type); + $self->ansii_type($ansii_type); + $self->types_l(\@types); + $self->length(shift); + $self->extra(shift); + + return $self; +} + +##----------------------------------------------------------------------------- +## OBJECT METHODS +##----------------------------------------------------------------------------- + +=head2 name($name) + +If I<$name> is supplied sets the name of the Mysql data type. Returns +the name of the data type. + +=head2 type($type) + +If I<$type> is supplied sets the number of the Mysql data type. +Returns the numeric data type. + +=head2 ansii_type($ansii_type) + +If I<$ansii_type> is supplied sets the number of the ANSII type which +most closely corresponds to the Mysql native type. Returns the ANSII +type which most closely corresponds to the Mysql native type. + +=head2 length($length) + +If I<$length> is supplied sets the length of the data type. Returns +the length of the data type. + +=head2 extra($extra) + +If I<$extra> is supplied sets any extra information which applies to +the data type e.g. I in they case of a Mysql +I data type. Returns the extra information which applies to +the data type. + +=cut + +1; + +=head1 SEE ALSO + +L + +=head1 AUTHOR + +Paul Sharpe Epaul@miraclefish.comE + +=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 diff --git a/lib/DbFramework/DefinitionObject.pm b/lib/DbFramework/DefinitionObject.pm new file mode 100644 index 0000000..6c89075 --- /dev/null +++ b/lib/DbFramework/DefinitionObject.pm @@ -0,0 +1,89 @@ +=head1 NAME + +DbFramework::DefinitionObject - DefinitionObject class + +=head1 SYNOPSIS + + use DbFramework::DefinitionObject; + +=head1 DESCRIPTION + +Abstract class for CDIF Definition Object objects. + +=head1 SUPERCLASSES + +B + +=cut + +package DbFramework::DefinitionObject; +use strict; +use vars qw( $NAME $_DEBUG); +use base qw(DbFramework::Util); +use Alias; +use Carp; + +## CLASS DATA + +my %fields = ( + NAME => undef, + # DefinitionObject 0:1 Contains 0:N Attribute + CONTAINS_L => undef, + CONTAINS_H => undef, + ); + +##----------------------------------------------------------------------------- +## CLASS METHODS +##----------------------------------------------------------------------------- + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = bless { _PERMITTED => \%fields, %fields, }, $class; + $self->name(shift); + $self->_init(shift); + return $self; +} + +##----------------------------------------------------------------------------- +## OBJECT METHODS +##----------------------------------------------------------------------------- + +=head1 OBJECT METHODS + +A definition object contains 0 or more B +objects. These objects can be accessed using the attributes +I and I. See L +for the accessor methods for these attributes. + +=cut + +#------------------------------------------------------------------------------ + +sub _init { + my $self = attr shift; + my @by_name; + for ( @{$self->contains_l(shift)} ) { push(@by_name,($_->name,$_)) } + $self->contains_h(\@by_name); + return $self; +} + +#------------------------------------------------------------------------------ + +1; + +=head1 SEE ALSO + +L + +=head1 AUTHOR + +Paul Sharpe Epaul@miraclefish.comE + +=head1 COPYRIGHT + +Copyright (c) 1998 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 diff --git a/lib/DbFramework/ForeignKey.pm b/lib/DbFramework/ForeignKey.pm new file mode 100644 index 0000000..b97b866 --- /dev/null +++ b/lib/DbFramework/ForeignKey.pm @@ -0,0 +1,171 @@ +=head1 NAME + +DbFramework::ForeignKey - Foreign Key class + +=head1 SYNOPSIS + + use DbFramework::ForeignKey; + $fk = new DbFramework::ForeignKey($name,\@attributes,$primary); + $pk = $fk->references($primary); + $sql = $fk->as_sql; + $html = $fk->as_html_form_field(\%values); + $s = $fk->sql_where; + +=head1 DESCRIPTION + +The B class implements foreign keys for a +table. + +=head1 SUPERCLASSES + +B + +=cut + +package DbFramework::ForeignKey; +use strict; +use base qw(DbFramework::Key); +use Alias; +use vars qw( $NAME $BELONGS_TO @INCORPORATES_L $BGCOLOR $_DEBUG ); + +# CLASS DATA + +my %fields = ( + # ForeignKey 0:N References 1:1 PrimaryKey + REFERENCES => undef, +); + +##----------------------------------------------------------------------------- +## CLASS METHODS +##----------------------------------------------------------------------------- + +=head1 CLASS METHODS + +=head2 new($name,\@attributes,$primary) + +Returns a new B object. + +I<$name> is the name of the foreign key. I<@attributes> is a list of +B objects from a single B +object which make up the key. I<$primary> is the +B object which the foreign key references. + +=cut + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = bless($class->SUPER::new(shift,shift),$class); + for my $element (keys %fields) { + $self->{_PERMITTED}->{$element} = $fields{$element}; + } + @{$self}{keys %fields} = values %fields; + $self->references(shift); + $self->bgcolor('#777777'); + return $self; +} + +##----------------------------------------------------------------------------- +## OBJECT METHODS +##----------------------------------------------------------------------------- + +=head1 OBJECT METHODS + +=head2 references($primary) + +I<$primary> should be a B object. If +supplied it sets the primary key referenced by this foreign key. +Returns the B object referenced by this +foreign key. + +=cut + +#----------------------------------------------------------------------------- + +sub _input_template { + my $self = attr shift; + my $t_name = $BELONGS_TO ? $BELONGS_TO->name : 'UNKNOWN_TABLE'; + return qq{}; +} + +#----------------------------------------------------------------------------- + +sub _output_template { + my $self = attr shift; + # output template consists of attributes from related pk table + my $pk_table = $self->references->belongs_to; + my $name = $pk_table->name; + my $attributes = join(',',$pk_table->attribute_names); + my $out = qq{}; + print STDERR "\$out = $out\n" if $_DEBUG; + $out; +} + +#------------------------------------------------------------------------------ + +=head2 as_html_form_field(\%values) + +Returns an HTML selection box containing values and labels from the +primary key columns in the related table. I<%values> is a hash whose +keys are the attribute names of the foreign key and whose values +indicate the item in the selection box which should be selected by +default. See L. + +=cut + +sub as_html_form_field { + my $self = attr shift; + my %values = $_[0] ? %{$_[0]} : (); + my $pk = $self->references; + my $name = join(',',$self->attribute_names); + # only handles single attribute foreign keys + my $t_name = $BELONGS_TO->name; + my @fk_value; + $fk_value[0] = $values{"${t_name}.${name}"}; + if ( $_DEBUG ) { + print STDERR "\$t_name = $t_name, \$name = $name, \@fk_value = @fk_value\n"; + print STDERR "pk table = ",$pk->belongs_to->name,"\n"; + } + $pk->html_select_field(undef,undef,\@fk_value,$name); +} +#------------------------------------------------------------------------------ + +=head2 sql_where() + +Returns a string containing SQL 'WHERE' condition(s) to join the +foreign key against the primary key of the related table. + +=cut + +sub sql_where { + my $self = shift; + my $fk_table = $self->belongs_to->name; + my @fk_columns = $self->attribute_names; + my $pk_table = $self->references->belongs_to->name; + my @pk_columns = $self->references->attribute_names; + my $where; + for ( my $i = 0; $i <= $#fk_columns; $i++ ) { + $where .= ' AND ' if $where; + $where .= "$fk_table.$fk_columns[$i] = $pk_table.$pk_columns[$i]"; + } + $where; +} + +1; + +=head1 SEE ALSO + +L, L and +L. + +=head1 AUTHOR + +Paul Sharpe Epaul@miraclefish.comE + +=head1 COPYRIGHT + +Copyright (c) 1997,1998,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 diff --git a/lib/DbFramework/Key.pm b/lib/DbFramework/Key.pm new file mode 100644 index 0000000..1f17055 --- /dev/null +++ b/lib/DbFramework/Key.pm @@ -0,0 +1,181 @@ +=head1 NAME + +DbFramework::Key - Key class + +=head1 SYNOPSIS + + use DbFramework::Key; + $k = new DbFramework::Key($name,\@attributes); + $name = $k->name($name); + @a = @{$k->incorporates_l(\@attributes)}; + @names = $k->attribute_names; + $sql = $k->as_sql; + $table = $k->belongs_to($table); + $html = $k->as_html_heading; + +=head1 DESCRIPTION + +The B class implements keys (indexes) for a table. + +=head1 SUPERCLASSES + +B + +=cut + +package DbFramework::Key; +use strict; +use base qw(DbFramework::Util); +use Alias; +use vars qw( $NAME @INCORPORATES_L $BELONGS_TO $BGCOLOR ); + +my %fields = ( + NAME => undef, + # Key 0:N Incorporates 0:N Attribute + INCORPORATES_L => undef, + # Key 1:1 BelongsTo 1:1 Table + BELONGS_TO => undef, + BGCOLOR => '#ffffff', + ); + +##----------------------------------------------------------------------------- +## CLASS METHODS +##----------------------------------------------------------------------------- + +=head1 CLASS METHODS + +=head2 new($name,\@attributes) + +Create a new B object. I<$name> is the name of the +key. I<@attributes> is a list of B objects +from a single B object which make up the key. + +=cut + +sub new { + my $DEBUG = 0; + my $proto = shift; + my $class = ref($proto) || $proto; + print STDERR "=>$class::new(@_)\n" if $DEBUG; + my $self = bless { _PERMITTED => \%fields, %fields, }, $class; + $self->name(shift); + $self->incorporates_l(shift); + print STDERR "<=$class::new()\n" if $DEBUG; + return $self; +} + +##---------------------------------------------------------------------------- +## OBJECT METHODS +##----------------------------------------------------------------------------- + +=head1 OBJECT METHODS + +A key incorporates 0 or more attributes. These attributes can be +accessed using the attribute I. See +L for the accessor methods for this +attribute. + +=head2 name($name) + +If I<$name> is supplied sets the data model name. Returns the data +model name. + +=head2 belongs_to($table) + +I<$table> is a B object. If supplied sets the +table to which this key refers to I<$table>. Returns a +B. + +=head2 bgcolor($bgcolor) + +If I<$color> is supplied sets the background colour for HTML table +cells. Returns the current background colour. + +=head2 attribute_names() + +Returns a list of the names of the attributes which make up the key. + +=cut + +sub attribute_names { + my $self = attr shift; + my @names; + for ( @INCORPORATES_L ) { push(@names,$_->name) } + return @names; +} + +#----------------------------------------------------------------------------- + +=head2 as_sql() + +Returns a string which can be used in an SQL 'CREATE TABLE' statement +to create the key. + +=cut + +sub as_sql { + my $self = attr shift; + return "KEY $NAME (" . join(',',$self->attribute_names) . ")"; +} + +#----------------------------------------------------------------------------- + +sub _input_template { + my $self = attr shift; + my $t_name = $BELONGS_TO ? $BELONGS_TO->name : 'UNKNOWN_TABLE'; + my $in; + my $bgcolor = $self->bgcolor; + for ( @INCORPORATES_L ) { + my $a_name = $_->name; + $in .= qq{}; + } + $in; +} + +#----------------------------------------------------------------------------- + +sub _output_template { + my $self = attr shift; + my $t_name = $BELONGS_TO ? $BELONGS_TO->name : 'UNKNOWN_TABLE'; + my $out; + for ( @INCORPORATES_L ) { + my $a_name = $_->name; + $out .= qq{}; + } + $out; +} + +#----------------------------------------------------------------------------- + +=head2 as_html_heading() + +Returns a string for use as a column heading cell in an HTML table; + +=cut + +sub as_html_heading { + my $self = attr shift; + my $html = ""; +} + +1; + +=head1 SEE ALSO + +L, L and +L. + +=head1 AUTHOR + +Paul Sharpe Epaul@miraclefish.comE + +=head1 COPYRIGHT + +Copyright (c) 1997,1998 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 diff --git a/lib/DbFramework/Persistent.pm b/lib/DbFramework/Persistent.pm new file mode 100644 index 0000000..a38b835 --- /dev/null +++ b/lib/DbFramework/Persistent.pm @@ -0,0 +1,349 @@ +=head1 NAME + +DbFramework::Persistent - Persistent Perl object base class + +=head1 SYNOPSIS + + package Foo; + use base qw(DbFramework::Persistent); + + package main; + $foo = new Foo($table,$dbh,$catalog); + $foo->attributes_h(\%foo}; + $foo->insert; + $foo->attributes_h(\%new_foo); + $foo->update(\%attributes); + $foo->delete; + $foo->init_pk; + @foo = $foo->select($condition,$order); + $hashref = $foo->table_qualified_attribute_hashref; + $code = DbFramework::Persistent::make_class($name); + +=head1 DESCRIPTION + +Base class for persistent objects which use a DBI database for +storage. To create your own persistent object classes subclass +B (see the make_class() class method.) + +=head1 SUPERCLASSES + +B + +=cut + +package DbFramework::Persistent; +use strict; +use vars qw( $TABLE $_DEBUG $VERSION %ATTRIBUTES_H $CATALOG ); +$VERSION = '1.10'; +use base qw(DbFramework::Util); +use Alias; +use DbFramework::Table; + +## CLASS DATA + +my $Debugging = 0; + +my %fields = ( + TABLE => undef, + ATTRIBUTES_H => undef, + CATALOG => undef, +); + +##----------------------------------------------------------------------------- +## CLASS METHODS +##----------------------------------------------------------------------------- + +=head1 CLASS METHODS + +=head2 new($table,$dbh,$catalog) + +Create a new persistent object. I<$table> is a B +object or the name of a database table. I<$dbh> is a B database +handle which refers to a database containing a table associated with +I<$table>. I<$catalog> is a B object. + +=cut + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my($table,$dbh,$catalog) = @_; + my $self = bless { _PERMITTED => \%fields, %fields, }, $class; + $table = new DbFramework::Table($table,undef,undef,$dbh) + unless (ref($table) eq 'DbFramework::Table'); + $self->table($table->init_db_metadata($catalog)); + $self->catalog($catalog); + return $self; +} + +##----------------------------------------------------------------------------- + +=head2 make_class($name) + +Returns some Perl code which can be used with eval() to create a new +persistent object (sub)class called I<$name>. + +=cut + +sub make_class { + my($proto,$name) = @_; + my $class = ref($proto) || $proto; + + my $code = qq{package $name; +use strict; +use base qw(DbFramework::Persistent); +}; +} + +##----------------------------------------------------------------------------- +## OBJECT METHODS +##----------------------------------------------------------------------------- + +=head1 OBJECT METHODS + +Attributes in a persistent object which relate to columns in the +associated table are made available through the attribute +I. See L for the accessor +methods for this attribute. + +=head2 delete() + +Delete this object from the associated table based on the values of +it's primary key attributes. Returns the number of rows deleted if +supplied by the DBI driver. + +=cut + +sub delete { + my $self = attr shift; + return $TABLE->delete($self->_pk_conditions); +} + +#------------------------------------------------------------------------------ + +=head2 insert() + +Insert this object in the associated table. Returns the primary key +of the inserted row if it is a Mysql 'AUTO_INCREMENT' column or -1. + +=cut + +sub insert { + my $self = attr shift; + return $TABLE->insert($self->attributes_h); +} + +#------------------------------------------------------------------------------ + +=head2 update(\%attributes) + +Update this object in the associated table. I<%attributes> is a hash +whose keys contain primary key column names and whose values will be +concatenated with 'ANDs' to form a SQL 'WHERE' clause. The default +values of I<%attributes> is the hash returned by attributes_h(). Pass +the B primary key attributes as an argument in I<%attributes> +when you need to update one or more primary key columns. Returns the +number of rows updated if supplied by the DBI driver. + +=cut + +sub update { + my $self = attr shift; + my %attributes = defined($_[0]) ? %{$_[0]} : %{$self->attributes_h}; + # get pk attributes + my %pk_attributes; + for ( $TABLE->is_identified_by->attribute_names ) { + $pk_attributes{$_} = $attributes{$_}; + } + return $TABLE->update($self->attributes_h,$self->where_and(\%pk_attributes)); +} + +#------------------------------------------------------------------------------ + +=head2 select($conditions,$order) + +Returns a list of objects of the same class as the object which +invokes it. Each object in the list has its attributes initialised +from the values returned by selecting all columns from the associated +table matching I<$conditions> ordered by the list of columns in +I<$order>. + +=cut + +sub select { + my $self = attr shift; + + my @things; + my @columns = $TABLE->attribute_names; + for ( $TABLE->select(\@columns,shift,shift) ) { + print STDERR "\@{\$_} = @{$_}\n" if $_DEBUG; + # pass Table *object* to new to retain any fk relationships + my $thing = $self->new($TABLE,$TABLE->dbh,$CATALOG); + my %attributes; + for ( my $i = 0; $i <= $#columns; $i++ ) { + print STDERR "assigning $columns[$i] = $_->[$i]\n" if $_DEBUG; + $attributes{$columns[$i]} = $_->[$i]; + } + $thing->attributes_h([%attributes]); + push(@things,$thing); + } + return @things; +} + +##----------------------------------------------------------------------------- + +#=head2 validate_required() + +#Returns a list of attribute names which must B be NULL but are +#undefined. If I<@attributes> is undefined, validates all attributes. + +#=cut + +#sub validate_required { +# my $self = attr shift; my $table = $self->table; +# my($attribute,@invalid); + +# my @attributes = @_ ? @_ : sort keys(%STATE); +# foreach $attribute ( @attributes ) { +# my $column = $table->get_column($attribute); +# if ( ! $column->null && ! defined($self->get_attribute($attribute)) ) { +# my $heading = $column->heading; +# if ( $heading ) { +# push(@invalid,$heading) +# } else { +# push(@invalid,$attribute); +# } +# } +# } +# return @invalid; +#} + +##----------------------------------------------------------------------------- + +# return a SQL 'WHERE' clause condition consisting of primary key +# attributes and their corresponding values joined by 'AND' + +sub _pk_conditions { + my $self = attr shift; + my @attributes = @{$TABLE->is_identified_by->incorporates_l}; + my %values = %{$self->attributes_h}; + my %pk_attributes; + for ( @attributes ) { + my $column = $_->name; + $pk_attributes{$column} = $values{$column}; + } + return $self->where_and(\%pk_attributes); +} + +##----------------------------------------------------------------------------- + +# return a SQL 'WHERE' clause condition consisting of attributes named +# after keys in %attributes and their corresponding values joined by +# 'AND' + +sub where_and { + my $self = attr shift; + my %attributes = %{$_[0]}; + my $conditions; + for ( keys %attributes ) { + my($attribute) = $TABLE->get_attributes($_); + $conditions .= ' AND ' if $conditions; + my($name,$type) = ($attribute->name,$attribute->references->type); + $conditions .= "$name = " . $TABLE->dbh->quote($attributes{$name},$type); + } + print STDERR "$conditions\n" if $_DEBUG; + $conditions; +} + +##----------------------------------------------------------------------------- + +#=head2 fill_template($name) + +#Returns the template named I<$name> in the table associated with this +#object filled with the object's attribute values. See +#L. + +#=cut + +sub fill_template { + my($self,$name) = (attr shift,shift); + $TABLE->fill_template($name,$self->attributes_h); +} + +##----------------------------------------------------------------------------- + +=head2 as_html_form() + +Returns an HTML form representing the object, filled with the object's +attribute values. + +=cut + +sub as_html_form { + my $self = attr shift; + my %attributes = %{$self->attributes_h}; + my $html; + for ( @{$self->table->contains_l} ) { + next if $self->table->in_foreign_key($_); + my $name = $_->name; + $html .= "\n"; + } + return $html; +} + +#------------------------------------------------------------------------------ + +=head2 init_pk() + +Initialise an object by setting its attributes based on the current +value of the its primary key attributes. + +=cut + +sub init_pk { + my $self = attr shift; + my @loh = $TABLE->select_loh(undef,$self->_pk_conditions); + $self->attributes_h([ %{$loh[0]} ]); +} + +#------------------------------------------------------------------------------ + +=head2 table_qualified_attribute_hashref() + +Returns a reference to a hash whose keys are the keys of +I<%ATTRIBUTES_H> with a prefix of I<$table>, where I<$table> is the +table associated with the object and whose values are values from +I<%ATTRIBUTES_H>. This is useful for filling a template (see +L.) + +=cut + +sub table_qualified_attribute_hashref { + my $self = attr shift; + my $t_name = $TABLE->name; + my %tq; + for ( keys %ATTRIBUTES_H ) { $tq{"$t_name.$_"} = $ATTRIBUTES_H{$_} } + return \%tq; +} + +1; + +=head1 SEE ALSO + +L, L and +L. + +=head1 AUTHOR + +Paul Sharpe Epaul@miraclefish.comE + +=head1 COPYRIGHT + +Copyright (c) 1997,1998,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 + diff --git a/lib/DbFramework/PrimaryKey.pm b/lib/DbFramework/PrimaryKey.pm new file mode 100644 index 0000000..385af4a --- /dev/null +++ b/lib/DbFramework/PrimaryKey.pm @@ -0,0 +1,341 @@ +=head1 NAME + +DbFramework::PrimaryKey - Primary key class + +=head1 SYNOPSIS + + use DbFramework::PrimaryKey; + $pk = new DbFramework::Primary(\@attributes,$table,\@labels); + $sql = $pk->as_sql; + $html = $pk->html_select_field(\@column_names,$multiple,\@default); + $html = $pk->as_html_heading; + $html = $pk->as_hidden_html(\%values); + $qw = $pk->as_query_string(\%values); + +=head1 DESCRIPTION + +The B class implements primary keys for a +table. + +=head1 SUPERCLASSES + +B + +=cut + +package DbFramework::PrimaryKey; +use strict; +use base qw(DbFramework::Key); +use Alias; +use vars qw( $NAME $BELONGS_TO @INCORPORATES_L $BGCOLOR $_DEBUG ); +use CGI; +use URI::Escape; + +# CLASS DATA + +my %fields = ( + # PrimaryKey 0:N Incorporates 0:N ForeignKey + INCORPORATES => undef, + LABELS_L => undef, +); + +#----------------------------------------------------------------------------- +## CLASS METHODS +#----------------------------------------------------------------------------- + +=head1 CLASS METHODS + +=head2 new(\@attributes,$table,\@labels) + +Create a new B object. I<@attributes> is a +list of B objects from a single +B object which make up the key. I<$table> is the +B to which the primary key belongs. I<@labels> is +a list of column names which should be used as labels when calling +html_select_field(). I<@labels> will default to all columns in +I<$table>. + +=cut + +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; +} + +#----------------------------------------------------------------------------- + +=head1 OBJECT METHODS + +=head2 as_sql() + +Returns a string which can be used in an SQL 'CREATE TABLE' statement +to create the primary key. + +=cut + +sub as_sql { + my $self = attr shift; + return "PRIMARY KEY (" . join(',',$self->attribute_names) . ")"; +} + +##---------------------------------------------------------------------------- + +=head2 html_select_field(\@column_names,$multiple,\@default,$name) + +Returns an HTML form select field where the value consists of the +values from the columns which make up the primary key and the labels +consist of the corresponding values from I<@column_names>. If +I<@column_names> is undefined the labels consist of the values from +all column names. If I<$multiple> is defined the field will allow +multiple selections. I<@default> is a list of values in the select +field which should be selected by default. For fields which allow +only a single selection the first value in I<@default> will be used as +the default. If I<$name> is defined it will be used as the name of +the select field, otherwise the name will consist of the attribute +names of the primary key joined by ',' (comma) and the values will +consist of the corresponding attribute values joined by ',' (comma). + +=cut + +sub html_select_field { + my $self = attr shift; + + my @labels = $_[0] || @{$self->labels_l}; + my $multiple = $_[1]; + # this is hard-coded for single-attribute primary keys + 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); + + # build SELECT statement + 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); + # handle foreign keys with > 1 attribute here! + if ( my($fk) = $BELONGS_TO->in_foreign_key($attribute) ) { + # get label columns from related table + $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 '; + # do this table first so that pk columns are returned at the front + 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); + + # prepare arguments for CGI methods + 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; + + # label fields + 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(''); # we just want this object for its methods + 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) ) { # part of foreign key + print STDERR "Adding $a_name to input template for pk in $t_name\n" if $_DEBUG; + $in .= qq{ +}; + } + } + $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) ) { # part of foreign key + $out .= qq{}; + } + } + $out; +} + +#----------------------------------------------------------------------------- + +=head2 as_html_heading() + +Returns a string for use as a column heading cell in an HTML table; + +=cut + +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); # part of foreign key + } + return '' unless @attributes; + my $html = ""; +} + +#----------------------------------------------------------------------------- + +=head2 as_query_string(\%values) + +Returns a CGI query string consisting of attribute names from the +primary key and their corresponding values from I<%values>. + +=cut + +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); +} + +#----------------------------------------------------------------------------- + +=head2 as_hidden_html(\%values) + +Returns hidden HTML form fields for each primary key attribute. The +field name is B. The field value is the value in +I<%values> whose key is I<$attribute_name>. This method is useful for +tracking the previous value of a primary key when you need to update a +primary key. + +=cut + +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{\n}; + } + $html; +} + +1; + +=head1 SEE ALSO + +L + +=head1 AUTHOR + +Paul Sharpe Epaul@miraclefish.comE + +=head1 COPYRIGHT + +Copyright (c) 1997,1998,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 diff --git a/lib/DbFramework/Relationship.pm b/lib/DbFramework/Relationship.pm new file mode 100644 index 0000000..db034fc --- /dev/null +++ b/lib/DbFramework/Relationship.pm @@ -0,0 +1,211 @@ +package DbFramework::Relationship; +use strict; +use base qw(DbFramework::DefinitionObject DbFramework::DataModelObject); +use DbFramework::ForeignKey; +use Alias; +use vars qw( $NAME $SRC $DEST @COLUMNS ); +use Carp; + +# CLASS DATA + +my %relationships; +my %fields = (SRC => undef, + DEST => undef, + ROLES => [], # DbFramework::Role +); + +##----------------------------------------------------------------------------- +## CLASS METHODS +##----------------------------------------------------------------------------- + +sub new { + my $DEBUG = 0; + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = bless($class->SUPER::new(shift),$class); + for my $element (keys %fields) { + $self->{_PERMITTED}->{$element} = $fields{$element}; + } + @{$self}{keys %fields} = values %fields; + + attr $self; + ($SRC,$DEST) = (shift,shift); + $self->{COLUMNS} = shift || []; + $relationships{$NAME} = [ $SRC,$DEST ]; + + if ( $DEBUG ) { + carp "relationship name: $NAME"; + for ( @{$self->{COLUMNS}} ) { + carp "column: " . $_->name; + } + } + +# if ( ( $_[2] !~ /(1|N)/ && $_[3] !~ /(1|N)/ ) || +# ( $_[6] !~ /(1|N)/ && $_[7] !~ /(1|N)/ ) ) { +# print STDERR $_[0]->name, "($_[2],$_[3]) ", $_[4]->name, "($_[6],$_[7])\n"; +# die "invalid cardinality"; +# } + + return $self; +} + +##----------------------------------------------------------------------------- +## OBJECT METHODS +##----------------------------------------------------------------------------- + +sub create_ddl { + my $self = attr shift; + my $t = shift; + my %values = ('rel_id' => 0, + 'rel_name' => $NAME, + 'rel_srctbl' => $SRC->table->name, + 'rel_srcrole' => $SRC->role, + 'rel_srcmin' => $SRC->min, + 'rel_srcmax' => $SRC->max, + 'rel_desttbl' => $DEST->table->name, + 'rel_destrole' => $DEST->role, + 'rel_destmin' => $DEST->min, + 'rel_destmax' => $DEST->max ); + $t->insert_ddl(\%values); +} + +##----------------------------------------------------------------------------- + +# requires (DbFramework::*::Table,DbFramework::*::Table) +sub many_to_many { + my $class = shift; + my($table1,$table2) = @_; + + for ( values(%relationships) ) { + if ( ($_->[0][0] == $table1 && $_[1][0] == $table2) || + ($_->[0][0] == $table2 && $_[1][0] == $table1) ) { + return 1 if ( $_->[0]->max eq 'N' && $_->[1]->max eq 'N' ); # M:N + return 0; + } + } +} + +##----------------------------------------------------------------------------- + +# See Fundamentals of Database Systems by Elmasri/Navathe, 1989 p 329ff +# for relationship mapping rules +# requires: $DbFramework::*::Schema +sub set_foreign_key { + my $DEBUG = 0; + my $self = attr shift; + my $schema = shift; + + if ( $DEBUG ) { + carp "in DbFramework::Relationship::set_foreign_key"; + carp "(src)", $SRC->table->name, " ", $SRC->role, " ", $SRC->min, ",", $SRC->max, "\n"; + carp "(dest)", $DEST->table->name, " ", $DEST->role, " ", $DEST->min, ",", $DEST->max, "\n"; + } + + my $s; # role player to add relationship attributes to + + if ( ($SRC->max == 1) && ($DEST->max == 1) ) { # 1:1 + # add fk in relation with highest min cardinality + my @roles = sort _by_min ($DEST,$SRC); + my $null = ($roles[0]->min == 0) ? 1 : 0; + $self->_pk_as_fk($null,@roles); + $s = $roles[0]->table; + } + + if ( ($SRC->max == 1) && ($DEST->max eq 'N') || + ($SRC->max eq 'N') && ($DEST->max == 1) ) { # 1:N + # add fk in relation with N cardinality + my @roles = sort _by_max ($DEST,$SRC); + if ( $DEBUG ) { + carp $roles[0]->min, ",", $roles[1]->min; + } + my $null = ($roles[0]->min == 0) ? 1 : 0; + $self->_pk_as_fk($null,@roles); + $s = $roles[0]->table; + } + + if ( ($SRC->max eq'N') && ($DEST->max eq 'N') ) { # M:N + carp "M:N ", $SRC->table->name, ",", $DEST->table->name if ( $DEBUG ); + # an M:N can be re-defined as two 1:N relationships with a new table + # we don't store these conceptual relationships atm + + my $table_name = $SRC->table->name . '_' . $DEST->table->name; + # primary key consists of pk from each table in the M:N (NOT NULL) + my(@src_pk,@dest_pk); + foreach ( @{$SRC->table->primary_key->columns} ) { + push(@src_pk,$_->new($_->name,$_->type,$_->length,0,undef)); + } + foreach ( @{$DEST->table->primary_key->columns} ) { + push(@dest_pk,$_->new($_->name,$_->type,$_->length,0,undef)); + } + my $pk = DbFramework::PrimaryKey->new([@src_pk,@dest_pk]); + my $n_side = $SRC->table->new($table_name,[@src_pk,@dest_pk],$pk,undef); + $n_side->foreign_key(DbFramework::ForeignKey->new($SRC->table,\@src_pk)); + $n_side->foreign_key(DbFramework::ForeignKey->new($DEST->table,\@dest_pk)); + $schema->tables( [ $n_side ] ); + $s = $n_side; + } + + # add attributes of relationship to appropriate table + if ( @COLUMNS ) { + print STDERR "adding columns from relationship $NAME to ",$s->name,"\n" + if $DEBUG; + $s->add_columns(\@COLUMNS); + } +} + +##----------------------------------------------------------------------------- + +# ascending sort by max cardinality +sub _by_max { + my $DEBUG = 0; + if ( $DEBUG ) { + carp "in DbFramework::Relationship::_sort_relationship"; + carp $a->max, ",", $b->max; + } + if ( $b->max == 1 ) { + return 0 if ( $a->max == 1 ); + return -1 if ( $a->max eq 'N' ); + } + if ( $b->max eq 'N' ) { + return 0 if ( $a->max == 'N' ); + return 1 if ( $a->max == 1 ); + } +} + +##----------------------------------------------------------------------------- + +# ascending sort by min cardinality +sub _by_min { + return ( $a->min <=> $b->min ); +} + +##----------------------------------------------------------------------------- + +# add primary key from table as a foreign key in related table +# require: ($DbFramework::RolePlayer,$DbFramework::RolePlayer) +sub _pk_as_fk { + my $DEBUG = 0; + carp "in DbFramework::Relationship::_pk_as_fk" if ( $DEBUG ); + my $self = attr shift; + my($null,$pk_side,$fk_side) = @_; + + if ( $DEBUG ) { + carp "pk side: ", $pk_side->table->name, " fk side: ", $fk_side->table->name; + } + my $column_name_suffix; + if ( $pk_side->table->name eq $fk_side->table->name ) { # recursive + $column_name_suffix = '_' . $NAME; + } + + my @columns; + foreach ( @{$pk_side->table->primary_key->columns} ) { + # be sure to create new columns from the same (sub)class by calling + # new() on an object + push(@columns,$_->new($_->name . $column_name_suffix,$_->type,$_->length,$null,undef)); + } + + $fk_side->table->add_columns(\@columns); + $fk_side->table->foreign_key(DbFramework::ForeignKey->new($pk_side->table,\@columns)); +} + +1; diff --git a/lib/DbFramework/Table.pm b/lib/DbFramework/Table.pm new file mode 100644 index 0000000..1fe8682 --- /dev/null +++ b/lib/DbFramework/Table.pm @@ -0,0 +1,886 @@ +=head1 NAME + +DbFramework::Table - Table class + +=head1 SYNOPSIS + + use DbFramework::Table; + + $t = new DbFramework::Table new($name,\@attributes,$pk,$dbh,$dm); + $t->init_db_metadata($catalog); + $dbh = $t->dbh($dbh); + $pk = $t->is_identified_by($pk); + @fks = @{$t->has_foreign_keys_l}; + %fks = %{$t->has_foreign_keys_h}; + @keys = @{$t->is_accessed_using_l}; + @a = $t->get_attributes(@names); + @n = $t->attribute_names; + $html = $t->as_html_form; + $s = $t->as_string; + $sql = $t->as_sql; + $rows = $t->delete($conditions); + $pk = $t->insert(\%values); + $rows = $t->update(\%values,$conditions); + @lol = $t->select(\@columns,$conditions,$order); + @loh = $t->select_loh(\@columns,$conditions,$order); + @a = $t->non_key_attributes; + $dm = $t->belongs_to; + @fks = $t->in_foreign_key($attribute); + do_something if $t->in_key($attribute); + do_something if $t->in_primary_key($attribute); + do_something if $t->in_any_key($attribute); + +=head1 DESCRIPTION + +A B object represents a database table (entity). + +=head1 SUPERCLASSES + +B + +B + +=cut + +package DbFramework::Table; +use strict; +use vars qw( $NAME @CONTAINS_L $IS_IDENTIFIED_BY $_DEBUG @IS_ACCESSED_USING_L + @HAS_FOREIGN_KEYS_L $DBH %TEMPLATE_H @CGI_PK %FORM_H + $BELONGS_TO ); +use base qw(DbFramework::DefinitionObject DbFramework::DataModelObject); +use DbFramework::PrimaryKey; +use DbFramework::DataType::ANSII; +use DbFramework::DataType::Mysql; +use DbFramework::Attribute; +use DbFramework::Catalog; +use Alias; +use Carp; +use CGI; + +# CLASS DATA + +my %fields = ( + # Entity 1:1 IsIdentifiedBy 1:1 PrimaryKey + IS_IDENTIFIED_BY => undef, + # Entity 1:1 HasForeignKeys 0:N ForeignKey + HAS_FOREIGN_KEYS_L => undef, + HAS_FOREIGN_KEYS_H => undef, + # Table 1:1 IsAccessedUsing 0:N Key + IS_ACCESSED_USING_L => undef, + # Table 1:1 BelongsTo 1:1 DataModel + BELONGS_TO => undef, + DBH => undef, + TEMPLATE_H => undef, + FORM_H => undef, + ); +my $formsdir = '/usr/local/etc/dbframework/forms'; + +##----------------------------------------------------------------------------- +## CLASS METHODS +##----------------------------------------------------------------------------- + +=head1 CLASS METHODS + +=head2 new($name,\@attributes,$pk,$dbh,$dm) + +Create a new B object. I<$dbh> is a DBI database +handle which refers to a database containing a table named I<$name>. +I<@attribues> is a list of B objects. +I<$primary> is a B object. I<@attributes> +and I<$primary> can be omitted if you plan to use the +B object method (see below). I<$dm> is a +B object to which this table belongs. + +=cut + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = bless($class->SUPER::new(shift,shift),$class); + for my $element (keys %fields) { + $self->{_PERMITTED}->{$element} = $fields{$element}; + } + @{$self}{keys %fields} = values %fields; + $self->is_identified_by(shift); + $self->dbh(shift); + $self->belongs_to(shift); + return $self; +} + +##----------------------------------------------------------------------------- +## OBJECT METHODS +##----------------------------------------------------------------------------- + +=head1 OBJECT METHODS + +Foreign keys in a table can be accessed using the +I and I attributes. B +that foreign key objects will not be created automatically by calling +init_db_metadata() on a table object. If you want to automatically +create foreign key objects for your tables you should use call +init_db_metadata() on a B object (see +L). Other keys (indexes) +defined for a table can be accessed using the I +attribute. See L for the accessor +methods for these attributes. + +=head2 is_identified_by($primary) + +I<$primary> is a B object. If supplied sets +the table's primary key to I<$primary>. Returns a +B object with is the table's primary key. + +=head2 dbh($dbh) + +I<$dbh> is a DBI database handle. If supplied sets the database +handle associated with the table. Returns the database handle +associated with the table. + +=head2 belongs_to($dm) + +I<$dm> is a B object. If supplied sets the +data model to which the table belongs. Returns the data model to +which the table belongs. + +=head2 get_attributes(@names) + +Returns a list of B objects. I<@names> is a +list of attribute names to return. If I<@names> is undefined all +attributes associated with the table are returned. + +=cut + +sub get_attributes { + my $self = attr shift; + print STDERR "getting attributes for (",join(',',@_),")\n" if $_DEBUG; + return @_ ? $self->contains_h_byname(@_) # specific attributes + : @{$self->contains_l}; # all attributes +} + +##----------------------------------------------------------------------------- + +=head2 attribute_names() + +Returns a list of attribute names for the table. + +=cut + +sub attribute_names { + my $self = attr shift; + my @names; + for ( @CONTAINS_L ) { push(@names,$_->name) } + @names; +} + +#------------------------------------------------------------------------------ + +=head2 as_html_form() + +Returns HTML form fields for all attributes in the table. + +=cut + +sub as_html_form { + my $self = attr shift; + my $form; + for ( @CONTAINS_L ) { $form .= "\n" } + $form; +} + +#------------------------------------------------------------------------------ + +=head2 in_foreign_key($attribute) + +I<$attribute> is a B object. Returns a list +of B objects which contain I<$attribute>. + + +=cut + +sub in_foreign_key { + my($self,$attribute) = (attr shift,shift); + my $name = $attribute->name; + my @in = (); + print STDERR "foreign keys: @HAS_FOREIGN_KEYS_L\n" if $_DEBUG; + for ( @HAS_FOREIGN_KEYS_L ) { + my @fk_names = $_->attribute_names; + push @in,$_ if grep(/^$name$/,@fk_names); + } + return @in; +} + +#------------------------------------------------------------------------------ + +=head2 in_primary_key($attribute) + +I<$attribute> is a B object. Returns true if +I<$attribute> is a part of the primary key in the table. + +=cut + +sub in_primary_key { + my($self,$attribute) = (attr shift,shift); + my $name = $attribute->name; + my @pk_names = $self->is_identified_by->attribute_names; + print STDERR "Looking for $name in @pk_names\n" if $_DEBUG; + return grep(/^$name$/,@pk_names) ? 1 : 0; +} + +#------------------------------------------------------------------------------ + +=head2 in_key($attribute) + +I<$attribute> is a B object. Returns true if +I<$attribute> is a part of a key (index) in the table. + +=cut + +sub in_key { + my($self,$attribute) = (attr shift,shift); + my @k_names = (); + my $name = $attribute->name; + for ( @IS_ACCESSED_USING_L ) { push(@k_names,$_->attribute_names) } + print STDERR "Looking for $name in @k_names\n" if $_DEBUG; + return grep(/^$name$/,@k_names) ? 1 : 0; +} + +#------------------------------------------------------------------------------ + +=head2 in_any_key($attribute) + +I<$attribute> is a B object. Returns true if +I<$attribute> is a part of a key (index), a primary key or a foreign +key in the table. + +=cut + +sub in_any_key { + my($self,$attribute) = (attr shift,shift); + print STDERR "$self->in_any_key($attribute)\n" if $_DEBUG; + return ($self->in_key($attribute) || + $self->in_primary_key($attribute) || + $self->in_foreign_key($attribute)) ? 1 : 0; +} + +#------------------------------------------------------------------------------ + +=head2 non_key_attributes() + +Returns a list of B objects which are not +members of any key, primary key or foreign key. + +=cut + +sub non_key_attributes { + my $self = attr shift; + my @non_key; + for ( @CONTAINS_L ) { push(@non_key,$_) unless $self->in_any_key($_) } + @non_key; +} + +#------------------------------------------------------------------------------ + +#=head2 html_hidden_pk_list() + +#Returns a 'hidden' HTML form field whose key consists of the primary +#key column names separated by '+' characters and whose value is the +#current list of @CGI_PK + +#=cut + +#sub html_hidden_pk_list { +# my $self = attr shift; +# my $cgi = new CGI(''); +# return $cgi->hidden(join('+',@{$PRIMARY->column_names}),@CGI_PK) . "\n"; +#} + +#------------------------------------------------------------------------------ + +=head2 as_string() + +Returns table details as a string. + +=cut + +sub as_string { + my $self = attr shift; + my $s = "Table: $NAME\n"; + for ( @{$self->contains_l} ) { $s .= $_->as_string } + return $s; +} + +##----------------------------------------------------------------------------- + +=head2 init_db_metadata($catalog) + +Returns an initialised B object for the table +matching this object's name() in the database referenced by dbh(). +I<$catalog> is a B object. + +=cut + +sub init_db_metadata { + my $self = attr shift; + my $catalog = shift; + + my $driver = $self->belongs_to->driver; + my($sql,$sth,$rows,$rv); + # query to get typeinfo + if ( ! defined($self->belongs_to) || $driver eq 'mSQL' ) { + $sql = qq{SELECT * FROM $NAME}; + } else { + # more efficient query for getting typeinfo but not supported by mSQL + $sql = qq{SELECT * FROM $NAME WHERE 1 = 0}; + } + $sth = DbFramework::Util::do_sql($DBH,$sql); + + my %datatypes = ( mysql => 'Mysql' ); # driver-specific datatype classes + my @columns; + for ( my $i = 0; $i < $sth->{NUM_OF_FIELDS}; $i++ ) { + my $class = ( defined($self->belongs_to) && + exists($datatypes{$driver}) + ) + ? $datatypes{$driver} + : 'ANSII'; + my $name = $sth->{NAME}->[$i]; + # if driver-specific class exists, get the driver-specific type + my($type,$ansii_type,$default,$extra); + SWITCH: for ( $class ) { + /Mysql/ && do { + print STDERR "mysql_type = ",join(',',@{$sth->{mysql_type}}),"\n" + if $_DEBUG; + $type = $sth->{mysql_type}->[$i]; + $ansii_type = $sth->{TYPE}->[$i]; + my $sth = DbFramework::Util::do_sql($DBH,"DESCRIBE $NAME $name"); + my $metadata = $sth->fetchrow_hashref; + ($default,$extra) = ($metadata->{Default},uc($metadata->{Extra})); + $sth->finish; + last SWITCH; + }; + /ANSII/ && do { + $ansii_type = $type = $sth->{TYPE}->[$i]; + last SWITCH; + }; + } + $class = "DbFramework::DataType::$class"; + my $precision = $sth->{PRECISION}->[$i]; + + my $d = $class->new($self->belongs_to, + $type, + $ansii_type, + $precision, + $extra, + ); + my $a = new DbFramework::Attribute($sth->{NAME}->[$i], + $default, + $sth->{NULLABLE}->[$i], + $d + ); + push(@columns,$a); + } + $self->_init(\@columns); + + ## add keys + $catalog->set_primary_key($self); + $catalog->set_keys($self); + + #$self->_templates; # set default templates + + return $self; +} + +#------------------------------------------------------------------------------ + +=head2 as_sql() + +Returns a string which can be used to create a table in an SQL 'CREATE +TABLE' statement. + +=cut + +sub as_sql { + my $self = attr shift; + my $sql = "CREATE TABLE $NAME (\n"; + for ( @{$self->contains_l} ) { $sql .= "\t" . $_->as_sql($DBH) . ",\n"; } + $sql .= "\t" . $IS_IDENTIFIED_BY->as_sql; + for ( @IS_ACCESSED_USING_L ) { $sql .= ",\n\t" . $_->as_sql } + for ( @HAS_FOREIGN_KEYS_L ) { $sql .= ",\n\t" . $_->as_sql } + return "$sql\n)"; +} + +#------------------------------------------------------------------------------ + +#=head2 validate_foreign_keys() + +#Ensure that foreign key definitions match related primary key +#definitions. + +#=cut + +sub validate_foreign_keys { + my $self = shift; + attr $self; + + for my $fk ( @HAS_FOREIGN_KEYS_L ) { + my $fk_name = $fk->name; + my @fk_attributes = @{$fk->incorporates_l}; + my @pk_attributes = @{$fk->references->incorporates_l}; + @fk_attributes == @pk_attributes || + die "Number of attributes in foreign key $NAME:$fk_name(",scalar(@fk_attributes),") doesn't match that of related primary key (",scalar(@pk_attributes),")"; + for ( my $i = 0; $i <= $#fk_attributes; $i++) { + my($fk_aname,$pk_aname) = + ($fk_attributes[$i]->name,$pk_attributes[$i]->name); + print STDERR "$fk_aname eq $pk_aname\n" if $_DEBUG; + #$fk_aname eq $pk_aname || + # die "foreign key component $NAME:$fk_aname ne primary key component $pk_aname\n"; + } + } +} + +#------------------------------------------------------------------------------ + +=head2 delete($conditions) + +DELETE rows FROM the table associated with this object WHERE the +conditions in I<$conditions> are met. Returns the number of rows +deleted if supplied by the DBI driver. + +=cut + +sub delete { + my($self,$conditions) = (attr shift,shift); + + my $sql = "DELETE FROM $NAME"; + $sql .= " WHERE $conditions" if $conditions; + print STDERR "$sql\n" if $_DEBUG; + return $DBH->do($sql) || die($DBH->errstr); +} +#------------------------------------------------------------------------------ + +=head2 insert(\%values) + +INSERT INTO the table columns corresponding to the keys of I<%values> +the VALUES corresponding to the values of I<%values>. Returns the +primary key of the inserted row if it is a Mysql 'AUTO_INCREMENT' +column or -1. + +=cut + +sub insert { + my $self = attr shift; + my %values = %{$_[0]}; + + my(@columns,$values); + for ( keys(%values) ) { + next unless defined($values{$_}); + push(@columns,$_); + my $type = $self->get_attributes($_)->references->ansii_type; + print STDERR "value = $values{$_}, type = $type\n" if $_DEBUG; + $values .= $self->_quote($values{$_},$type) . ','; + } + chop $values; + my $columns = '(' . join(',',@columns). ')'; + + my $sql = "INSERT INTO $NAME $columns VALUES ($values)"; + print STDERR "$sql\n" if $_DEBUG; + + my $sth = $DBH->prepare($sql) || die $DBH->errstr; + my $rv = $sth->execute || die "$sql\n" . $sth->errstr . "\n"; + my $rc = $sth->finish; + + if ( $self->belongs_to->driver eq 'mysql' ) { + # id of auto_increment field + return $sth->{mysql_insertid}; + } else { + return -1; + } +} +#------------------------------------------------------------------------------ + +=head2 update(\%values,$conditions) + +UPDATE the table SETting the columns matching the keys in %values to +the values in %values WHERE I<$conditions> are met. Returns the +number of rows updated if supplied by the DBI driver. + +=cut + +sub update { + my $self = attr shift; + my %values = %{$_[0]}; + my $conditions = $_[1]; + + my $values; + for ( keys %values ) { + next unless $values{$_}; + my $dt = $self->get_attributes($_)->references; + my $type = $dt->ansii_type; + print STDERR "\$type = ",$dt->name,"($type)\n" if $_DEBUG; + $values .= "$_ = " . $self->_quote($values{$_},$type) . ','; + } + chop $values; + + my $sql = "UPDATE $NAME SET $values"; + $sql .= " WHERE $conditions" if $conditions; + print STDERR "$sql\n" if $_DEBUG; + return $DBH->do($sql) || die($DBH->errstr); +} + +#------------------------------------------------------------------------------ + +=head2 select(\@columns,$conditions,$order) + +Returns a list of lists of values by SELECTing values FROM I<@columns> +WHERE rows meet I<$conditions> ORDERed BY the list of columns in +I<$order>. Strings in I<@columns> can refer to functions supported by +the database in a SELECT clause e.g. + +C<@columns = q/sin(foo),cos(bar),tan(baz)/;> + +=cut + +sub select { + my $self = attr shift; + my $sth = $self->_do_select(@_); + my @things; + # WARNING! + # Can't use fetchrow_arrayref here as it returns the *same* ref (man DBI) + while ( my @attributes = $sth->fetchrow_array ) { + print "@attributes\n" if $_DEBUG; + push(@things,\@attributes); + } + if ( $_DEBUG ) { + print "@things\n"; + for ( @things ) { print "@{$_}\n" } + } + return @things; +} + +#------------------------------------------------------------------------------ + +=head2 select_loh(\@columns,$conditions,$order) + +Returns a list of hashrefs containing B<(column_name,value)> pairs by +SELECTing values FROM I<@columns> WHERE rows meet I<$conditions> +ORDERed BY the list of columns in I<$order>. Strings in I<@columns> +can refer to functions supported by the database in a SELECT clause +e.g. + +C<@columns = q/sin(foo),cos(bar),tan(baz)/;> + +The keys in the hashrefs will match the name of the function applied +to the column i.e. + +C<@loh = $foo-Eselect(\@columns);> + +C{sin(foo)}\n";> + +=cut + +sub select_loh { + my $self = attr shift; + my $sth = $self->_do_select(@_); + my @things; + while ( $_ = $sth->fetchrow_hashref ) { + # fetchrow_hashref may not return a fresh hashref in future (man DBI) + my %hash = %{$_}; + push(@things,\%hash); + } + return @things; +} + +#------------------------------------------------------------------------------ + +# select(\@columns,$conditions,$order) +# returns a statement handle for a SELECT + +sub _do_select { + my $self = attr shift; + my($columns_ref,$conditions,$order,$function_ref) = @_; + my @columns = defined($columns_ref) ? @$columns_ref : $self->attribute_names; + my $sql = "SELECT " . join(',',@columns) . " FROM $NAME"; + $sql .= " WHERE $conditions" if $conditions; + $sql .= " ORDER BY $order" if $order; + print STDERR "$sql\n" if $_DEBUG; + my $sth = $DBH->prepare($sql) || die($DBH->errstr); + my $rv = $sth->execute || die "$sql\n" . $sth->errstr . "\n"; + return $sth; +} + +#------------------------------------------------------------------------------ + +#=head2 fill_template($name,\%values) + +#Return the filled HTML template named I<$name>. A template can +#contain special placeholders representing columns in a database table. +#Placeholders in I<$template> can take the following forms: + +#=over 4 + +#=item BDbField table.column [value=value] [type=type]E> + +#If the table's name() matches I
+ + + + + + + +
+

db: $db

+
+

Tables

+
    +EOF + +for ( @{$dm->collects_table_l} ) { + my $table = $_->name; + print "
  • $table\n"; +} + +print < +
+ 		+ + + + + + \n"; + print $template->fill($values_hashref); + for ( 'select','insert' ) { + print "\n"; + } +print < + +EOF +} +print < + + +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 "\n"; + for ( qw(host driver db db_dsn c_dsn table form) ) { + print "\n"; + } + print $thing->table->is_identified_by->as_hidden_html($values_hashref); + print "",$template->fill($thing->table_qualified_attribute_hashref),"\n"; + print "\n"; + print "\n"; + print "\n"; + } + } else { + print "\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 < + + +
+

$table

+
+EOF + +if ( $form eq 'input' ) { + my $self_url = $cgi->self_url; + print "
\n"; + for ( qw(host driver db db_dsn c_dsn table form) ) { + print "\n"; + } + my $values_hashref = $thing->table_qualified_attribute_hashref; + print $thing->table->as_html_heading,"\n
$_
' : '',"update",($action eq 'delete') ? ' checked' : '',"delete
No rows matched your query
+ + +EOF diff --git a/lib/DbFramework/Attribute.pm b/lib/DbFramework/Attribute.pm new file mode 100644 index 0000000..dabd552 --- /dev/null +++ b/lib/DbFramework/Attribute.pm @@ -0,0 +1,241 @@ +=head1 NAME + +DbFramework::Attribute - Attribute class + +=head1 SYNOPSIS + + use DbFramework::Attribute; + my $a = new DbFramework::Attribute($name,$default_value,$is_optional,$data_type); + $name = $a->name($name); + $value = $a->default_value($value); + $opt = $a->is_optional($boolean); + $type = $a->references($data_type); + $bgc = $a->bgcolor($bgcolor); + $sql = $a->as_sql; + $s = $a->as_string; + $html = $a->as_html_form_field($value,$type); + $html = $a->as_html_heading($bgcolor); + +=head1 DESCRIPTION + +A B object represents an attribute (column) in +a table (entity). + +=head1 SUPERCLASSES + +B + +=cut + +package DbFramework::Attribute; +use strict; +use base qw(DbFramework::Util); +use vars qw($_DEBUG $NAME $DEFAULT_VALUE $IS_OPTIONAL $REFERENCES $BGCOLOR); +use Alias; + +## CLASS DATA + +my %fields = ( + NAME => undef, + DEFAULT_VALUE => undef, + IS_OPTIONAL => undef, + # Attribute 0:N References 0:1 DefinitionObject (DataType) + REFERENCES => undef, + BGCOLOR => '#007777', +); + +##----------------------------------------------------------------------------- +## CLASS METHODS +##----------------------------------------------------------------------------- + +=head1 CLASS METHODS + +=head2 new($name,$default_value,$is_optional,$data_type) + +Create a new B object. I<$name> is the name +of the attribute. I<$default_value> is the default value for the +attribute. I<$is_optional> should be set to true if the attribute is +optional or false. I<$data_type> is a B +object. + +=cut + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = bless { _PERMITTED => \%fields, %fields, }, $class; + $self->name(shift); + $self->default_value(shift); + $self->is_optional(shift); + $self->references(shift); + return $self; +} + +##----------------------------------------------------------------------------- +## OBJECT METHODS +##----------------------------------------------------------------------------- + +=head2 name($name) + +If I<$name> is supplied sets the attribute name. Returns the +attribute name. + +=head2 default_value($value) + +If I<$value> is supplied sets the default value for the attribute. +I<$value> should be compatible with the the data type set by +references(). Returns the default value for the attribute. + +=head2 is_optional($boolean) + +If I<$boolean> is supplied sets the optionality of the attribute +(i.e. whether it can contain NULLs.) I<$boolean> should evaluate to +true or false. Returns the optionality of the attribute. + +=head2 references($data_type) + +If I<$data_type> is supplied sets the data type of the attribute. +I<$data_type> is an ANSII data type object +i.e. B or a driver-specific object +e.g. B. Returns the data type object. + +=head2 bgcolor($bgcolor) + +If I<$color> is supplied sets the background colour for HTML table +headings returned by as_html_heading(). Returns the current +background colour. + +=head2 as_sql($dbh) + +Returns a string which can be used to create a column in an SQL +'CREATE TABLE' statement. I<$dbh> is a B handle. + +=cut + +sub as_sql { + my($self,$dbh) = (attr shift,shift); + my $sql = "$NAME "; + $sql .= $REFERENCES->name; + $sql .= '(' . $REFERENCES->length . ')' if $REFERENCES->length; + $sql .= " NOT NULL" unless $IS_OPTIONAL; + $sql .= " DEFAULT " . $dbh->quote($DEFAULT_VALUE) if $DEFAULT_VALUE; + $sql .= ' ' . $REFERENCES->extra if $REFERENCES->extra; + return $sql; +} + +##----------------------------------------------------------------------------- + +=head2 as_html_form_field($value,$type) + +Returns an HTML form field representation of the attribute. The HTML +field type produced depends on the name of object returned by +data_type(). This can be overidden by setting I<$type>. I<$value> is +the default value to be entered in the generated field. + +=cut + +sub as_html_form_field { + my $self = attr shift; + my $value = defined($_[0]) ? $_[0] : ''; + my $type = defined($_[1]) ? uc($_[1]) : $REFERENCES->name; + my $length = $REFERENCES->length || 10; + my $html; + +SWITCH: { + $type =~ /(INT|DATE)/ && + do { + $html = qq{}; + last SWITCH; + }; + $type =~ /CHAR$/ && + do { + $html = qq{}; + last SWITCH; + }; + $type eq 'TEXT' && + do { + $value =~ s/'//g; # remove quotes + $html = qq{}; + last SWITCH; + }; + $type eq 'BOOLEAN' && + do { + my $y = qq{Yes \n$n>\n} : qq{$y>\n$n CHECKED>\n}; + last SWITCH; + }; + # default + my $size = ($length < 30) ? $length : 30; + $html = qq{}; + } + return $html; +} + +##----------------------------------------------------------------------------- + +=head2 as_string() + +Return attribute details as a text string. + +=cut + +sub as_string { + my $self = attr shift; + my $s = "$NAME(" . $REFERENCES->name; + $s .= ' ('. $REFERENCES->length . ')' if $REFERENCES->length; + $s .= " '$DEFAULT_VALUE'" if $DEFAULT_VALUE; + $s .= ' NOT NULL' unless $IS_OPTIONAL; + $s .= ' ' . $REFERENCES->extra if $REFERENCES->extra; + #print " $FUNCTION" if $FUNCTION; + return "$s)\n"; +} + +##---------------------------------------------------------------------------- + +sub _input_template { + my($self,$t_name) = (attr shift,shift); + return qq{		$text"; + for ( @INCORPORATES_L ) { $html .= $_->name . ',' } + chop($html); + "$html
$name" + . $_->as_html_form_field($attributes{$name}) + . "
"; + for ( @attributes ) { + my $a_name = $_->name; + my $extra = $_->references->extra + ? ' ('.$_->references->extra.')' + : ''; + $html .= "$a_name$extra,"; + } + chop($html); + "$html
" . $_->as_html_form_field . "
in a B placeholder, +#the placeholder will be replaced with the corresponding HTML form +#field for the column named I with arguments I and +#I (see L). If +#I<%values> is supplied placeholders will have the values in I<%values> +#added where a key in I<%values> matches a column name in the table. + +#=item BDbFKey table.fk_name[,column...]E> + +#If the table's name() matches I
in a B placeholder, the +#placeholder will be replaced with the a selection box containing +#values and labels from the primary key columns in the related table. +#Primary key attribute values in I<%values> will be used to select the +#default item in the selection box. + +#=item BDbValue table.column[,column...]E> + +#If the table's name() matches I
in a B placeholder, +#the placeholder will be replaced with the values in I<%values> where a +#key in I<%values> matches a column name in the table. + +#=item BDbJoin table.column.template[.order][.column_name[;column_name...]]E> + +#A B placeholder will cause a join to be performed between this +#table and the table specified in I
over the column I +#where the value equals I<%values{column}> orderd by I. Values +#will be selected from columns specified with I. +#I may refer to functions supported by the database in a +#B
will be selected. The placeholder will +#be replaced by the concatenation of I