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