#!/usr/bin/perl require 5.002; my $REVISION = '$Header: /sources/public/perl/modules/W3C/Database/bin/object_maker,v 1.30 2004/09/30 10:33:51 eric Exp $'; #BEGIN {unshift@INC,('../../..');} use strict; use Data::Dumper; use W3C::Database::ObjectDB; use W3C::Util::Properties; package W3C::Database::object_maker; use W3C::Util::Exception; use vars qw($Header $Footer); $Header = < Table Layout

Table Layout

EO_HEADER ; $Footer = < EO_FOOTER ; eval { my $om = new W3C::Database::object_maker(\@ARGV); $om->main; }; if ($@) {if (my $ex = &catch('W3C::Util::Exception')) { print STDERR $ex->toString(); exit(1); } else { die $@; }} use W3C::Database::ObjectDB qw($FieldType_INT $FieldType_TINYINT $FieldType_FLOAT $FieldType_ENUM $FieldType_CHAR $FieldType_VARCHAR $FieldType_TEXT $FieldType_BLOB $FieldType_DATE $FieldType_TIME $FieldType_DATETIME $FieldType_TIMESTAMP); use vars qw(@TODO); @TODO = ('improve primary key map parsing (and fix \'undef\' keyword', 'run from script file', 'figure out why the hell int is -type => \'0\'', 'make mode or app to generate tables from object dump (go backwords)'); sub new { my ($proto, $argv) = @_; my $class = ref $proto || $proto; my $self = {}; bless ($self, $class); # set default parameters $self->{TABLE_VARIABLE} = '$table'; $self->{OUT_FILE} = *STDOUT; $self->{UI} = new Shim; # parse user-supplied parameters my (@errors); if ($self->parseArgs($argv, \@errors)) { &throw(new W3C::Util::Exception(-message => join("\n", @errors)."\n".&usage())); } ((print STDOUT &usage) && return) if (exists $self->{ARGS}{'help'}); if ($self->{ARGS}{'-useTk'}) { require W3C::Database::TableVisualizer; $self->{UI} = new W3C::Database::TableVisualizer; bless ($self, 'W3C::Database::Tk_object_maker'); } return $self; } sub main { my ($self) = @_; $self->makeConnection; $self->walkTables; $self->processTableList; $self->referentFixups; $self->dumpOutput; if ($self->{PY_OUT_FILE}) { $self->dumpPythonOutput($self->{PY_OUT_FILE}); } $self->quit(0); } # make DB connection sub makeConnection { my ($self) = @_; $self->{DB_NAME} = $self->{ARGS}{'-database'}; $self->{ARGS}{'-properties'} = new W3C::Util::Properties($0.'.props') if (!defined $self->{ARGS}{'-properties'}); $self->{DB} = new W3C::Database::ObjectDB($self->{ARGS}{'-properties'}); } # walk the list of tables and store in %tableList sub walkTables { my ($self) = @_; my (@rows, $errorCount, @tableList); $self->{DB}->executeQuery(\@rows, 'SHOW TABLES FROM '.$self->{DB_NAME}); $self->{UI}->selectTable(\@rows); foreach my $row (@rows) { if ($self->{ARGS}{'-tableCount'}) { if (exists $self->{ARGS}{'-tables'}{$row}) { push (@tableList, $row); delete $self->{ARGS}{'-tables'}{$row}; } else { push (@{$self->{EXCLUDED_TABLES}}, $row); # print STDERR 'Skipping table "'.$row.'" in "'.$self->{DB_NAME}."\".\n"; } } else { push (@tableList, $row); } } # default table order to the order in SHOW TABLES $self->{INCLUDED_TABLES} = defined $self->{ARGS}{-tableOrder} ? $self->{ARGS}{-tableOrder} : [@tableList]; # check for unknown tables specified by the user foreach my $table (keys %{$self->{ARGS}{'-tables'}}) { print STDERR 'Can\'t find table "'.$table.'" in "'.$self->{DB_NAME}."\".\n"; $errorCount++; } ($self->quit(1)) if ($errorCount); } # process each table in @tableList sub processTableList { my ($self) = @_; foreach my $table (@{$self->{INCLUDED_TABLES}}) { print STDERR $table."\n" if ($self->{ARGS}{'-verbose'}); $self->{ENTRIES}{$table} = [$self->getTableMetaData($table)]; } } # run referenceFrom fixups - latent resolution to find out the primary key for $targetTable; sub referentFixups { my ($self) = @_; foreach my $targetTable (keys %{$self->{REFS_FROM}}) { my $targetField = $self->{TABLE_REFS}{$targetTable}{-primaryKey}; push (@{$self->{TABLE_REFS}{$targetTable}{-fields}{$targetField}{-referents}}, @{$self->{REFS_FROM}{$targetTable}}); foreach my $referrer (@{$self->{REFS_FROM}{$targetTable}}) { my ($referrerTable, $referrerField) = $referrer =~ m/^([^\.]+)\.(.*)$/; my $className = $self->{INTERFACE_VARIABLE}.'::'.$targetTable; my $funcDef = '{$_[0]->loadExternalKey(\''.$targetTable.'\',\''.$referrerTable.'\',\''.$referrerField.'\');}'; $self->{ENTRIES}{$targetTable}[1] .='sub '.$className.'::_find'.$referrerTable.'_by_'.$referrerField.' '.$funcDef."\n"; } } } # dump the outputs (currently a table and optional html file) sub dumpOutput { my ($self) = @_; if ($self->{HTML_FILE}) { $self->printHtml($Header); $self->printHtml("

$table

\n"); $self->printHtml("

\n"); } for (my $i = 0; $i < @{$self->{INCLUDED_TABLES}}; $i++) { my $table = $self->{INCLUDED_TABLES}[$i]; my $entry = $self->{ENTRIES}{$table}; $self->dumpTable($i, @$entry); } $self->printOut($self->pruneDumperOutput($self->{LAST_DEFS})); if ($self->{HTML_FILE}) { $self->printHtml("\n"); $self->printHtml($Footer); } } sub quit { my ($self, $errorCode) = @_; $self->{DB}->disconnect; exit $errorCode; } sub usage { my $ret = ''; $ret .= "Usage: $0 [-p properties] database [table,...]\n"; return $ret; } sub parseArgs { my ($self, $argv, $errs) = @_; my $errorCount = 0; NEXTARG: for (my $i = 0; $i < @$argv; $i++) { my $arg = $argv->[$i]; if ($arg =~ m/\A @(.*) \Z/x) { my $scriptFile; if ($1) { $scriptFile = $1; } elsif ($i < @$argv - 1) { $scriptFile = $argv->[++$i]; } else { push (@{$self->{ERRORS}}, 'missing parm for \@ directive'); } if (!open (SCRIPT_FILE, '<'.$scriptFile)) { &throw(new W3C::Util::FileNotFoundException(-filename => $scriptFile)); } local $/ = undef; my $script = ; close(SCRIPT_FILE); my ($line, @parms); while (pos $script < length $script && $script =~ m/\G ([^\s\\\'\"\#]*) ([\s\\\'\"\#])? /gcxs) { my ($word, $delim) = ($1, $2); $line .= $word; if ($delim =~ m/\s/) { push (@parms, $line) if ($line && $line ne '$*'); $line = undef; if ($script =~ m/\G \s* /gcxs) {} } elsif ($delim eq '\\') { if ($script =~ m/\G (.) /gcxs) {$line .= $1 if ($1 ne "\r" && $1 ne "\n");} } elsif ($delim eq '\'') { while ($script =~ m/\G ([^\\\']*) ([\\\'\z]) /gcxs) { $line .= $1; if ($2 eq '\\') { if ($script =~ m/\G (.) /gcxs) {$line .= $1 if ($1 ne "\r" && $1 ne "\n");} } elsif ($2 eq '\'') { last; } } } elsif ($delim eq '"') { while ($script =~ m/\G ([^\\\"]*) ([\\\"\z]) /gcxs) { $line .= $1; if ($2 eq '\\') { if ($script =~ m/\G (.) /gcxs) {$line .= $1 if ($1 ne "\r" && $1 ne "\n");} } elsif ($2 eq '"') { last; } } } elsif ($delim eq '#') { # eat rest of line after comment $script =~ m/\G ([^\r\n]*) $ /gcxm; } else { push (@parms, $line) if (defined $line && $line ne '$*'); $line = undef; # \z so at end of input - hmm - can't count on that. bummer } } push (@parms, $line) if ($line); my $zero = shift (@parms); splice (@$argv, $i, 1, @parms); $i--; } elsif ($arg =~ m/\A -py(.*) \Z/x) { local *OUT; if ($1) { if (!open(OUT, '>'.$1)) { &throw(new W3C::Util::FileCreationException({-filename => $1})); } $self->{PY_OUT_FILE} = *OUT; } elsif ($i < @$argv - 1) { if (!open(OUT, '>'.$argv->[++$i])) { &throw(new W3C::Util::FileCreationException({-filename => $argv->[$i]})); } $self->{PY_OUT_FILE} = *OUT; } else { $errorCount++; } } elsif ($arg =~ m/\A -p(.*) \Z/x) { if ($1) { $self->{ARGS}{'-properties'} = new W3C::Util::Properties($1); } elsif ($i < @$argv - 1) { $self->{ARGS}{'-properties'} = new W3C::Util::Properties($argv->[++$i]); } else { $errorCount++; } } elsif ($arg =~ m/\A -q(.*) \Z/x) { if ($1) { $self->{ARGS}{'-queryHost'} = $1; } elsif ($i < @$argv - 1) { $self->{ARGS}{'-queryHost'} = $argv->[++$i]; } else { $errorCount++; } } elsif ($arg =~ m/\A -u(.*) \Z/x) { if ($1) { $self->{ARGS}{'-user'} = $1; } elsif ($i < @$argv - 1) { $self->{ARGS}{'-user'} = $argv->[++$i]; } else { $errorCount++; } } elsif ($arg =~ m/\A -p(.*) \Z/x) { if ($1) { $self->{ARGS}{'-password'} = $1; } elsif ($i < @$argv - 1) { $self->{ARGS}{'-password'} = $argv->[++$i]; } else { $errorCount++; } } elsif ($arg =~ m/\A -s(.*) \Z/x) { if ($1) { $self->{SUPERCLASS} = $1; } elsif ($i < @$argv - 1) { $self->{SUPERCLASS} = $argv->[++$i]; } else { $errorCount++; } $self->{SUPERCLASS} = [split (/\s*,\s*/, $self->{SUPERCLASS})]; } elsif ($arg =~ m/\A -n(.*) \Z/x) { if ($1) { $self->{TABLE_VARIABLE} = $1; } elsif ($i < @$argv - 1) { $self->{TABLE_VARIABLE} = $argv->[++$i]; } else { $errorCount++; } } elsif ($arg =~ m/\A -h(.*) \Z/x) { if ($1) { if (!open(HTML, '>'.$1)) { &throw(new W3C::Util::FileCreationException({-filename => $1})); } $self->{HTML_FILE} = *HTML; } elsif ($i < @$argv - 1) { if (!open(HTML, '>'.$argv->[++$i])) { &throw(new W3C::Util::FileCreationException({-filename => $argv->[$i]})); } $self->{HTML_FILE} = *HTML; } else { $errorCount++; } } elsif ($arg =~ m/\A -o(.*) \Z/x) { local *OUT; if ($1) { if (!open(OUT, '>'.$1)) { &throw(new W3C::Util::FileCreationException({-filename => $1})); } $self->{OUT_FILE} = *OUT; } elsif ($i < @$argv - 1) { if (!open(OUT, '>'.$argv->[++$i])) { &throw(new W3C::Util::FileCreationException({-filename => $argv->[$i]})); } $self->{OUT_FILE} = *OUT; } else { $errorCount++; } } elsif ($arg =~ m/\A ( -{0,2}help | -{0,1}\? ) \Z/x) { # help -help --help ? -? $self->{ARGS}{'-help'} = 1; } elsif ($arg =~ m/\A ( -{1,2}verbose | -{1,2}v ) \Z/x) { # -verbose --verbose -v --v $self->{ARGS}{'-verbose'} = 1; } elsif ($arg =~ m/\A -Tk \Z/ix) { # -Tk -tk $self->{ARGS}{'-useTk'} = 1; } elsif ($arg =~ m/\A -m(.*) \Z/x) { if ($1) { $self->{EXTERNAL_KEYS} = $self->parseMaps($1); } elsif ($i < @$argv - 1) { $self->{EXTERNAL_KEYS} = $self->parseMaps($argv->[++$i]); } else { $errorCount++; } } elsif ($arg =~ m/\A -c(.*) \Z/x) { if ($1) { $self->{OVERRIDES} = $self->parseOverrides($1); } elsif ($i < @$argv - 1) { $self->{OVERRIDES} = $self->parseOverrides($argv->[++$i]); } else { $errorCount++; } } elsif ($self->{ARGS}{'-database'}) { push (@{$self->{ARGS}{-tableOrder}}, $arg); $self->{ARGS}{'-tables'}{$arg} = undef; $self->{ARGS}{'-tableCount'}++; } else { $self->{ARGS}{'-database'} = $arg; # push(@$errs, 'unknown arg: "'.$arg.'"'); } } # check required parameters if (!defined $self->{ARGS}{'-properties'}) { $self->{ARGS}{'-properties'} = new W3C::Util::Properties({'queryHost' => $self->{ARGS}{'-queryHost'}, 'database' => $self->{ARGS}{'-database'}, 'user' => $self->{ARGS}{'-user'}, 'password' => $self->{ARGS}{'-password'}}); } $self->{INTERFACE_VARIABLE} = $self->{TABLE_VARIABLE}; $self->{ORDER_VARIABLE} = $self->{TABLE_VARIABLE}.'::_TableOrder'; $self->{TABLE_VARIABLE} .= '::_AllTables'; $self->{SUPERCLASS} = [qw(W3C::Database::ObjectBase)] if (!defined $self->{SUPERCLASS}); @{$self->{LAST_DEFS}} = (); $self->{ORDER} = $self->assignAndQueue('ARRAY', $self->{ORDER_VARIABLE}, "()", $self->{LAST_DEFS}); if (!$self->{ARGS}{'-database'}) { push(@$errs, 'no database specified'); $errorCount++; } return $errorCount; } sub parseMaps { my ($self, $text) = @_; my (%ret, @stack); my %closers = ('{' => '}', '[' => ']', '(' => ')', '<' => '>'); while ($text =~ m/\G([$\{\[<\s])/gcxsi) { if ($1 !~ /^\s$/) { push (@stack, $closers{$1}); } } while ($text =~ m/\G([,\s]*)([\w\.\-]+)/gcxsi) { my $lvalue = $2; if ($text =~ m/\G(\s*=>\s*)([\w\.\-]+)/gcxsi) { my $rvalue = $2 eq 'undef' ? undef : $2; $ret{$lvalue} = $rvalue; } else { } } # %ret = (@array); # cheat: (1,2,3,4) goes to (1=>2, 3=>4) while ($text =~ m/\G([$\}\]>\s])/gcxsi) { if ($1 !~ /^\s$/) { my $match = pop (@stack); if ($match ne $1) { warn ("expected \"$match\", got \"$1\"\n"); } } } if (@stack) { warn ("no close for \"".join ('', @stack)."\"\n"); } my $unparsedLength = length($text) - pos($text); if ($unparsedLength) { my $unparsed; if ($unparsedLength <= 20) { $unparsed = substr($text, pos $text, $unparsedLength); } else { $unparsed = substr($text, pos $text, 20).'...'; } warn ("unparsed $unparsedLength bytes of map parameter: \"$unparsed\"\n"); } return \%ret; } sub parseOverrides { my ($self, $text) = @_; my (%ret, @stack); my %closers = ('{' => '}', '[' => ']', '(' => ')', '<' => '>'); while ($text =~ m/\G([$\{\[<\s])/gcxsi) { if ($1 !~ /^\s$/) { push (@stack, $closers{$1}); } } while ($text =~ m/\G([,\s]*)([\w\.\-]+)/gcxsi) { my $lvalue = $2; if ($text =~ m/\G(\s*=>\s*)([\(\{\[<])\s*([\w\.\-]+)(\s*=>\s*)([\(\{\[<])/gcxsi) { my $starter = $closers{$2}; my $key = $3; my $starterb = $closers{$5}; my %classes; while ($text =~ m/\G([,\s]*)([\w\.\-]+)/gcxsi) { my $enum = $2; if ($text =~ m/\G(\s*=>\s*)([\w\.\-]+)/gcxsi) { my $class = $2; $classes{$enum} = $class; } else { } } if ($text =~ m/\G([,\s]*)\Q$starterb\E\s*/gcxsi) { } else { warn ("no close for \"$starterb\"\n"); } if ($text =~ m/\G([,\s]*)\Q$starter\E\s*/gcxsi) { } else { warn ("no close for \"$starter\"\n"); } $ret{$lvalue}{$key} = \%classes; } else { } } # %ret = (@array); # cheat: (1,2,3,4) goes to (1=>2, 3=>4) while ($text =~ m/\G([$\}\]>\s])/gcxsi) { if ($1 !~ /^\s$/) { my $match = pop (@stack); if ($match ne $1) { warn ("expected \"$match\", got \"$1\"\n"); } } } if (@stack) { warn ("no close for \"".join ('', @stack)."\"\n"); } my $unparsedLength = length($text) - pos($text); if ($unparsedLength) { my $unparsed; if ($unparsedLength <= 20) { $unparsed = substr($text, pos $text, $unparsedLength); } else { $unparsed = substr($text, pos $text, 20).'...'; } warn ("unparsed $unparsedLength bytes of map parameter: \"$unparsed\"\n"); } return \%ret; } sub getTableMetaData ($$$) { my ($self, $table) = @_; # convenience variables my $className = $self->{INTERFACE_VARIABLE}.'::'.$table; # class for this table my $thisTableName = $className.'::_TableDesc'; # variable name for this table description my $interface = ''; # variable to store function interface my (@preDefs, @postDefs); # queue of pairs of [variable, name] to be Dumped later # create a description for this table my $tableDesc = $self->assignAndQueue('HASH', $thisTableName, '()', \@postDefs); my $isas = $self->assignAndQueue('ARRAY', $className.'::ISA', '()', \@preDefs); push (@$isas, @{$self->{SUPERCLASS}}); # add pointer from global table to this table $self->{TABLE_REFS}{$table} = $self->assignAndQueue('', $self->{TABLE_VARIABLE}.'{\''.$table.'\'}', "\\%".$thisTableName, \@postDefs); push (@{$self->{ORDER}}, $table); # add general table information to data structure $tableDesc->{-class} = $className; $tableDesc->{-table} = $table; $interface .= 'sub '.$className.'::getTableDesc {return \%'.$thisTableName.";}\n"; # iterate through each column my @rows; $self->{DB}->executeArrayQuery(\@rows, 'SHOW COLUMNS FROM '.$self->{DB_NAME}.'.'.$table); foreach my $row (@rows) { my ($Field, $Type, $Null, $Key, $Default, $Extra) = (@$row); my $fieldDesc = $tableDesc->{-fields}{$Field} = {}; # convience variable for this field description # $Type is of form "type(parms) modifiers" eg "char(20) binary" my ($type, @modifiers) = split(/ /, $Type); my $parms; ($type, $parms) = split(/[]/, $type); # add general field information to data structure if ($Key eq 'PRI') { if (my $pk = $tableDesc->{-primaryKey}) { if (ref $pk eq 'ARRAY') { push (@{$tableDesc->{-primaryKey}}, $Field); } else { $tableDesc->{-primaryKey} = [$tableDesc->{-primaryKey}, $Field]; } } else { $tableDesc->{-primaryKey} = $Field; } } $fieldDesc->{-null} = 1 if ($Null eq 'YES'); $fieldDesc->{-default} = $Default if (defined $Default); push (@{$tableDesc->{-fieldOrder}}, $Field); # build data structure according to the field type if ($type eq 'int') { $fieldDesc->{-type} = $FieldType_INT; $fieldDesc->{-size} = $parms; # integers may be an external key if ($Key ne 'PRI' || exists $self->{EXTERNAL_KEYS}{$table.'.'.$Field}) { my ($targetTable, $targetField); if ($self->{EXTERNAL_KEYS}) { # map according to the defined external keys if (exists $self->{EXTERNAL_KEYS}{$table.'.'.$Field}) { # apply table-specific foreign key mapping my $map = $self->{EXTERNAL_KEYS}{$table.'.'.$Field}; $targetTable = $map if (defined $map); # print STDERR 'ignoring "'.$table.'.'.$Field."\"\n" if (!defined $map); } elsif (exists $self->{EXTERNAL_KEYS}{$Field}) { # apply general key foreign key mapping my $map = $self->{EXTERNAL_KEYS}{$Field}; $targetTable = $map if (defined $map); # print STDERR 'ignoring "'.$table.'.'.$Field."\"\n" if (!defined $map); } else { # tell user they may wish to add mapping for this key # they can add {'Field' => undef} to get rid of this warning warn 'potential external key "'.$table.'.'.$Field."\"\n"; } } else { # make guess at field mapping # $targetTable = "\u$Field".'s'; $targetTable = "$Field".'s'; } if ($targetTable) { push (@{$self->{REFS_FROM}{$targetTable}}, $table.'.'.$Field); if ($targetTable =~ m/\A(\w+)\.(\w+)\Z/) { $fieldDesc->{-target} = [$1, $2]; } elsif ($targetTable =~ m/\A(\w+)\Z/) { $fieldDesc->{-target} = $targetTable; } else { &throw(new W3C::Util::Exception(-message => "what kind of target is \"$targetTable\"?")); } } } } elsif ($type eq 'tinyint') { $fieldDesc->{-type} = $FieldType_TINYINT; $fieldDesc->{-size} = $parms; } elsif ($type eq 'float') { $fieldDesc->{-type} = $FieldType_FLOAT; $fieldDesc->{-size} = $parms; } elsif ($type eq 'enum') { $fieldDesc->{-type} = $FieldType_ENUM; $fieldDesc->{-values} = [$parms =~ m/\'(\w+)\'/g]; # build perl contstants to represent the enum constants my $i = 0; my (@toStrings, @stringsTo); foreach my $enum (@{$fieldDesc->{-values}}) { my $varName = $className.'::'.$Field."_\U$enum\E"; # assign int value to ENUM varName and queue to dump $self->assignAndQueue('', $varName, $i++, \@preDefs); push (@toStrings, "\$".$varName.' => \''.$enum.'\''); push (@stringsTo, '\''.$enum.'\' => '."\$".$varName); } # include type any overrides if (my $overrides = $self->{OVERRIDES}{$table}{$Field}) { $tableDesc->{-overrides}{$Field} = $overrides; foreach my $value (keys %$overrides) { $tableDesc->{-overrides}{$Field}{$value} = $self->{INTERFACE_VARIABLE}.'::'.$overrides->{$value}; } } # add extra hashes for converting between ints and ENUM strings $fieldDesc->{-toStrings} = $self->assignAndQueue('HASH', $className.'::'.$Field.'_to_string', '('.join (",", @toStrings).')', \@preDefs); $fieldDesc->{-stringsTo} = $self->assignAndQueue('HASH', $className.'::string_to_'.$Field, '('.join (",", @stringsTo).')', \@preDefs); } elsif ($type eq 'char') { $fieldDesc->{-type} = $FieldType_CHAR; $fieldDesc->{-size} = $parms; } elsif ($type eq 'varchar') { $fieldDesc->{-type} = $FieldType_VARCHAR; $fieldDesc->{-size} = $parms; } elsif ($type eq 'text') { $fieldDesc->{-type} = $FieldType_TEXT; $fieldDesc->{-size} = $parms; } elsif ($type eq 'blob') { $fieldDesc->{-type} = $FieldType_BLOB; } elsif ($type eq 'date') { $fieldDesc->{-type} = $FieldType_DATE; } elsif ($type eq 'time') { $fieldDesc->{-type} = $FieldType_TIME; } elsif ($type eq 'datetime') { $fieldDesc->{-type} = $FieldType_DATETIME; } elsif ($type eq 'timestamp') { $fieldDesc->{-type} = $FieldType_TIMESTAMP; } else { print STDERR 'What\'s a "'.$type.'" in "'.$self->{DB_NAME}.'.'.$table.'"?'."\n"; } if (0) { # generate function interface $interface .= 'sub '.$className.'::getPrimaryKey {return $_[0]->{DB_ID'."};}\n" if ($Key eq 'PRI'); $interface .= 'sub '.$className.'::_get'."\u$Field".' {return $_[0]->{FIELD_VALUES}{\''.$Field."'};}\n"; $interface .= 'sub '.$className.'::_check'."\u$Field".' {return ${($_[0]->check([\''.$Field."']))[0]}[0];}\n"; # ;-P $interface .= 'sub '.$className.'::_set'."\u$Field".' {$_[0]->{FIELD_VALUES}{\''.$Field."'} = \$_[1];}\n"; $interface .= 'sub '.$className.'::_update'."\u$Field".' {$_[0]->update({\''.$Field."' => \$_[1]});}\n"; } } # get all the indexes and uniques my @rows; $self->{DB}->executeArrayQuery(\@rows, 'SHOW INDEX FROM '.$self->{DB_NAME}.'.'.$table); foreach my $row (@rows) { my ($Table, $Non_unique, $Key_name, $Seq_in_index, $Column_name, $Collation, $Cardinality, $Sub_part) = (@$row); if ($Column_name eq $tableDesc->{-primaryKey}) { # ignore so we don't tromp an indexes (oddly) named 'PRIMARY' } else { $tableDesc->{-index}{$Key_name}{-unique} = !$Non_unique; $tableDesc->{-index}{$Key_name}{-fields}{$Column_name} = $Seq_in_index-1; $tableDesc->{-index}{$Key_name}{-sequence}[$Seq_in_index-1] = $Column_name; } } # make sure the primary key is first if (my $pk = $tableDesc->{-primaryKey}) { if (ref $pk eq 'ARRAY') { # make hash of key orders (eg {'name'=>0, 'addr'=>2}) my $order = {}; for (my $i = 0; $i < @$pk; $i++) { $order->{$pk->[$i]} = $i; } $tableDesc->{-fieldOrder} = [@{$tableDesc->{-primaryKey}}, grep {!exists $order->{$_}} @{$tableDesc->{-fieldOrder}}]; } else { $tableDesc->{-fieldOrder} = [$tableDesc->{-primaryKey}, grep {$_ ne $tableDesc->{-primaryKey}} @{$tableDesc->{-fieldOrder}}]; } } # Everything in this return line gets Data::Dump'ed ... return ([@preDefs, @postDefs], $interface, $table, $tableDesc); } sub dumpTable ($) { # ... into this parameter line. my ($self, $ordinal, $defs, $interface, $table, $tableDesc) = @_; $self->printOut($self->pruneDumperOutput($defs)); $self->printOut($interface); $self->printOut("\n"); # token readability # print the html documentation if ($self->{HTML_FILE}) { $self->printHtmlTable($ordinal, $table, $tableDesc); } } sub pruneDumperOutput ($) { my ($self, $defs) = @_; # Dump at Dumper indent policy of 2 ... $Data::Dumper::Indent = 2; my $structure = Data::Dumper->Dump([map {$_->[0]} (@$defs)], # the queued variables [map {$_->[1]} (@$defs)]); # and their names # ... and collapse spurious linefeeds inside '{}', '[]', '()' $structure =~ s/([\{\[$])\n\s+/$1 /g; # blah {\n foo => blah { foo $structure =~ s/\n\s+([\}\]$])/ $1/g; # foo \n }\n => foo } return $structure; } sub dumpPythonOutput { my ($self, $fileHandle) = @_; $Data::Dumper::Indent = 2; # Dump just the _AllTables variable. my $structure = Data::Dumper->Dump([\%W3C::Rnodes::AclSqlObjects::_AllTables], ['_AllTables']); # Transform it to Python syntax. $structure =~ s/\=\>/:/g; $structure =~ s/undef/"NULL"/g; $structure =~ s/^\$//s; $structure =~ s/\;$//s; # Collapse spurious linefeeds inside '{}', '[]', '()' $structure =~ s/([\{\[$])\n\s+/$1 /g; # blah {\n foo => blah { foo $structure =~ s/\n\s+([\}\]$])/ $1/g; # foo \n }\n => foo } # Print out a table description. my $orderStr = join (', ', @{$self->{ORDER}}); my $date = `date`; chomp $date; my $dir = `pwd`; chomp $dir; my $hostname = `hostname`; chomp $hostname; my $args = join(' ', @ARGV); $args =~ s/\n/ \\\n/sg; print $fileHandle <{INTERFACE_VARIABLE}: database: $self->{DB_NAME} tables: $orderStr generated $date by $REVISION ------------------------------------------------------------------------------- $hostname:$dir\$ $0 $args ------------------------------------------------------------------------------- """ EOF ; print $fileHandle $structure; print $fileHandle "\n"; close $fileHandle; } # Build a variable initializer and evaluate it. Store the result in # the @$pDefs queue. # $refType - ref type of the variable. May be '' for a variable # that is a simple SCALAR (not a SCALAR reference). # $varName - name of the variable being initialized. # $rvalue - right side of the initial assignment. This is included # because many of the assignments were constructed from # strings and required evals anyways. # @$pDefs - ref to a definition queue. This is passed to the # Data::Dumper as the variable ref and variabe name. # returns: $varRef - the variable ref which will be passed to # Data::Dumper. Many times it will be convenient # to point a convenience variable at the return. sub assignAndQueue { my ($self, $refType, $varName, $rvalue, $pDefs) = @_; my ($evalMe, $howToPrint); if ($refType eq 'HASH') { $evalMe = "\%".$varName.' = '.$rvalue.'; $varRef = \%'.$varName; $howToPrint = '*'; } elsif ($refType eq 'ARRAY') { $evalMe = "\@".$varName.' = '.$rvalue.'; $varRef = \@'.$varName; $howToPrint = '*'; } elsif ($refType eq '') { $evalMe = "\$".$varName.' = '.$rvalue.'; $varRef = '."\$".$varName; $howToPrint = "\$"; } else { &throw(new W3C::Util::Exception(-message => "assignAndQueue: bad refType: \"$refType\"")); } my $varRef; eval $evalMe; if ($@) { &throw(new W3C::Util::Exception(-message => 'bad eval:"'.$evalMe."\"\n".$@)); } push (@$pDefs, [$varRef, $howToPrint.$varName]); return $varRef; } sub printOut ($) { my ($self, $printMe) = @_; return if (!$self->{OUT_FILE}); local *FH = $self->{OUT_FILE}; print FH $printMe; } sub printHtml ($) { my ($self, $printMe) = @_; return if (!$self->{HTML_FILE}); local *FH = $self->{HTML_FILE}; print FH $printMe; } sub printHtmlTable ($) { my ($self, $ordinal, $table, $tableDesc) = @_; my $idxNo = $ordinal+1; $self->printHtml("

$idxNo. $table table

\n"); # list the field names #$self->printHtml(' '); $self->printHtml(' '); foreach my $field (@{$tableDesc->{-fieldOrder}}) { my $classStr = $field eq $tableDesc->{-primaryKey} ? ' class="pk"' : ''; $self->printHtml("$field"); } $self->printHtml("\n"); # leave room for the descriptions if (0) { $self->printHtml(' '); foreach my $field (@{$tableDesc->{-fieldOrder}}) { $self->printHtml(''); # @@@ - add user-defined descriptions } $self->printHtml(" "); } # show outbound links { my ($printBuf, $buf) = (0, ''); $buf .= ' '; foreach my $field (@{$tableDesc->{-fieldOrder}}) { $buf .= ''; } $buf .= " "; $self->printHtml($buf) if ($printBuf); } # show inbound links { my ($printBuf, $buf) = (0, ''); $buf .= ' '; foreach my $field (@{$tableDesc->{-fieldOrder}}) { $buf .= ''; } $buf .= " "; $self->printHtml($buf) if ($printBuf); } # and the indexes foreach my $index (keys %{$tableDesc->{-index}}) { $self->printHtml(' '); foreach my $field (@{$tableDesc->{-fieldOrder}}) { $self->printHtml(''); } $self->printHtml(" "); } # get n examples my @rows; { my $count = 1; # @@@ user definable someday? my $fields = (@{$tableDesc->{-fieldOrder}})+1; $self->{DB}->executeArrayQuery(\@rows, 'SELECT '.join(',', @{$tableDesc->{-fieldOrder}}).' FROM '.$self->{DB_NAME}.'.'.$table.' LIMIT '.$count); $self->printHtml(" "); } foreach my $row (@rows) { $self->printHtml(" "); for (my $i = 0; $i < @{$tableDesc->{-fieldOrder}}; $i++) { if ($tableDesc->{-fieldOrder}[$i] eq $tableDesc->{-primaryKey}) { $self->printHtml(''); } else { $self->printHtml(''); } } $self->printHtml(" "); } $self->printHtml("

'.$table.'
'.$table.'
description	'.'
links to:	'; my $target = $tableDesc->{-fields}{$field}{-target}[0]; if (defined $target) { $target .= '.'.$self->{ENTRIES}{$target}[3]{-primaryKey}; $target = ''.$target.''; $buf .= $target; $printBuf = 1; } $buf .= '
links from:	'; if (my $referents = $tableDesc->{-fields}{$field}{-referents}) { foreach my $referent (@$referents) { $referent = ''.$referent.' '; $buf .= $referent; } $printBuf = 1; } $buf .= '
'.$index.($tableDesc->{-index}{$index}{-unique} ? ' U' : '').'	'); my $index = $tableDesc->{-index}{$index}{-fields}{$field}; $self->printHtml($index) if (defined $index); $self->printHtml('
example
	'.$row->[$i].'	'.$row->[$i].'

"); } package Shim; sub new { my ($proto, $argv) = @_; my $class = ref $proto || $proto; my $self = {}; bless ($self, $class); return $self; } sub selectTable ($) { my ($self, $tables) = @_; } package W3C::Database::Tk_object_maker; BEGIN {@W3C::Database::Tk_object_maker::ISA = qw(W3C::Database::object_maker);} sub main { my ($self) = @_; # $self->SUPER::main(); $self->selectDB; &Tk::MainLoop; # $self->processTableList; # $self->dumpOutput; $self->quit(0); } sub selectDB ($) { my ($self) = @_; # clear current GUI $self->clearTableWindows; $self->{CUR_FRAME}->destroy() if ($self->{CUR_FRAME}); $self->{CONTROL_FRAME}->destroy() if ($self->{CONTROL_FRAME}); my ($props, $fields, $descs, $om, $makeConnection) = ($self->{ARGS}{'-properties'}, ['queryHost', 'database', 'user', 'password'], {'queryHost' => {-prompt => 'queryHost', -type => 0}, 'database' => {-prompt => 'database', -type => 0}, 'user' => {-prompt => 'user', -type => 0}, 'password' => {-prompt => 'password', -type => 0}}, $self, sub {$self->makeConnection()}); # $self->{MW} = Tk::MainWindow->new(-title => 'browse '.$self->{DATABASE}); $self->{CUR_FRAME} = $self->{UI}->{MW}->Frame(-relief => 'groove', -bd => 2)->pack(-anchor => 'n', -side => 'top'); my %context; $context{FIELDS} = $fields; $context{PROPS} = $props; foreach my $field (@$fields) { $context{VALUES}{$field} = $props->get($field); $self->{CUR_FRAME}->LabEntry(-label => $descs->{$field}{-prompt}, -textvariable => \$context{VALUES}{$field}, -labelPack => [ -side => 'left' ])->pack(-side => 'top', -anchor => 'n'); } # bottom row is just the exit button $self->{CONTROL_FRAME} = $self->{UI}->{MW}->Frame(-relief => 'groove', -bd => 2)->pack(-anchor => 's', -side => 'bottom'); $self->{CONTROL_FRAME}->Button(-text => "OK", -underline => 1, -command => [\&checkConnection, $self, \%context, $makeConnection])->pack(-side => 'left'); $self->{CONTROL_FRAME}->Button(-text => "Exit", -underline => 1, -command => sub {exit;})->pack(-side => 'left'); } sub checkConnection { my ($self, $context, $makeConnection) = @_; foreach my $field (@{$context->{FIELDS}}) { $context->{PROPS}->putR($field, $context->{VALUES}{$field}); } eval {$makeConnection->();}; if ($@) { warn $@; } else { $self->selectTable; } } sub selectTable () { my ($self) = @_; # clear current GUI $self->{CUR_FRAME}->destroy(); $self->{CONTROL_FRAME}->destroy(); $self->walkTables; $self->{CUR_FRAME} = $self->{UI}->{MW}->Frame(-relief => 'groove', -bd => 2)->pack(-anchor => 'n', -side => 'top'); my ($included, $excluded); $included = $self->{CUR_FRAME}->Listbox->pack(-anchor => 'w', -side => 'left'); $excluded = $self->{CUR_FRAME}->Listbox->pack(-anchor => 'e', -side => 'right'); $included->insert('end', @{$self->{INCLUDED_TABLES}}); $excluded->insert('end', @{$self->{EXCLUDED_TABLES}}); $included->Tk::bind("", [sub {$self->startDrag(@_)}]); $included->Tk::bind("", [sub {$self->endDrag(@_)}, Tk::Ev('x'), Tk::Ev('y'), Tk::Ev('X'), Tk::Ev('Y')]); $included->Tk::bind("", [sub {$self->pickOne(@_)}, Tk::Ev('x'), Tk::Ev('y')]); $excluded->Tk::bind("", [sub {$self->startDrag(@_)}]); $excluded->Tk::bind("", [sub {$self->endDrag(@_)}, Tk::Ev('x'), Tk::Ev('y'), Tk::Ev('X'), Tk::Ev('Y')]); $excluded->Tk::bind("", [sub {$self->pickOne(@_)}, Tk::Ev('x'), Tk::Ev('y')]); $self->{CONTEXT}{INCLUDED} = [$self->{INCLUDED_TABLES}, $included]; $self->{CONTEXT}{EXCLUDED} = [$self->{EXCLUDED_TABLES}, $excluded]; # bottom row is just the exit button $self->{CONTROL_FRAME} = $self->{UI}->{MW}->Frame(-relief => 'groove', -bd => 2)->pack(-anchor => 's', -side => 'bottom'); $self->{CONTROL_FRAME}->Button(-text => "<=", -underline => 1, -command => sub {$self->selectDB;})->pack(-side => 'left'); $self->{CONTROL_FRAME}->Button(-text => "=>", -underline => 1, -command => sub {$self->promptOutput;})->pack(-side => 'left'); } sub promptOutput { my ($self) = @_; # clear current GUI $self->{CUR_FRAME}->destroy(); $self->{CONTROL_FRAME}->destroy(); $self->processTableList; $self->referentFixups; $self->dumpOutput; # bottom row is just the exit button $self->{CONTROL_FRAME} = $self->{UI}->{MW}->Frame(-relief => 'groove', -bd => 2)->pack(-anchor => 's', -side => 'bottom'); $self->{CONTROL_FRAME}->Button(-text => "<=", -underline => 1, -command => sub {$self->selectTable;})->pack(-side => 'left'); $self->{CONTROL_FRAME}->Button(-text => "done", -underline => 1, -command => sub {$self->quit(0);})->pack(-side => 'left'); } sub startDrag ($) { my ($self, $list) = @_; $self->{FROM_INDEX} = $list->curselection; # print STDERR 'startDrag: '.$list.':'.$list->curselection.'('.$x.','.$y.')'."\n"; } sub endDrag ($$$$$) { my ($self, $list, $x, $y, $X, $Y) = @_; my $dragTo = [$list, $list->curselection]; my $context = $self->{CONTEXT}; my $hit = $self->{CUR_FRAME}->containing($X, $Y); my $fromArray = $list == $context->{INCLUDED}[1] ? $context->{INCLUDED}[0] : $list == $context->{EXCLUDED}[1] ? $context->{EXCLUDED}[0] : undef; my $toArray = $hit == $context->{INCLUDED}[1] ? $context->{INCLUDED}[0] : $hit == $context->{EXCLUDED}[1] ? $context->{EXCLUDED}[0] : undef; if (exists $self->{FROM_INDEX} && defined $toArray) { my $xy = '@'.$x.','.$y; my $toIndex = $hit == $context->{INCLUDED}[1] ? $context->{INCLUDED}[1]->index($xy) : $context->{EXCLUDED}[1]->index($xy); if (!($fromArray == $toArray && $self->{FROM_INDEX} == $toIndex)) { # print STDERR join(' ', @{$fromArray}).' -> '.join(' ', @{$toArray})."\n"; splice(@{$toArray}, $toIndex, 0, splice(@{$fromArray}, $self->{FROM_INDEX}, 1)); # print STDERR join(' ', @{$fromArray}).' -> '.join(' ', @{$toArray})."\n"; $hit->insert($toIndex, $list->get($self->{FROM_INDEX})); $list->delete($self->{FROM_INDEX}); # $context->{INCLUDED}[1]->delete(0, 'end'); # $context->{INCLUDED}[1]->insert('end', @{$self->{INCLUDED_TABLES}}); # $context->{EXCLUDED}[1]->delete(0, 'end'); # $context->{EXCLUDED}[1]->insert('end', @{$self->{EXCLUDED_TABLES}}); } } } sub pickOne ($$$) { my ($self, $list, $x, $y) = @_; my $pick = [$list, $list->curselection]; delete $self->{FROM_INDEX}; print STDERR 'pickOne: '.$list.':'.$list->curselection.'('.$x.','.$y.')'."\n"; my $table = $list->get('active'); my $tableWindow = Tk::MainWindow->new(-title => 'edit '.$table); push (@{$self->{TABLE_WINDOWS}}, $tableWindow); } sub quit (;$) { my ($self, $errorCode) = @_; $self->clearTableWindows; $self::SUPER->quit($errorCode); } sub clearTableWindows { my ($self) = @_; foreach my $tableWindow (@{$self->{TABLE_WINDOWS}}) { $tableWindow->destroy; } } __END__ W3C::Database::ObjectDB - =head1 SYNOPSIS @@@ =head1 DESCRIPTION This module is part of the W3C::Database CPAN module. =head1 AUTHOR Eric Prud'hommeaux =head1 SEE ALSO perl(1). =cut