inc/Module/Install/RTx/Factory.pm

   1 #line 1
   2 package Module::Install::RTx::Factory;
   3 use Module::Install::Base; @ISA = qw(Module::Install::Base);
   4
   5 use strict;
   6 use File::Basename ();
   7
   8 sub RTxInitDB {
   9     my ($self, $action) = @_;
  10
  11     unshift @INC, substr(delete($INC{'RT.pm'}), 0, -5) if $INC{'RT.pm'};
  12
  13     require RT;
  14     unshift @INC, "$RT::LocalPath/lib" if $RT::LocalPath;
  15
  16     $RT::SbinPath ||= $RT::LocalPath;
  17     $RT::SbinPath =~ s/local$/sbin/;
  18
  19     foreach my $file ($RT::CORE_CONFIG_FILE, $RT::SITE_CONFIG_FILE) {
  20         next if !-e $file or -r $file;
  21         die "No permission to read $file\n-- please re-run $0 with suitable privileges.\n";
  22     }
  23
  24     RT::LoadConfig();
  25
  26     my $lib_path = File::Basename::dirname($INC{'RT.pm'});
  27     my @args = ("-Ilib");
  28     push @args, "-I$RT::LocalPath/lib" if $RT::LocalPath;
  29     push @args, (
  30         "-I$lib_path",
  31         "$RT::SbinPath/rt-setup-database",
  32         "--action"      => $action,
  33         "--datadir"     => "etc",
  34         (($action eq 'insert') ? ("--datafile"    => "etc/initialdata") : ()),
  35         "--dba"         => $RT::DatabaseUser,
  36         "--prompt-for-dba-password" => ''
  37     );
  38     print "$^X @args\n";
  39     (system($^X, @args) == 0) or die "...returned with error: $?\n";
  40 }
  41
  42 sub RTxFactory {
  43     my ($self, $RTx, $name, $drop) = @_;
  44     my $namespace = "$RTx\::$name";
  45
  46     $self->RTxInit;
  47
  48     my $dbh = $RT::Handle->dbh;
  49     # get all tables out of database
  50     my @tables = $dbh->tables;
  51     my ( %tablemap, %typemap, %modulemap );
  52     my $driver = $RT::DatabaseType;
  53
  54     my $CollectionBaseclass = 'RT::SearchBuilder';
  55     my $RecordBaseclass     = 'RT::Record';
  56     my $LicenseBlock = << '.';
  57 # BEGIN LICENSE BLOCK
  58 #
  59 # END LICENSE BLOCK
  60 .
  61     my $Attribution = << '.';
  62 # Autogenerated by Module::Intall::RTx::Factory
  63 # WARNING: THIS FILE IS AUTOGENERATED. ALL CHANGES TO THIS FILE WILL BE LOST.
  64 #
  65 # !! DO NOT EDIT THIS FILE !!
  66 #
  67
  68 use strict;
  69 .
  70     my $RecordInit = '';
  71
  72     @tables = map { do { {
  73         my $table = $_;
  74         $table =~ s/.*\.//g;
  75         $table =~ s/\W//g;
  76         $table =~ s/^\Q$name\E_//i or next;
  77         $table ne 'sessions' or next;
  78
  79         $table = ucfirst(lc($table));
  80         $table =~ s/$_/\u$_/ for qw(field group custom member value);
  81         $table =~ s/(?<=Scrip)$_/\u$_/ for qw(action condition);
  82         $table =~ s/$_/\U$_/ for qw(Acl);
  83         $table = $name . '_' . $table;
  84
  85         $tablemap{$table}  = $table;
  86         $modulemap{$table} = $table;
  87         if ( $table =~ /^(.*)s$/ ) {
  88             $tablemap{$1}  = $table;
  89             $modulemap{$1} = $1;
  90         }
  91         $table;
  92     } } } @tables;
  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     $typemap{lc($_)} = $typemap{$_} for keys %typemap;
 106
 107     foreach my $table (@tables) {
 108         if ($drop) {
 109             $dbh->do("DROP TABLE $table");
 110             $dbh->do("DROP sequence ${table}_id_seq") if $driver eq 'Pg';
 111             $dbh->do("DROP sequence ${table}_seq") if $driver eq 'Oracle';
 112             next;
 113         }
 114
 115         my $tablesingle = $table;
 116         $tablesingle =~ s/^\Q$name\E_//i;
 117         $tablesingle =~ s/s$//;
 118         my $tableplural = $tablesingle . "s";
 119
 120         if ( $tablesingle eq 'ACL' ) {
 121             $tablesingle = "ACE";
 122             $tableplural = "ACL";
 123         }
 124
 125         my %requirements;
 126
 127         my $CollectionClassName = $namespace . "::" . $tableplural;
 128         my $RecordClassName     = $namespace . "::" . $tablesingle;
 129
 130         my $path = $namespace;
 131         $path =~ s/::/\//g;
 132
 133         my $RecordClassPath     = $path . "/" . $tablesingle . ".pm";
 134         my $CollectionClassPath = $path . "/" . $tableplural . ".pm";
 135
 136         #create a collection class
 137         my $CreateInParams;
 138         my $CreateOutParams;
 139         my $ClassAccessible = "";
 140         my $FieldsPod       = "";
 141         my $CreatePod       = "";
 142         my $CreateSub       = "";
 143         my %fields;
 144         my $sth = $dbh->prepare("DESCRIBE $table");
 145
 146         if ( $driver eq 'Pg' ) {
 147             $sth = $dbh->prepare(<<".");
 148   SELECT a.attname, format_type(a.atttypid, a.atttypmod),
 149          a.attnotnull, a.atthasdef, a.attnum
 150     FROM pg_class c, pg_attribute a
 151    WHERE c.relname ILIKE '$table'
 152          AND a.attnum > 0
 153          AND a.attrelid = c.oid
 154 ORDER BY a.attnum
 155 .
 156         }
 157         elsif ( $driver eq 'mysql' ) {
 158             $sth = $dbh->prepare("DESCRIBE $table");
 159         }
 160         else {
 161             die "$driver is currently unsupported";
 162         }
 163
 164         $sth->execute;
 165
 166         while ( my $row = $sth->fetchrow_hashref() ) {
 167             my ( $field, $type, $default );
 168             if ( $driver eq 'Pg' ) {
 169
 170                 $field   = $row->{'attname'};
 171                 $type    = $row->{'format_type'};
 172                 $default = $row->{'atthasdef'};
 173
 174                 if ( $default != 0 ) {
 175                     my $tth = $dbh->prepare(<<".");
 176 SELECT substring(d.adsrc for 128)
 177   FROM pg_attrdef d, pg_class c
 178  WHERE c.relname = 'acct'
 179        AND c.oid = d.adrelid
 180        AND d.adnum = $row->{'attnum'}
 181 .
 182                     $tth->execute();
 183                     my @default = $tth->fetchrow_array;
 184                     $default = $default[0];
 185                 }
 186
 187             }
 188             elsif ( $driver eq 'mysql' ) {
 189                 $field   = $row->{'Field'};
 190                 $type    = $row->{'Type'};
 191                 $default = $row->{'Default'};
 192             }
 193
 194             $fields{$field} = 1;
 195
 196             #generate the 'accessible' datastructure
 197
 198             if ( $typemap{$field} eq 'auto' ) {
 199                 $ClassAccessible .= "        $field =>
 200                     {read => 1, auto => 1,";
 201             }
 202             elsif ( $typemap{$field} eq 'ro' ) {
 203                 $ClassAccessible .= "        $field =>
 204                     {read => 1,";
 205             }
 206             else {
 207                 $ClassAccessible .= "        $field =>
 208                     {read => 1, write => 1,";
 209
 210             }
 211
 212             $ClassAccessible .= " type => '$type', default => '$default'},\n";
 213
 214             #generate pod for the accessible fields
 215             $FieldsPod .= $self->_pod(<<".");
 216 ^head2 $field
 217
 218 Returns the current value of $field.
 219 (In the database, $field is stored as $type.)
 220
 221 .
 222
 223             unless ( $typemap{$field} eq 'auto' || $typemap{$field} eq 'ro' ) {
 224                 $FieldsPod .= $self->_pod(<<".");
 225
 226 ^head2 Set$field VALUE
 227
 228
 229 Set $field to VALUE.
 230 Returns (1, 'Status message') on success and (0, 'Error Message') on failure.
 231 (In the database, $field will be stored as a $type.)
 232
 233 .
 234             }
 235
 236             $FieldsPod .= $self->_pod(<<".");
 237 ^cut
 238
 239 .
 240
 241             if ( $modulemap{$field} ) {
 242                 $FieldsPod .= $self->_pod(<<".");
 243 ^head2 ${field}Obj
 244
 245 Returns the $modulemap{$field} Object which has the id returned by $field
 246
 247
 248 ^cut
 249
 250 sub ${field}Obj {
 251         my \$self = shift;
 252         my \$$field =  ${namespace}::$modulemap{$field}->new(\$self->CurrentUser);
 253         \$$field->Load(\$self->__Value('$field'));
 254         return(\$$field);
 255 }
 256 .
 257                 $requirements{ $tablemap{$field} } =
 258                 "use ${namespace}::$modulemap{$field};";
 259
 260             }
 261
 262             unless ( $typemap{$field} eq 'auto' || $field eq 'id' ) {
 263
 264                 #generate create statement
 265                 $CreateInParams .= "                $field => '$default',\n";
 266                 $CreateOutParams .=
 267                 "                         $field => \$args{'$field'},\n";
 268
 269                 #gerenate pod for the create statement
 270                 $CreatePod .= "  $type '$field'";
 271                 $CreatePod .= " defaults to '$default'" if ($default);
 272                 $CreatePod .= ".\n";
 273
 274             }
 275
 276         }
 277
 278         $CreateSub = <<".";
 279 sub Create {
 280     my \$self = shift;
 281     my \%args = (
 282 $CreateInParams
 283                 \@_);
 284     \$self->SUPER::Create(
 285 $CreateOutParams);
 286
 287 }
 288 .
 289         $CreatePod .= "\n=cut\n\n";
 290
 291         my $CollectionClass = $LicenseBlock . $Attribution . $self->_pod(<<".") . $self->_magic_import($CollectionClassName);
 292
 293 ^head1 NAME
 294
 295 $CollectionClassName -- Class Description
 296
 297 ^head1 SYNOPSIS
 298
 299 use $CollectionClassName
 300
 301 ^head1 DESCRIPTION
 302
 303
 304 ^head1 METHODS
 305
 306 ^cut
 307
 308 package $CollectionClassName;
 309
 310 use $CollectionBaseclass;
 311 use $RecordClassName;
 312
 313 use vars qw( \@ISA );
 314 \@ISA= qw($CollectionBaseclass);
 315
 316
 317 sub _Init {
 318     my \$self = shift;
 319     \$self->{'table'} = '$table';
 320     \$self->{'primary_key'} = 'id';
 321
 322 .
 323
 324     if ( $fields{'SortOrder'} ) {
 325
 326         $CollectionClass .= $self->_pod(<<".");
 327
 328 # By default, order by name
 329 \$self->OrderBy( ALIAS => 'main',
 330                 FIELD => 'SortOrder',
 331                 ORDER => 'ASC');
 332 .
 333     }
 334     $CollectionClass .= $self->_pod(<<".");
 335     return ( \$self->SUPER::_Init(\@_) );
 336 }
 337
 338
 339 ^head2 NewItem
 340
 341 Returns an empty new $RecordClassName item
 342
 343 ^cut
 344
 345 sub NewItem {
 346     my \$self = shift;
 347     return($RecordClassName->new(\$self->CurrentUser));
 348 }
 349 .
 350
 351     my $RecordClassHeader = $Attribution . "
 352
 353 ^head1 NAME
 354
 355 $RecordClassName
 356
 357
 358 ^head1 SYNOPSIS
 359
 360 ^head1 DESCRIPTION
 361
 362 ^head1 METHODS
 363
 364 ^cut
 365
 366 package $RecordClassName;
 367 use $RecordBaseclass;
 368 ";
 369
 370     foreach my $key ( keys %requirements ) {
 371         $RecordClassHeader .= $requirements{$key} . "\n";
 372     }
 373     $RecordClassHeader .= <<".";
 374
 375 use vars qw( \@ISA );
 376 \@ISA= qw( $RecordBaseclass );
 377
 378 sub _Init {
 379 my \$self = shift;
 380
 381 \$self->Table('$table');
 382 \$self->SUPER::_Init(\@_);
 383 }
 384
 385 .
 386
 387     my $RecordClass = $LicenseBlock . $RecordClassHeader . $self->_pod(<<".") . $self->_magic_import($RecordClassName);
 388
 389 $RecordInit
 390
 391 ^head2 Create PARAMHASH
 392
 393 Create takes a hash of values and creates a row in the database:
 394
 395 $CreatePod
 396
 397 $CreateSub
 398
 399 $FieldsPod
 400
 401 sub _CoreAccessible {
 402     {
 403
 404 $ClassAccessible
 405 }
 406 };
 407
 408 .
 409
 410         print "About to make $RecordClassPath, $CollectionClassPath\n";
 411         `mkdir -p $path`;
 412
 413         open( RECORD, ">$RecordClassPath" );
 414         print RECORD $RecordClass;
 415         close(RECORD);
 416
 417         open( COL, ">$CollectionClassPath" );
 418         print COL $CollectionClass;
 419         close(COL);
 420
 421     }
 422 }
 423
 424 sub _magic_import {
 425     my $self = shift;
 426     my $class = ref($self) || $self;
 427
 428     #if (exists \$warnings::{unimport})  {
 429     #        no warnings qw(redefine);
 430
 431     my $path = $class;
 432     $path =~ s#::#/#gi;
 433
 434
 435     my $content = $self->_pod(<<".");
 436         eval \"require ${class}_Overlay\";
 437         if (\$@ && \$@ !~ qr{^Can't locate ${path}_Overlay.pm}) {
 438             die \$@;
 439         };
 440
 441         eval \"require ${class}_Vendor\";
 442         if (\$@ && \$@ !~ qr{^Can't locate ${path}_Vendor.pm}) {
 443             die \$@;
 444         };
 445
 446         eval \"require ${class}_Local\";
 447         if (\$@ && \$@ !~ qr{^Can't locate ${path}_Local.pm}) {
 448             die \$@;
 449         };
 450
 451
 452
 453
 454 ^head1 SEE ALSO
 455
 456 This class allows \"overlay\" methods to be placed
 457 into the following files _Overlay is for a System overlay by the original author,
 458 _Vendor is for 3rd-party vendor add-ons, while _Local is for site-local customizations.
 459
 460 These overlay files can contain new subs or subs to replace existing subs in this module.
 461
 462 If you'll be working with perl 5.6.0 or greater, each of these files should begin with the line
 463
 464    no warnings qw(redefine);
 465
 466 so that perl does not kick and scream when you redefine a subroutine or variable in your overlay.
 467
 468 ${class}_Overlay, ${class}_Vendor, ${class}_Local
 469
 470 ^cut
 471
 472
 473 1;
 474 .
 475
 476     return $content;
 477 }
 478
 479 sub _pod {
 480     my ($self, $text) = @_;
 481     $text =~ s/^\^/=/mg;
 482     return $text;
 483 }