factory.mysql

#!/usr/bin/perl
#$Header: /raid/RT/polysched/sbin/factory,v 1.2 2001/12/07 03:51:09 jesse Exp $
use DBI;

my $database  = shift;
my $namespace = shift;

my $CollectionBaseclass = 'RT::FM::SearchBuilder';
my $RecordBaseclass     = 'RT::FM::Record';

my $driver   = 'mysql';
my $hostname = 'localhost';
my $user     = 'root';
my $password = '';

my $Attribution = "
# Autogenerated by DBIx::SearchBuilder factory (by <jesse\@bestpractical.com>)
# WARNING: THIS FILE IS AUTOGENERATED. ALL CHANGES TO THIS FILE WILL BE LOST.  
# 
# !! DO NOT EDIT THIS FILE !!
#
";

my $dsn = "DBI:$driver:database=$database;host=$hostname";

my $dbh = DBI->connect( $dsn, $user, $password );

#get all tables out of database
my @tables = $dbh->tables();

@tables = grep { /^FM_/i } map {s/`\Q$database\E`\.`(.*)`/$1/; $_} @tables;
my ( %tablemap, $typemap, %modulemap );

foreach my $table (@tables) {
    print "We're looking at $table\n";

    $table =~ s/customfield/CustomField/gi;
    $table =~ s/value/Value/gi;
    $table =~ s/cfvalue/CFValue/gi;
    $table =~ s/fm_/FM_/;
    $table =~ s/_(.)/"_".uc($1)/e;


    $tablemap{$table}  = $table;
    $modulemap{$table} = $table;
    if ( $table =~ /^FM_((?:Object)?Class)es$/i || $table =~ /^FM_(.*?)(s?)$/i ) {
        my $item = $1;
        $item = ucfirst($item);
        $tablemap{$item}  = $table;
        $modulemap{$item} = $item;
        print "Shoving $item into the map as a pointer to $table\n";
    }
}
$tablemap{'CreatedBy'} = 'User';
$tablemap{'UpdatedBy'} = 'User';

$typemap{'id'}            = 'ro';
$typemap{'Creator'}       = 'auto';
$typemap{'Created'}       = 'auto';
$typemap{'Updated'}       = 'auto';
$typemap{'UpdatedBy'}     = 'auto';
$typemap{'LastUpdated'}   = 'auto';
$typemap{'LastUpdatedBy'} = 'auto';

foreach my $table (@tables) {
    next if ($table eq 'sessions');

    print "We're looking at $table\n";


    my $tablesingle = $table;
    $tablesingle =~ s/^FM_//gi;
    $tablesingle = ucfirst($tablesingle);
    $tablesingle =~ s/customfield/CustomField/gi;
    $tablesingle =~ s/value/Value/gi;
    $tablesingle =~ s/cfvalue/CFValue/gi;
    if ($tablesingle =~ /^Classes$/i) {
        $tablesingle = "Class";
    } elsif ($tablesingle =~ /^ObjectClasses$/i) {
        $tablesingle = "ObjectClass";
    } else {
        $tablesingle =~ s/s$//;
    }
    my $tableplural = $tablesingle . "Collection";



    my %requirements;

    my $CollectionClassName = $namespace . "::" . $tableplural;
    my $RecordClassName     = $namespace . "::" . $tablesingle;

    my $path = $namespace;
    $path =~ s/::/\//g;

    my $RecordClassPath     = $path . "/" . $tablesingle . ".pm";
    my $CollectionClassPath = $path . "/" . $tableplural . ".pm";

    #create a collection class
    my $CreateInParams;
    my $CreateOutParams;
    my $ClassAccessible = "";
    my $FieldsPod       = "";
    my $CreatePod       = "";
    my %fields;
    my $sth = $dbh->prepare("DESCRIBE $table");
    $sth->execute;

    while ( my $row = $sth->fetchrow_hashref() ) {
        my $field   = $row->{'Field'};
        my $type    = $row->{'Type'};
        my $default = $row->{'Default'};
        $fields{$field} = 1;

        #generate the 'accessible' datastructure

        if ( $typemap{$field} eq 'auto' ) {
            $ClassAccessible .= "        $field => 
		{read => 1, auto => 1,";
        }
        elsif ( $typemap{$field} eq 'ro' ) {
            $ClassAccessible .= "        $field =>
		{read => 1,";
        }
        else {
            $ClassAccessible .= "        $field => 
		{read => 1, write => 1,";

        }

        $ClassAccessible .= " type => '$type', default => '$default'},\n";

        #generate pod for the accessible fields
        $FieldsPod .= "
=item $field

Returns the current value of $field. 
(In the database, $field is stored as $type.)

";

        unless ( $typemap{$field} eq 'auto' || $typemap{$field} eq 'ro' ) {
            $FieldsPod .= "

=item Set$field VALUE


Set $field to VALUE. 
Returns (1, 'Status message') on success and (0, 'Error Message') on failure.
(In the database, $field will be stored as a $type.)

";
        }

        $FieldsPod .= "
=cut

";

        print "Checking module map for $field\n";

        if ( $modulemap{$field} ) {
            print " found it!\n";
            $FieldsPod .= "
=item ${field}Obj

Returns the $modulemap{$field} Object which has the id returned by $field


=cut

sub ${field}Obj {
	my \$self = shift;
	my \$$field =  ${namespace}::$modulemap{$field}->new(\$self->CurrentUser);
	\$$field->Load(\$self->$field());
	return(\$$field);
}
";
            $requirements{ $tablemap{$field} } =
              "use ${namespace}::$modulemap{$field};";

        }

        unless ( $typemap{$field} eq 'auto' || $field eq 'id' ) {

            #generate create statement
            $CreateInParams .= "                $field => '$default',\n";
            $CreateOutParams .=
              "                         $field => \$args{'$field'},\n";

            #gerenate pod for the create statement	
            $CreatePod .= "  $type '$field'";
            $CreatePod .= " defaults to '$default'" if ($default);
            $CreatePod .= ".\n";

        }

    }

    $Create = "
sub Create {
    my \$self = shift;
    my \%args = ( 
$CreateInParams
		  \@_);
    \$self->SUPER::Create(
$CreateOutParams);

}
";
    $CreatePod .= "\n=cut\n\n";

    my $CollectionClass = $Attribution .

      "

=head1 NAME

  $CollectionClassName -- Class Description
 
=head1 SYNOPSIS

  use $CollectionClassName

=head1 DESCRIPTION


=head1 METHODS

=cut

package $CollectionClassName;

use $CollectionBaseclass;
use $RecordClassName;

use base qw($CollectionBaseclass);


sub _Init {
    my \$self = shift;
    \$self->{'table'} = '$table';
    \$self->{'primary_key'} = 'id';

";

    if ( $fields{'SortOrder'} ) {

        $CollectionClass .= "

  # By default, order by name
  \$self->OrderBy( ALIAS => 'main',
                  FIELD => 'SortOrder',
                  ORDER => 'ASC');
";
    }
    $CollectionClass .= "
    return ( \$self->SUPER::_Init(\@_) );
}


=item NewItem

Returns an empty new $RecordClassName item

=cut

sub NewItem {
    my \$self = shift;
    return($RecordClassName->new(\$self->CurrentUser));
}
" . MagicImport($CollectionClassName);

    my $RecordClassHeader = $Attribution . "

=head1 NAME

$RecordClassName


=head1 SYNOPSIS

=head1 DESCRIPTION

=head1 METHODS

=cut

package $RecordClassName;
use $RecordBaseclass; 
";

    foreach my $key ( keys %requirements ) {
        $RecordClassHeader .= $requirements{$key} . "\n";
    }
    $RecordClassHeader .= "

use base qw( $RecordBaseclass );

sub _Init {
  my \$self = shift; 

  \$self->Table('$table');
  \$self->SUPER::_Init(\@_);
}

";

    my $RecordClass = "

$RecordClassHeader

$RecordInit

=item Create PARAMHASH

Create takes a hash of values and creates a row in the database:

$CreatePod

$Create

$FieldsPod

sub _CoreAccessible {
    {
     
$ClassAccessible
 }
};

" . MagicImport($RecordClassName);

    print "About to make $RecordClassPath, $CollectionClassPath\n";
    `mkdir -p $path`;

    open( RECORD, ">$RecordClassPath" );
    print RECORD $RecordClass;
    close(RECORD);

    open( COL, ">$CollectionClassPath" );
    print COL $CollectionClass;
    close($COL);

}

sub MagicImport {
    my $class = shift;

    #if (exists \$warnings::{unimport})  {
    #        no warnings qw(redefine);

    my $content = "
        eval \"require @{[$class]}_Overlay\";
        if (\$@ && \$@ !~ /^Can't locate/) {
            die \$@;
        };

        eval \"require @{[$class]}_Local\";
        if (\$@ && \$@ !~ /^Can't locate/) {
            die \$@;
        };




=head1 SEE ALSO

This class allows \"overlay\" methods to be placed
into the following files _Overlay is for a System overlay by the original author,
while _Local is for site-local customizations.  

These overlay files can contain new subs or subs to replace existing subs in this module.

If you'll be working with perl 5.6.0 or greater, each of these files should begin with the line 

   no warnings qw(redefine);

so that perl does not kick and scream when you redefine a subroutine or variable in your overlay.

@{[$class]}_Overlay, @{[$class]}_Local

=cut


1;
";

    return $content;
}

# }}}