rt/sbin/factory

   1 #!/usr/bin/perl
   2 # BEGIN LICENSE BLOCK
   3 #
   4 # Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com>
   5 #
   6 # (Except where explictly superceded by other copyright notices)
   7 #
   8 # This work is made available to you under the terms of Version 2 of
   9 # the GNU General Public License. A copy of that license should have
  10 # been provided with this software, but in any event can be snarfed
  11 # from www.gnu.org.
  12 #
  13 # This work is distributed in the hope that it will be useful, but
  14 # WITHOUT ANY WARRANTY; without even the implied warranty of
  15 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  16 # General Public License for more details.
  17 #
  18 # Unless otherwise specified, all modifications, corrections or
  19 # extensions to this work which alter its source code become the
  20 # property of Best Practical Solutions, LLC when submitted for
  21 # inclusion in the work.
  22 #
  23 #
  24 # END LICENSE BLOCK
  25
  26 use DBI;
  27
  28 my $database  = shift;
  29 my $namespace = shift;
  30
  31 my $CollectionBaseclass = 'RT::SearchBuilder';
  32 my $RecordBaseclass     = 'RT::Record';
  33
  34 my $driver   = 'mysql';
  35 my $hostname = 'localhost';
  36 my $user     = 'root';
  37 my $password = '';
  38
  39
  40 my $LicenseBlock = << '.';
  41 # BEGIN LICENSE BLOCK
  42 #
  43 # Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com>
  44 #
  45 # (Except where explictly superceded by other copyright notices)
  46 #
  47 # This work is made available to you under the terms of Version 2 of
  48 # the GNU General Public License. A copy of that license should have
  49 # been provided with this software, but in any event can be snarfed
  50 # from www.gnu.org.
  51 #
  52 # This work is distributed in the hope that it will be useful, but
  53 # WITHOUT ANY WARRANTY; without even the implied warranty of
  54 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  55 # General Public License for more details.
  56 #
  57 # Unless otherwise specified, all modifications, corrections or
  58 # extensions to this work which alter its source code become the
  59 # property of Best Practical Solutions, LLC when submitted for
  60 # inclusion in the work.
  61 #
  62 #
  63 # END LICENSE BLOCK
  64 .
  65
  66 my $Attribution = << '.';
  67 # Autogenerated by DBIx::SearchBuilder factory (by <jesse@bestpractical.com>)
  68 # WARNING: THIS FILE IS AUTOGENERATED. ALL CHANGES TO THIS FILE WILL BE LOST.
  69 #
  70 # !! DO NOT EDIT THIS FILE !!
  71 #
  72
  73 use strict;
  74 .
  75
  76 my $dsn = "DBI:$driver:database=$database;host=$hostname";
  77
  78 my $dbh = DBI->connect( $dsn, $user, $password );
  79
  80 #get all tables out of database
  81 my @tables = $dbh->tables();
  82
  83 my ( %tablemap, $typemap, %modulemap );
  84
  85 foreach my $table (@tables) {
  86     next if ($table eq 'sessions');
  87     $tablemap{$table}  = $table;
  88     $modulemap{$table} = $table;
  89     if ( $table =~ /^(.*)s$/ ) {
  90         $tablemap{$1}  = $table;
  91         $modulemap{$1} = $1;
  92     }
  93 }
  94 $tablemap{'CreatedBy'} = 'User';
  95 $tablemap{'UpdatedBy'} = 'User';
  96
  97 $typemap{'id'}            = 'ro';
  98 $typemap{'Creator'}       = 'auto';
  99 $typemap{'Created'}       = 'auto';
 100 $typemap{'Updated'}       = 'auto';
 101 $typemap{'UpdatedBy'}     = 'auto';
 102 $typemap{'LastUpdated'}   = 'auto';
 103 $typemap{'LastUpdatedBy'} = 'auto';
 104
 105 foreach my $table (@tables) {
 106     next if ($table eq 'sessions');
 107     my $tablesingle = $table;
 108     $tablesingle =~ s/s$//;
 109     my $tableplural = $tablesingle . "s";
 110
 111     if ( $tablesingle eq 'ACL' ) {
 112         $tablesingle = "ACE";
 113         $tableplural = "ACL";
 114     }
 115
 116     my %requirements;
 117
 118     my $CollectionClassName = $namespace . "::" . $tableplural;
 119     my $RecordClassName     = $namespace . "::" . $tablesingle;
 120
 121     my $path = $namespace;
 122     $path =~ s/::/\//g;
 123
 124     my $RecordClassPath     = $path . "/" . $tablesingle . ".pm";
 125     my $CollectionClassPath = $path . "/" . $tableplural . ".pm";
 126
 127     #create a collection class
 128     my $CreateInParams;
 129     my $CreateOutParams;
 130     my $ClassAccessible = "";
 131     my $FieldsPod       = "";
 132     my $CreatePod       = "";
 133     my %fields;
 134     my $sth = $dbh->prepare("DESCRIBE $table");
 135     $sth->execute;
 136
 137     while ( my $row = $sth->fetchrow_hashref() ) {
 138         my $field   = $row->{'Field'};
 139         my $type    = $row->{'Type'};
 140         my $default = $row->{'Default'};
 141         $fields{$field} = 1;
 142
 143         #generate the 'accessible' datastructure
 144
 145         if ( $typemap{$field} eq 'auto' ) {
 146             $ClassAccessible .= "        $field =>
 147                 {read => 1, auto => 1,";
 148         }
 149         elsif ( $typemap{$field} eq 'ro' ) {
 150             $ClassAccessible .= "        $field =>
 151                 {read => 1,";
 152         }
 153         else {
 154             $ClassAccessible .= "        $field =>
 155                 {read => 1, write => 1,";
 156
 157         }
 158
 159         $ClassAccessible .= " type => '$type', default => '$default'},\n";
 160
 161         #generate pod for the accessible fields
 162         $FieldsPod .= "
 163 =head2 $field
 164
 165 Returns the current value of $field.
 166 (In the database, $field is stored as $type.)
 167
 168 ";
 169
 170         unless ( $typemap{$field} eq 'auto' || $typemap{$field} eq 'ro' ) {
 171             $FieldsPod .= "
 172
 173 =head2 Set$field VALUE
 174
 175
 176 Set $field to VALUE.
 177 Returns (1, 'Status message') on success and (0, 'Error Message') on failure.
 178 (In the database, $field will be stored as a $type.)
 179
 180 ";
 181         }
 182
 183         $FieldsPod .= "
 184 =cut
 185
 186 ";
 187
 188         if ( $modulemap{$field} ) {
 189             $FieldsPod .= "
 190 =head2 ${field}Obj
 191
 192 Returns the $modulemap{$field} Object which has the id returned by $field
 193
 194
 195 =cut
 196
 197 sub ${field}Obj {
 198         my \$self = shift;
 199         my \$$field =  ${namespace}::$modulemap{$field}->new(\$self->CurrentUser);
 200         \$$field->Load(\$self->__Value('$field'));
 201         return(\$$field);
 202 }
 203 ";
 204             $requirements{ $tablemap{$field} } =
 205               "use ${namespace}::$modulemap{$field};";
 206
 207         }
 208
 209         unless ( $typemap{$field} eq 'auto' || $field eq 'id' ) {
 210
 211             #generate create statement
 212             $CreateInParams .= "                $field => '$default',\n";
 213             $CreateOutParams .=
 214               "                         $field => \$args{'$field'},\n";
 215
 216             #gerenate pod for the create statement
 217             $CreatePod .= "  $type '$field'";
 218             $CreatePod .= " defaults to '$default'" if ($default);
 219             $CreatePod .= ".\n";
 220
 221         }
 222
 223     }
 224
 225     $Create = "
 226 sub Create {
 227     my \$self = shift;
 228     my \%args = (
 229 $CreateInParams
 230                   \@_);
 231     \$self->SUPER::Create(
 232 $CreateOutParams);
 233
 234 }
 235 ";
 236     $CreatePod .= "\n=cut\n\n";
 237
 238     my $CollectionClass = $LicenseBlock . $Attribution .
 239
 240       "
 241
 242 =head1 NAME
 243
 244   $CollectionClassName -- Class Description
 245
 246 =head1 SYNOPSIS
 247
 248   use $CollectionClassName
 249
 250 =head1 DESCRIPTION
 251
 252
 253 =head1 METHODS
 254
 255 =cut
 256
 257 package $CollectionClassName;
 258
 259 use $CollectionBaseclass;
 260 use $RecordClassName;
 261
 262 use vars qw( \@ISA );
 263 \@ISA= qw($CollectionBaseclass);
 264
 265
 266 sub _Init {
 267     my \$self = shift;
 268     \$self->{'table'} = '$table';
 269     \$self->{'primary_key'} = 'id';
 270
 271 ";
 272
 273     if ( $fields{'SortOrder'} ) {
 274
 275         $CollectionClass .= "
 276
 277   # By default, order by name
 278   \$self->OrderBy( ALIAS => 'main',
 279                   FIELD => 'SortOrder',
 280                   ORDER => 'ASC');
 281 ";
 282     }
 283     $CollectionClass .= "
 284     return ( \$self->SUPER::_Init(\@_) );
 285 }
 286
 287
 288 =head2 NewItem
 289
 290 Returns an empty new $RecordClassName item
 291
 292 =cut
 293
 294 sub NewItem {
 295     my \$self = shift;
 296     return($RecordClassName->new(\$self->CurrentUser));
 297 }
 298 " . MagicImport($CollectionClassName);
 299
 300     my $RecordClassHeader = $Attribution . "
 301
 302 =head1 NAME
 303
 304 $RecordClassName
 305
 306
 307 =head1 SYNOPSIS
 308
 309 =head1 DESCRIPTION
 310
 311 =head1 METHODS
 312
 313 =cut
 314
 315 package $RecordClassName;
 316 use $RecordBaseclass;
 317 ";
 318
 319     foreach my $key ( keys %requirements ) {
 320         $RecordClassHeader .= $requirements{$key} . "\n";
 321     }
 322     $RecordClassHeader .= "
 323
 324 use vars qw( \@ISA );
 325 \@ISA= qw( $RecordBaseclass );
 326
 327 sub _Init {
 328   my \$self = shift;
 329
 330   \$self->Table('$table');
 331   \$self->SUPER::_Init(\@_);
 332 }
 333
 334 ";
 335
 336     my $RecordClass = $LicenseBlock .  $RecordClassHeader . "
 337
 338 $RecordInit
 339
 340 =head2 Create PARAMHASH
 341
 342 Create takes a hash of values and creates a row in the database:
 343
 344 $CreatePod
 345
 346 $Create
 347
 348 $FieldsPod
 349
 350 sub _ClassAccessible {
 351     {
 352
 353 $ClassAccessible
 354  }
 355 };
 356
 357 " . MagicImport($RecordClassName);
 358
 359     print "About to make $RecordClassPath, $CollectionClassPath\n";
 360     `mkdir -p $path`;
 361
 362     open( RECORD, ">$RecordClassPath" );
 363     print RECORD $RecordClass;
 364     close(RECORD);
 365
 366     open( COL, ">$CollectionClassPath" );
 367     print COL $CollectionClass;
 368     close($COL);
 369
 370 }
 371
 372 sub MagicImport {
 373     my $class = shift;
 374
 375     #if (exists \$warnings::{unimport})  {
 376     #        no warnings qw(redefine);
 377
 378     my $path = $class;
 379     $path =~ s#::#/#gi;
 380
 381
 382     my $content = "
 383         eval \"require @{[$class]}_Overlay\";
 384         if (\$@ && \$@ !~ qr{^Can't locate ".$path."_Overlay.pm}) {
 385             die \$@;
 386         };
 387
 388         eval \"require @{[$class]}_Vendor\";
 389         if (\$@ && \$@ !~ qr{^Can't locate ".$path."_Vendor.pm}) {
 390             die \$@;
 391         };
 392
 393         eval \"require @{[$class]}_Local\";
 394         if (\$@ && \$@ !~ qr{^Can't locate ".$path."_Local.pm}) {
 395             die \$@;
 396         };
 397
 398
 399
 400
 401 =head1 SEE ALSO
 402
 403 This class allows \"overlay\" methods to be placed
 404 into the following files _Overlay is for a System overlay by the original author,
 405 _Vendor is for 3rd-party vendor add-ons, while _Local is for site-local customizations.
 406
 407 These overlay files can contain new subs or subs to replace existing subs in this module.
 408
 409 If you'll be working with perl 5.6.0 or greater, each of these files should begin with the line
 410
 411    no warnings qw(redefine);
 412
 413 so that perl does not kick and scream when you redefine a subroutine or variable in your overlay.
 414
 415 @{[$class]}_Overlay, @{[$class]}_Vendor, @{[$class]}_Local
 416
 417 =cut
 418
 419
 420 1;
 421 ";
 422
 423     return $content;
 424 }
 425
 426 # }}}
 427