rt/sbin/factory

   1 #!/usr/bin/perl -w
   2 # BEGIN BPS TAGGED BLOCK {{{
   3 #
   4 # COPYRIGHT:
   5 #
   6 # This software is Copyright (c) 1996-2009 Best Practical Solutions, LLC
   7 #                                          <jesse@bestpractical.com>
   8 #
   9 # (Except where explicitly superseded by other copyright notices)
  10 #
  11 #
  12 # LICENSE:
  13 #
  14 # This work is made available to you under the terms of Version 2 of
  15 # the GNU General Public License. A copy of that license should have
  16 # been provided with this software, but in any event can be snarfed
  17 # from www.gnu.org.
  18 #
  19 # This work is distributed in the hope that it will be useful, but
  20 # WITHOUT ANY WARRANTY; without even the implied warranty of
  21 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  22 # General Public License for more details.
  23 #
  24 # You should have received a copy of the GNU General Public License
  25 # along with this program; if not, write to the Free Software
  26 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  27 # 02110-1301 or visit their web page on the internet at
  28 # http://www.gnu.org/licenses/old-licenses/gpl-2.0.html.
  29 #
  30 #
  31 # CONTRIBUTION SUBMISSION POLICY:
  32 #
  33 # (The following paragraph is not intended to limit the rights granted
  34 # to you to modify and distribute this software under the terms of
  35 # the GNU General Public License and is only of importance to you if
  36 # you choose to contribute your changes and enhancements to the
  37 # community by submitting them to Best Practical Solutions, LLC.)
  38 #
  39 # By intentionally submitting any modifications, corrections or
  40 # derivatives to this work, or any other work intended for use with
  41 # Request Tracker, to Best Practical Solutions, LLC, you confirm that
  42 # you are the copyright holder for those contributions and you grant
  43 # Best Practical Solutions,  LLC a nonexclusive, worldwide, irrevocable,
  44 # royalty-free, perpetual, license to use, copy, create derivative
  45 # works based on those contributions, and sublicense and distribute
  46 # those contributions and any derivatives thereof.
  47 #
  48 # END BPS TAGGED BLOCK }}}
  49 use strict;
  50 use DBI;
  51
  52 die "Usage: $0 database namespace" if @ARGV != 2;
  53
  54 my $database  = shift;
  55 my $namespace = shift;
  56
  57 my $CollectionBaseclass = 'RT::SearchBuilder';
  58 my $RecordBaseclass     = 'RT::Record';
  59
  60 my $driver   = 'mysql';
  61 my $hostname = 'localhost';
  62 my $user     = 'root';
  63 my $password = '';
  64
  65
  66 my $LicenseBlock = << '.';
  67 # BEGIN BPS TAGGED BLOCK {{{
  68 #
  69 # COPYRIGHT:
  70 #
  71 # This software is Copyright (c) 1996-2008 Best Practical Solutions, LLC
  72 #                                          <jesse@bestpractical.com>
  73 #
  74 # (Except where explicitly superseded by other copyright notices)
  75 #
  76 #
  77 # LICENSE:
  78 #
  79 # This work is made available to you under the terms of Version 2 of
  80 # the GNU General Public License. A copy of that license should have
  81 # been provided with this software, but in any event can be snarfed
  82 # from www.gnu.org.
  83 #
  84 # This work is distributed in the hope that it will be useful, but
  85 # WITHOUT ANY WARRANTY; without even the implied warranty of
  86 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  87 # General Public License for more details.
  88 #
  89 # You should have received a copy of the GNU General Public License
  90 # along with this program; if not, write to the Free Software
  91 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  92 # 02110-1301 or visit their web page on the internet at
  93 # http://www.gnu.org/licenses/old-licenses/gpl-2.0.html.
  94 #
  95 #
  96 # CONTRIBUTION SUBMISSION POLICY:
  97 #
  98 # (The following paragraph is not intended to limit the rights granted
  99 # to you to modify and distribute this software under the terms of
 100 # the GNU General Public License and is only of importance to you if
 101 # you choose to contribute your changes and enhancements to the
 102 # community by submitting them to Best Practical Solutions, LLC.)
 103 #
 104 # By intentionally submitting any modifications, corrections or
 105 # derivatives to this work, or any other work intended for use with
 106 # Request Tracker, to Best Practical Solutions, LLC, you confirm that
 107 # you are the copyright holder for those contributions and you grant
 108 # Best Practical Solutions,  LLC a nonexclusive, worldwide, irrevocable,
 109 # royalty-free, perpetual, license to use, copy, create derivative
 110 # works based on those contributions, and sublicense and distribute
 111 # those contributions and any derivatives thereof.
 112 #
 113 # END BPS TAGGED BLOCK }}}
 114 .
 115
 116 my $Attribution = << '.';
 117
 118 # Autogenerated by DBIx::SearchBuilder factory (by <jesse@bestpractical.com>)
 119 # WARNING: THIS FILE IS AUTOGENERATED. ALL CHANGES TO THIS FILE WILL BE LOST.
 120 #
 121 # !! DO NOT EDIT THIS FILE !!
 122 #
 123
 124 use strict;
 125 .
 126
 127 my $dsn = "DBI:$driver:database=$database;host=$hostname";
 128
 129 my $dbh = DBI->connect( $dsn, $user, $password );
 130
 131 #get all tables out of database
 132 my @tables = map { s/^\`\Q$database\E\`\.//; $_ } $dbh->tables();
 133
 134 my ( %tablemap, $typemap, %modulemap );
 135
 136 foreach my $table (@tables) {
 137     $table =~ s/\`//g;
 138     next if ($table eq 'sessions');
 139         $table = ucfirst($table);
 140         $table =~ s/field/Field/;
 141         $table =~ s/group/Group/;
 142         $table =~ s/custom/Custom/;
 143         $table =~ s/member/Member/;
 144         $table =~ s/Scripaction/ScripAction/g;
 145         $table =~ s/condition/Condition/g;
 146         $table =~ s/value/Value/;
 147         $table =~ s/Acl/ACL/g;
 148     $tablemap{$table}  = $table;
 149     $modulemap{$table} = $table;
 150     if ( $table =~ /^(.*)s$/ ) {
 151         $tablemap{$1}  = $table;
 152         $modulemap{$1} = $1;
 153     }
 154 }
 155 $tablemap{'CreatedBy'} = 'User';
 156 $tablemap{'UpdatedBy'} = 'User';
 157
 158 my %typemap;
 159 $typemap{'id'}            = 'ro';
 160 $typemap{'Creator'}       = 'auto';
 161 $typemap{'Created'}       = 'auto';
 162 $typemap{'Updated'}       = 'auto';
 163 $typemap{'UpdatedBy'}     = 'auto';
 164 $typemap{'LastUpdated'}   = 'auto';
 165 $typemap{'LastUpdatedBy'} = 'auto';
 166
 167 foreach my $table (@tables) {
 168     next if ($table eq 'sessions');
 169     my $tablesingle = $table;
 170     $tablesingle =~ s/s$//;
 171     my $tableplural = $tablesingle . "s";
 172
 173     if ( $tablesingle eq 'ACL' ) {
 174         $tablesingle = "ACE";
 175         $tableplural = "ACL";
 176     }
 177
 178     my %requirements;
 179
 180     my $CollectionClassName = $namespace . "::" . $tableplural;
 181     my $RecordClassName     = $namespace . "::" . $tablesingle;
 182
 183     my $path = $namespace;
 184     $path =~ s/::/\//g;
 185
 186     my $RecordClassPath     = $path . "/" . $tablesingle . ".pm";
 187     my $CollectionClassPath = $path . "/" . $tableplural . ".pm";
 188
 189     #create a collection class
 190     my $CreateInParams;
 191     my $CreateOutParams;
 192     my $ClassAccessible = "";
 193     my $FieldsPod       = "";
 194     my $CreatePod       = "";
 195     my $RecordInit      = "";
 196     my %fields;
 197
 198
 199     my $introspection = $dbh->prepare("SELECT * from $table where id is null");
 200     $introspection->execute();
 201     my @names =@{ $introspection->{'NAME'}};
 202     my @types = @{$introspection->{'TYPE'}};
 203     my @is_blob = @{$introspection->{'mysql_is_blob'}};
 204     my @is_num = @{$introspection->{'mysql_is_num'}};
 205
 206     my %blobness = ();
 207     my %sqltypes = ();
 208     my %numeric = ();
 209     foreach my $name (@names) {
 210         $sqltypes{$name} = shift @types;
 211         $blobness{$name} = (shift @is_blob || "0");
 212         $numeric{$name} = (shift @is_num || "0");
 213     }
 214
 215
 216     my $sth = $dbh->prepare("DESCRIBE $table");
 217     $sth->execute;
 218
 219     while ( my $row = $sth->fetchrow_hashref() ) {
 220         my $field   = $row->{'Field'};
 221         my $type    = $row->{'Type'};
 222         my $default = $row->{'Default'};
 223         my $length = 0;
 224         if ($type =~ /^(?:.*?)\((\d+)\)$/) {
 225                 $length = $1;
 226         }
 227         $fields{$field} = 1;
 228
 229         #generate the 'accessible' datastructure
 230
 231         no warnings 'uninitialized';
 232
 233         if ( $typemap{$field} eq 'auto' ) {
 234             $ClassAccessible .= "        $field =>
 235                 {read => 1, auto => 1,";
 236         }
 237         elsif ( $typemap{$field} eq 'ro' ) {
 238             $ClassAccessible .= "        $field =>
 239                 {read => 1,";
 240         }
 241         else {
 242             $ClassAccessible .= "        $field =>
 243                 {read => 1, write => 1,";
 244
 245         }
 246         $ClassAccessible .= " sql_type => $sqltypes{$field}, length => $length,  is_blob => $blobness{$field},  is_numeric => $numeric{$field}, ";
 247         $ClassAccessible .= " type => '$type', default => '$default'},\n";
 248
 249         #generate pod for the accessible fields
 250         $FieldsPod .= "
 251 =head2 $field
 252
 253 Returns the current value of $field.
 254 (In the database, $field is stored as $type.)
 255
 256 ";
 257
 258         unless ( exists $typemap{$field} && ( $typemap{$field} eq 'auto' || $typemap{$field} eq 'ro' )) {
 259             $FieldsPod .= "
 260
 261 =head2 Set$field VALUE
 262
 263
 264 Set $field to VALUE.
 265 Returns (1, 'Status message') on success and (0, 'Error Message') on failure.
 266 (In the database, $field will be stored as a $type.)
 267
 268 ";
 269         }
 270
 271         $FieldsPod .= "
 272 =cut
 273
 274 ";
 275
 276         if ( $modulemap{$field} ) {
 277             $FieldsPod .= "
 278 =head2 ${field}Obj
 279
 280 Returns the $modulemap{$field} Object which has the id returned by $field
 281
 282
 283 =cut
 284
 285 sub ${field}Obj {
 286         my \$self = shift;
 287         my \$$field =  ${namespace}::$modulemap{$field}->new(\$self->CurrentUser);
 288         \$$field->Load(\$self->__Value('$field'));
 289         return(\$$field);
 290 }
 291 ";
 292             $requirements{ $tablemap{$field} } =
 293               "use ${namespace}::$modulemap{$field};";
 294
 295         }
 296
 297         unless ( $typemap{$field} eq 'auto' || $field eq 'id' ) {
 298
 299             #generate create statement
 300             $CreateInParams .= "                $field => '$default',\n";
 301             $CreateOutParams .=
 302               "                         $field => \$args{'$field'},\n";
 303
 304             #gerenate pod for the create statement
 305             $CreatePod .= "  $type '$field'";
 306             $CreatePod .= " defaults to '$default'" if ($default);
 307             $CreatePod .= ".\n";
 308
 309         }
 310
 311     }
 312
 313     my $Create = "
 314 sub Create {
 315     my \$self = shift;
 316     my \%args = (
 317 $CreateInParams
 318                   \@_);
 319     \$self->SUPER::Create(
 320 $CreateOutParams);
 321
 322 }
 323 ";
 324     $CreatePod .= "\n=cut\n\n";
 325
 326     my $CollectionClass = $LicenseBlock . $Attribution .
 327
 328       "
 329
 330 =head1 NAME
 331
 332   $CollectionClassName -- Class Description
 333
 334 =head1 SYNOPSIS
 335
 336   use $CollectionClassName
 337
 338 =head1 DESCRIPTION
 339
 340
 341 =head1 METHODS
 342
 343 =cut
 344
 345 package $CollectionClassName;
 346
 347 use $CollectionBaseclass;
 348 use $RecordClassName;
 349
 350 use vars qw( \@ISA );
 351 \@ISA= qw($CollectionBaseclass);
 352
 353
 354 sub _Init {
 355     my \$self = shift;
 356     \$self->{'table'} = '$table';
 357     \$self->{'primary_key'} = 'id';
 358
 359 ";
 360
 361     if ( $fields{'SortOrder'} ) {
 362
 363         $CollectionClass .= "
 364
 365   # By default, order by SortOrder
 366   \$self->OrderByCols(
 367          { ALIAS => 'main',
 368            FIELD => 'SortOrder',
 369            ORDER => 'ASC' },
 370          { ALIAS => 'main',
 371            FIELD => 'id',
 372            ORDER => 'ASC' },
 373      );
 374 ";
 375     }
 376     $CollectionClass .= "
 377     return ( \$self->SUPER::_Init(\@_) );
 378 }
 379
 380
 381 =head2 NewItem
 382
 383 Returns an empty new $RecordClassName item
 384
 385 =cut
 386
 387 sub NewItem {
 388     my \$self = shift;
 389     return($RecordClassName->new(\$self->CurrentUser));
 390 }
 391 " . MagicImport($CollectionClassName);
 392
 393     my $RecordClassHeader = $Attribution . "
 394
 395 =head1 NAME
 396
 397 $RecordClassName
 398
 399
 400 =head1 SYNOPSIS
 401
 402 =head1 DESCRIPTION
 403
 404 =head1 METHODS
 405
 406 =cut
 407
 408 package $RecordClassName;
 409 use $RecordBaseclass;
 410 ";
 411
 412     foreach my $key ( keys %requirements ) {
 413         $RecordClassHeader .= $requirements{$key} . "\n";
 414     }
 415     $RecordClassHeader .= "
 416
 417 use vars qw( \@ISA );
 418 \@ISA= qw( $RecordBaseclass );
 419
 420 sub _Init {
 421   my \$self = shift;
 422
 423   \$self->Table('$table');
 424   \$self->SUPER::_Init(\@_);
 425 }
 426
 427 ";
 428
 429     my $RecordClass = $LicenseBlock .  $RecordClassHeader . "
 430
 431 $RecordInit
 432
 433 =head2 Create PARAMHASH
 434
 435 Create takes a hash of values and creates a row in the database:
 436
 437 $CreatePod
 438
 439 $Create
 440
 441 $FieldsPod
 442
 443 sub _CoreAccessible {
 444     {
 445
 446 $ClassAccessible
 447  }
 448 };
 449
 450 " . MagicImport($RecordClassName);
 451
 452     print "About to make $RecordClassPath, $CollectionClassPath\n";
 453     `mkdir -p $path`;
 454
 455     open( RECORD, ">$RecordClassPath" );
 456     print RECORD $RecordClass;
 457     close(RECORD);
 458
 459     open( COL, ">$CollectionClassPath" );
 460     print COL $CollectionClass;
 461     close(COL);
 462
 463 }
 464
 465 sub MagicImport {
 466     my $class = shift;
 467
 468     #if (exists \$warnings::{unimport})  {
 469     #        no warnings qw(redefine);
 470
 471     my $path = $class;
 472     $path =~ s#::#/#gi;
 473
 474
 475     my $content = "
 476         eval \"require @{[$class]}_Overlay\";
 477         if (\$@ && \$@ !~ qr{^Can't locate ".$path."_Overlay.pm}) {
 478             die \$@;
 479         };
 480
 481         eval \"require @{[$class]}_Vendor\";
 482         if (\$@ && \$@ !~ qr{^Can't locate ".$path."_Vendor.pm}) {
 483             die \$@;
 484         };
 485
 486         eval \"require @{[$class]}_Local\";
 487         if (\$@ && \$@ !~ qr{^Can't locate ".$path."_Local.pm}) {
 488             die \$@;
 489         };
 490
 491
 492
 493
 494 =head1 SEE ALSO
 495
 496 This class allows \"overlay\" methods to be placed
 497 into the following files _Overlay is for a System overlay by the original author,
 498 _Vendor is for 3rd-party vendor add-ons, while _Local is for site-local customizations.
 499
 500 These overlay files can contain new subs or subs to replace existing subs in this module.
 501
 502 Each of these files should begin with the line
 503
 504    no warnings qw(redefine);
 505
 506 so that perl does not kick and scream when you redefine a subroutine or variable in your overlay.
 507
 508 @{[$class]}_Overlay, @{[$class]}_Vendor, @{[$class]}_Local
 509
 510 =cut
 511
 512
 513 1;
 514 ";
 515
 516     return $content;
 517 }
 518
 519 # }}}
 520