t/make-modules.t - metacpan.org

#!/usr/bin/perl -w

use strict;

use Test::More();

my $Lib_Dir = 't/cg-lib';

unless(-d $Lib_Dir)
{
  mkdir($Lib_Dir);
}

if(-d $Lib_Dir)
{
  Test::More->import(tests => 2 + (4 * 4));
}
else
{
  Test::More->import(skip_all => "Could not mkdir($Lib_Dir) - $!");
}

require 't/test-lib.pl';
use_ok('Rose::DB::Object');
use_ok('Rose::DB::Object::Loader');

my $Include_Tables = '^(?:' . join('|', 
  qw(product_colors prices products colors vendors)) . ')$';
$Include_Tables = qr($Include_Tables);

my %Column_Defs =
(
  pg => 
  {
    id        => q(id        => { type => 'serial', not_null => 1 },),
    vendor_id => q(vendor_id => { type => 'integer', not_null => 1 },),
  },

  mysql => 
  {
    id        => q(id        => { type => 'serial', not_null => 1 },),
    vendor_id => q(vendor_id => { type => 'integer', default => '', not_null => 1 },),
  },

  sqlite => 
  {
    id        => q(id        => { type => 'serial' },),
    vendor_id => q(vendor_id => { type => 'integer', not_null => 1 },),
  },

  informix => 
  {
    id        => q(id        => { type => 'serial', not_null => 1 },),
    vendor_id => q(vendor_id => { type => 'integer', not_null => 1 },),
  },
);

use Config;

my $Perl = $^X;

if($^O ne 'VMS')
{
  $Perl .= $Config{'_exe'}  unless($Perl =~ /$Config{'_exe'}$/i);
}

#
# Tests
#

foreach my $db_type (qw(pg mysql informix sqlite))
{
  unless(have_db($db_type))
  {
    SKIP: { skip("$db_type tests", 4) }
    next;
  }

  Rose::DB::Object::Metadata->unregister_all_classes;

  Rose::DB->default_type($db_type);

  if($db_type eq 'mysql')
  {
    my $serial = Rose::DB->new->dbh->{'Driver'}{'Version'} >= 4.002 ? 'serial' : 'integer';
    $Column_Defs{'mysql'}{'id'} = qq(id        => { type => '$serial', not_null => 1 },);
  }

  my $class_prefix = 'My' . ucfirst($db_type);

  my $loader = 
    Rose::DB::Object::Loader->new(
    db_class       => 'Rose::DB',
    class_prefix   => $class_prefix,
    module_preamble => "# My Preamble\n",
    module_postamble => 'This will be hidden',
    include_tables => $Include_Tables);

  $loader->make_modules(module_dir   => $Lib_Dir,
                        braces       => 'bsd',
                        indent       => 2,
                        module_postamble => 
                        sub
                        {
                          no warnings 'uninitialized';
                          "# My Postamble for " . $_[0]->class . " ($_[1])\n";
                        });

  my $mylsq_5_51 = ($db_type eq 'mysql' && Rose::DB->new->database_version >= 5_000_051) ? 1 : 0; 

  # XXX: Lame
  if(slurp("$Lib_Dir/$class_prefix/Product.pm") !~ /default => '', /) # $mylsq_5_51
  {
    $Column_Defs{$db_type}{'vendor_id'} =~ s/default => '', //;
  }

  my $unique_keys;

  no warnings 'uninitialized';
  my($v1, $v2, $v3) = split(/\./, $DBD::Pg::VERSION);

  if($db_type eq 'pg' && $v1 >= 2 && $v2 >= 19)
  {
    $unique_keys = qq([ 'name' ],\n    [ 'name', 'vendor_id' ],);
  }
  else
  {
    $unique_keys = qq([ 'name', 'vendor_id' ],\n    [ 'name' ],);
  }

  is(slurp("$Lib_Dir/$class_prefix/Product.pm"), <<"EOF", "Product 1 - $db_type");
# My Preamble
package ${class_prefix}::Product;

use strict;

use base qw(${class_prefix}::DB::Object::AutoBaseNNN);

__PACKAGE__->meta->setup
(
  table   => 'products',

  columns => 
  [
    $Column_Defs{$db_type}{'id'}
    name      => { type => 'varchar', length => 255 },
    $Column_Defs{$db_type}{'vendor_id'}
  ],

  primary_key_columns => [ 'id' ],

  unique_keys => 
  [
    $unique_keys
  ],

  foreign_keys => 
  [
    vendor => 
    {
      class       => '${class_prefix}::Vendor',
      key_columns => { vendor_id => 'id' },
    },
  ],

  relationships => 
  [
    colors => 
    {
      map_class => '${class_prefix}::ProductColor',
      map_from  => 'product',
      map_to    => 'color',
      type      => 'many to many',
    },

    prices => 
    {
      class      => '${class_prefix}::Price',
      column_map => { id => 'product_id' },
      type       => 'one to many',
    },
  ],
);

1;

# My Postamble for ${class_prefix}::Product ()
EOF

  is(slurp("$Lib_Dir/$class_prefix/Product/Manager.pm"), <<"EOF", "Product Manager 1 - $db_type");
# My Preamble
package ${class_prefix}::Product::Manager;

use strict;

use base qw(Rose::DB::Object::Manager);

use ${class_prefix}::Product;

sub object_class { '${class_prefix}::Product' }

__PACKAGE__->make_manager_methods('products');

1;

# My Postamble for ${class_prefix}::Product (${class_prefix}::Product::Manager)
EOF

  is(slurp("$Lib_Dir/$class_prefix/Color.pm"), <<"EOF", "Color 1 - $db_type");
# My Preamble
package ${class_prefix}::Color;

use strict;

use base qw(${class_prefix}::DB::Object::AutoBaseNNN);

__PACKAGE__->meta->setup
(
  table   => 'colors',

  columns => 
  [
    code => { type => 'character', length => 3, not_null => 1 },
    name => { type => 'varchar', length => 255 },
  ],

  primary_key_columns => [ 'code' ],

  unique_key => [ 'name' ],

  relationships => 
  [
    products => 
    {
      map_class => '${class_prefix}::ProductColor',
      map_from  => 'color',
      map_to    => 'product',
      type      => 'many to many',
    },
  ],
);

1;

# My Postamble for ${class_prefix}::Color ()
EOF

  unshift(@INC, $Lib_Dir);

  # Test actual code by running external script with db type arg

  my($ok, $script_fh);

  # Perl 5.8.x and later support the FILEHANDLE,MODE,EXPR,LIST form of 
  # open, but not (apparently) on Windows
  if($Config{'version'} =~ /^5\.([89]|1\d)\./ && $^O !~ /Win32/i)
  {
    $ok = open($script_fh, '-|', $Perl, 't/make-modules.ext', $db_type);
  }
  else
  {
    $ok = open($script_fh, "$Perl t/make-modules.ext $db_type |");
  }

  if($ok)
  {
    chomp(my $line = <$script_fh>);
    close($script_fh);
    is($line, 'V1; IS: 1.25, DE: 4.25; green, red; red: CC1', "external test - $db_type");
  }
  else
  {
    ok(0, "Failed to open external script for $db_type - $!");
  }

  shift(@INC);
}

BEGIN
{
  require 't/test-lib.pl';

  #
  # PostgreSQL
  #

  if(have_db('pg_admin'))
  {
    my $dbh = get_dbh('pg_admin');

    # Drop existing tables, ignoring errors
    {
      local $dbh->{'RaiseError'} = 0;
      local $dbh->{'PrintError'} = 0;
      $dbh->do('DROP TABLE product_colors CASCADE');
      $dbh->do('DROP TABLE prices CASCADE');
      $dbh->do('DROP TABLE products CASCADE');
      $dbh->do('DROP TABLE colors CASCADE');
      $dbh->do('DROP TABLE vendors CASCADE');
    }

    $dbh->do(<<"EOF");
CREATE TABLE vendors
(
  id    SERIAL NOT NULL PRIMARY KEY,
  name  VARCHAR(255)
)
EOF

    $dbh->do(<<"EOF");
CREATE TABLE colors
(
  code  CHAR(3) NOT NULL PRIMARY KEY,
  name  VARCHAR(255),
  UNIQUE(name)
)
EOF

    $dbh->do(<<"EOF");
CREATE TABLE products
(
  id        SERIAL NOT NULL PRIMARY KEY,
  name      VARCHAR(255),
  vendor_id INT NOT NULL REFERENCES vendors (id),

  UNIQUE(name, vendor_id),
  UNIQUE(name)
)
EOF

    $dbh->do(<<"EOF");
CREATE TABLE prices
(
  price_id    SERIAL NOT NULL PRIMARY KEY,
  product_id  INT NOT NULL REFERENCES products (id),
  region      CHAR(2) NOT NULL DEFAULT 'US',
  price       DECIMAL(10,2) NOT NULL
)
EOF

    $dbh->do(<<"EOF");
CREATE TABLE product_colors
(
  id           SERIAL NOT NULL PRIMARY KEY,
  product_id   INT NOT NULL REFERENCES products (id),
  color_code   CHAR(3) NOT NULL REFERENCES colors (code)
)
EOF

    $dbh->disconnect;
  }

  #
  # MySQL
  #

  eval
  {
    my $db = get_db('mysql_admin');
    my $dbh = $db->retain_dbh or die Rose::DB->error;
    my $db_version = $db->database_version;

    die "MySQL version too old"  unless($db_version >= 4_000_000);

    CLEAR:
    {
      local $dbh->{'RaiseError'} = 0;
      local $dbh->{'PrintError'} = 0;
      $dbh->do('DROP TABLE product_colors CASCADE');
      $dbh->do('DROP TABLE prices CASCADE');
      $dbh->do('DROP TABLE products CASCADE');
      $dbh->do('DROP TABLE colors CASCADE');
      $dbh->do('DROP TABLE vendors CASCADE');
    }

    # Foreign key stuff requires InnoDB support
    $dbh->do(<<"EOF");
CREATE TABLE vendors
(
  id    INT AUTO_INCREMENT PRIMARY KEY,
  name  VARCHAR(255)
)
ENGINE=InnoDB
EOF

    # MySQL will silently ignore the "ENGINE=InnoDB" part and create
    # a MyISAM table instead.  MySQL is evil!  Now we have to manually
    # check to make sure an InnoDB table was really created.
    my $db_name = $db->database;
    my $sth = $dbh->prepare("SHOW TABLE STATUS FROM `$db_name` LIKE ?");
    $sth->execute('vendors');
    my $info = $sth->fetchrow_hashref;

    no warnings 'uninitialized';
    unless(lc $info->{'Type'} eq 'innodb' || lc $info->{'Engine'} eq 'innodb')
    {
      die "Missing InnoDB support";
    }
  };

  if($@)
  {
    have_db(mysql_admin => 0);
    have_db(mysql => 0);
  }

  if(have_db('mysql_admin'))
  {
    my $dbh = get_dbh('mysql_admin');

    $dbh->do(<<"EOF");
CREATE TABLE colors
(
  code  CHAR(3) NOT NULL PRIMARY KEY,
  name  VARCHAR(255),
  UNIQUE(name)
)
ENGINE=InnoDB
EOF

    $dbh->do(<<"EOF");
CREATE TABLE products
(
  id        INT AUTO_INCREMENT PRIMARY KEY,
  name      VARCHAR(255),
  vendor_id INT NOT NULL,

  UNIQUE(name, vendor_id),
  UNIQUE(name),

  INDEX(vendor_id),

  FOREIGN KEY (vendor_id) REFERENCES vendors (id)
)
ENGINE=InnoDB
EOF

    $dbh->do(<<"EOF");
CREATE TABLE prices
(
  price_id    INT AUTO_INCREMENT PRIMARY KEY,
  product_id  INT NOT NULL,
  region      CHAR(2) NOT NULL DEFAULT 'US',
  price       DECIMAL(10,2) NOT NULL,

  INDEX(product_id),

  FOREIGN KEY (product_id) REFERENCES products (id)
)
ENGINE=InnoDB
EOF

    $dbh->do(<<"EOF");
CREATE TABLE product_colors
(
  id           INT AUTO_INCREMENT PRIMARY KEY,
  product_id   INT NOT NULL,
  color_code   CHAR(3) NOT NULL,

  INDEX(product_id),
  INDEX(color_code),

  FOREIGN KEY (product_id) REFERENCES products (id),
  FOREIGN KEY (color_code) REFERENCES colors (code)
)
ENGINE=InnoDB
EOF

    $dbh->disconnect;
  }

  #
  # Informix
  #

  if(have_db('informix_admin'))
  {
    my $dbh = get_dbh('informix_admin');

    # Drop existing tables, ignoring errors
    {
      local $dbh->{'RaiseError'} = 0;
      local $dbh->{'PrintError'} = 0;
      $dbh->do('DROP TABLE product_colors CASCADE');
      $dbh->do('DROP TABLE prices CASCADE');
      $dbh->do('DROP TABLE products CASCADE');
      $dbh->do('DROP TABLE colors CASCADE');
      $dbh->do('DROP TABLE vendors CASCADE');
    }

    $dbh->do(<<"EOF");
CREATE TABLE vendors
(
  id    SERIAL NOT NULL PRIMARY KEY,
  name  VARCHAR(255)
)
EOF

    $dbh->do(<<"EOF");
CREATE TABLE colors
(
  code  CHAR(3) NOT NULL PRIMARY KEY,
  name  VARCHAR(255),
  UNIQUE(name)
)
EOF

    $dbh->do(<<"EOF");
CREATE TABLE products
(
  id        SERIAL NOT NULL PRIMARY KEY,
  name      VARCHAR(255),
  vendor_id INT NOT NULL REFERENCES vendors (id),

  UNIQUE(name, vendor_id),
  UNIQUE(name)
)
EOF

    $dbh->do(<<"EOF");
CREATE TABLE prices
(
  price_id    SERIAL NOT NULL PRIMARY KEY,
  product_id  INT NOT NULL REFERENCES products (id),
  region      CHAR(2) DEFAULT 'US' NOT NULL,
  price       DECIMAL(10,2) NOT NULL
)
EOF

    $dbh->do(<<"EOF");
CREATE TABLE product_colors
(
  id           SERIAL NOT NULL PRIMARY KEY,
  product_id   INT NOT NULL REFERENCES products (id),
  color_code   CHAR(3) NOT NULL REFERENCES colors (code)
)
EOF

    $dbh->disconnect;
  }

  #
  # SQLite
  #

  if(have_db('sqlite_admin'))
  {
    my $dbh = get_dbh('sqlite_admin');

    # Drop existing tables, ignoring errors
    {
      local $dbh->{'RaiseError'} = 0;
      local $dbh->{'PrintError'} = 0;
      $dbh->do('DROP TABLE product_colors CASCADE');
      $dbh->do('DROP TABLE prices CASCADE');
      $dbh->do('DROP TABLE products CASCADE');
      $dbh->do('DROP TABLE colors CASCADE');
      $dbh->do('DROP TABLE vendors CASCADE');
    }

    $dbh->do(<<"EOF");
CREATE TABLE vendors
(
  id    INTEGER PRIMARY KEY AUTOINCREMENT,
  name  VARCHAR(255)
)
EOF

    $dbh->do(<<"EOF");
CREATE TABLE colors
(
  code  CHAR(3) NOT NULL PRIMARY KEY,
  name  VARCHAR(255),
  UNIQUE(name)
)
EOF

    $dbh->do(<<"EOF");
CREATE TABLE products
(
  id        INTEGER PRIMARY KEY AUTOINCREMENT,
  name      VARCHAR(255),
  vendor_id INT NOT NULL REFERENCES vendors (id),

  UNIQUE(name, vendor_id),
  UNIQUE(name)
)
EOF

    $dbh->do(<<"EOF");
CREATE TABLE prices
(
  price_id    INTEGER PRIMARY KEY AUTOINCREMENT,
  product_id  INT NOT NULL REFERENCES products (id),
  region      CHAR(2) NOT NULL DEFAULT 'US',
  price       DECIMAL(10,2) NOT NULL
)
EOF

    $dbh->do(<<"EOF");
CREATE TABLE product_colors
(
  id           INTEGER PRIMARY KEY AUTOINCREMENT,
  product_id   INT NOT NULL REFERENCES products (id),
  color_code   CHAR(3) NOT NULL REFERENCES colors (code)
)
EOF

    $dbh->disconnect;
  }
}

sub slurp
{
  my($path) = shift;

  return undef  unless(-e $path);

  open(my $fh, $path) or die "Could not open '$path' - $!";
  my $data = do { local $/; <$fh> };

  # Normalize auto-numbered base classes
  for($data)
  {
    s/::DB::Object::AutoBase\d+/::DB::Object::AutoBaseNNN/g;
    # MySQL 4.1.2 apparently defaults INTEGER NOT NULL columns to 0
    s/default => '0',/default => '',/;
  }

  return $data;
}

END
{
  eval 'require File::Path';

  # Delete the lib dir  
  unless($@)
  {
    File::Path::rmtree($Lib_Dir, 0, 1);
  }

  # Delete test tables

  if(have_db('pg_admin'))
  {
    my $dbh = get_dbh('pg_admin');

    $dbh->do('DROP TABLE product_colors CASCADE');
    $dbh->do('DROP TABLE prices CASCADE');
    $dbh->do('DROP TABLE products CASCADE');
    $dbh->do('DROP TABLE colors CASCADE');
    $dbh->do('DROP TABLE vendors CASCADE');

    $dbh->disconnect;
  }

  if(have_db('mysql_admin'))
  {
    my $dbh = get_dbh('mysql_admin');

    $dbh->do('DROP TABLE product_colors CASCADE');
    $dbh->do('DROP TABLE prices CASCADE');
    $dbh->do('DROP TABLE products CASCADE');
    $dbh->do('DROP TABLE colors CASCADE');
    $dbh->do('DROP TABLE vendors CASCADE');

    $dbh->disconnect;
  }

  if(have_db('informix_admin'))
  {
    my $dbh = get_dbh('informix_admin');

    $dbh->do('DROP TABLE product_colors CASCADE');
    $dbh->do('DROP TABLE prices CASCADE');
    $dbh->do('DROP TABLE products CASCADE');
    $dbh->do('DROP TABLE colors CASCADE');
    $dbh->do('DROP TABLE vendors CASCADE');

    $dbh->disconnect;
  }

  if(have_db('sqlite_admin'))
  {
    my $dbh = get_dbh('sqlite_admin');

    $dbh->do('DROP TABLE product_colors');
    $dbh->do('DROP TABLE prices');
    $dbh->do('DROP TABLE products');
    $dbh->do('DROP TABLE colors');
    $dbh->do('DROP TABLE vendors');

    $dbh->disconnect;
  }
}
	Global
`s`	Focus search bar
`?`	Bring up this help dialog
	GitHub
`g` `p`	Go to pull requests
`g` `i`	go to github issues (only if github is preferred repository)
	POD
`g` `a`	Go to author
`g` `c`	Go to changes
`g` `i`	Go to issues
`g` `d`	Go to dist
`g` `r`	Go to repository/SCM
`g` `s`	Go to source
`g` `b`	Go to file browse
	Search terms
module: (e.g. module:Plugin)
distribution: (e.g. distribution:Dancer auth)
author: (e.g. author:SONGMU Redis)
version: (e.g. version:1.00)