Parse-Dia-SQL-0.30/0000755000175000017500000000000013105115727011712 5ustar affaffParse-Dia-SQL-0.30/README0000644000175000017500000000177513035770474012614 0ustar affaffDia-SQL Parse::Dia::SQL converts Dia class diagrams into SQL. Dia is a diagram creation program for Linux, Unix and Windows released under the GNU General Public License (GPL). Parse::Dia::SQL is based on tedia2sql by Tim Ellis and others. See the AUTHORS file for details. INSTALLATION To install this module, run the following commands: perl Makefile.PL make make test make install SUPPORT AND DOCUMENTATION After installing, you can find documentation for this module with the perldoc command. perldoc Parse::Dia::SQL You can also look for information at: RT, CPAN's request tracker http://rt.cpan.org/NoAuth/Bugs.html?Dist=Parse-Dia-SQL AnnoCPAN, Annotated CPAN documentation http://annocpan.org/dist/Parse-Dia-SQL CPAN Ratings http://cpanratings.perl.org/d/Parse-Dia-SQL Search CPAN http://search.cpan.org/dist/Parse-Dia-SQL COPYRIGHT AND LICENCE Copyright (C) 2008 Andreas Faafeng This program is released under the following license: GPL Parse-Dia-SQL-0.30/Makefile.PL0000644000175000017500000000344513105114662013667 0ustar affaffuse strict; use warnings; require 5.006; use ExtUtils::MakeMaker; my %args = ( NAME => 'Parse::Dia::SQL', AUTHOR => 'Andreas Faafeng ', VERSION_FROM => 'lib/Parse/Dia/SQL.pm', ABSTRACT_FROM => 'lib/Parse/Dia/SQL.pm', EXE_FILES => ['bin/parsediasql'], PL_FILES => {}, LICENSE => 'gpl', META_MERGE => { resources => { repository => 'https://github.com/aff/Parse-Dia-SQL', }, keywords => [ qw [Parse Dia SQL DDL RDBMS DB2 Informix Ingres InnoDB MyISAM MySQL Oracle Postgres SQLite3 Sas Sybase] ], }, BUILD_REQUIRES => { 'CPAN::Meta' => 0, }, PREREQ_PM => { 'Data::Dumper' => 0, 'Digest::MD5' => 0, 'Fatal' => 0, 'File::Find' => 0, 'File::Spec::Functions' => 0, 'File::Temp' => 0, 'Getopt::Long' => 0, 'HTML::Lint' => 0, 'IO::All' => 0, 'IO::Uncompress::Gunzip' => 0, 'Log::Log4perl' => 0, 'POSIX' => 0, 'Test::Exception' => 0, 'Test::More' => 0, 'Text::Table' => 0, 'XML::DOM' => 0, }, dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, clean => { FILES => 'Parse-Dia-SQL-*' }, ); # Use args according to installed version of ExtUtils::MM my %filter = ( MIN_PERL_VERSION => '6.48', LICENSE => '6.48', META_MERGE => '6.46', AUTHOR => '6.07', ABSTRACT_FROM => '6.07', ); delete $args {$_} for grep {defined $filter {$_} && $ExtUtils::MakeMaker::VERSION lt $filter {$_}} keys %args; WriteMakefile %args; __END__ Parse-Dia-SQL-0.30/AUTHORS0000644000175000017500000000152013035770474012770 0ustar affaff Contributing Authors to-date: Tim Ellis -- Main program, general direction -- mailto: ttiimmeelleessss at tigris dot org Martin Gebert, Edward Epstein -- MySQL InnoDB support and Constraint enforcement Andrew S. Halper -- Ingres Support Greg Copeland -- Bug fixes & patches Christopher Bowland -- Windows-without-Cygwin fixes Peter Lamb -- UML mode and automatic generation of PK, FK and join tables Martin Bögelund -- SAS DB Support (mainly fixing SQL comment style) Neal Stephenson -- Macro expasion support (small objects defined once for many tables) Paul Suda -- Auto-increment MySQL support Mike Ginou -- Debian friendliness and drop index support Norbert Volf -- Comments for PostgreSQL support Patryk Sciborek -- Datatype equivalence generic algorithm Andreas Faafeng -- CPAN rewrite, test suite. Peter Langton -- SQLite3, HTML support. Parse-Dia-SQL-0.30/installer/0000755000175000017500000000000013105115727013707 5ustar affaffParse-Dia-SQL-0.30/installer/parsediasql-setup.nsi0000755000175000017500000001445613035770476020117 0ustar affaff# Parse-Dia-Sql - Convert Dia class diagrams into SQL # # Copyright (C) 2009-2012 Steffen Macke # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # NOTE: this .NSI script is designed for NSIS v2.0 Name Parse-Dia-Sql SetCompressor lzma # Defines !define REGKEY "SOFTWARE\$(^Name)" !define VERSION 0.23.0 !define COMPANY "The Parse-Dia-Sql developers" !define URL http://dia-installer.de/parse-dia-sql/ # MUI defines !define MUI_ICON "${NSISDIR}\Contrib\Graphics\Icons\orange-install.ico" !define MUI_FINISHPAGE_NOAUTOCLOSE !define MUI_STARTMENUPAGE_REGISTRY_ROOT HKLM !define MUI_STARTMENUPAGE_REGISTRY_KEY ${REGKEY} !define MUI_STARTMENUPAGE_REGISTRY_VALUENAME StartMenuGroup !define MUI_STARTMENUPAGE_DEFAULTFOLDER Parse-Dia-Sql !define MUI_UNICON "${NSISDIR}\Contrib\Graphics\Icons\orange-uninstall.ico" !define MUI_UNFINISHPAGE_NOAUTOCLOSE !define MUI_FINISHPAGE_LINK "dia-installer.de/parse-dia-sql" !define MUI_FINISHPAGE_LINK_LOCATION "http://dia-installer.de/parse-dia-sql/" # Included files !include Sections.nsh !include MUI.nsh !include Library.nsh !include WinVer.nsh # Variables Var StartMenuGroup # Installer pages !insertmacro MUI_PAGE_WELCOME !insertmacro MUI_PAGE_LICENSE ..\LICENSE !insertmacro MUI_PAGE_DIRECTORY !insertmacro MUI_PAGE_STARTMENU Application $StartMenuGroup !insertmacro MUI_PAGE_INSTFILES !insertmacro MUI_PAGE_FINISH !insertmacro MUI_UNPAGE_CONFIRM !insertmacro MUI_UNPAGE_INSTFILES !insertmacro MUI_LANGUAGE English # Installer attributes OutFile parse-dia-sql-setup-${VERSION}.exe InstallDir $PROGRAMFILES\Parse-Dia-Sql CRCCheck on XPStyle on ShowInstDetails show VIProductVersion ${VERSION}.0 VIAddVersionKey /LANG=${LANG_ENGLISH} ProductName Parse-Dia-SQL VIAddVersionKey /LANG=${LANG_ENGLISH} ProductVersion "${VERSION}" VIAddVersionKey /LANG=${LANG_ENGLISH} CompanyName "${COMPANY}" VIAddVersionKey /LANG=${LANG_ENGLISH} CompanyWebsite "${URL}" VIAddVersionKey /LANG=${LANG_ENGLISH} FileVersion "${VERSION}" VIAddVersionKey /LANG=${LANG_ENGLISH} FileDescription "" VIAddVersionKey /LANG=${LANG_ENGLISH} LegalCopyright "" InstallDirRegKey HKLM "${REGKEY}" Path ShowUninstDetails show # Installer sections Section -Main SEC0000 SetOutPath $INSTDIR\bin SetOverwrite on File parsediasql.exe File C:\strawberry\c\bin\libstdc++-6.dll File C:\strawberry\c\bin\libexpat-1_.dll File c:\strawberry\c\bin\LIBGCC_S_SJLJ-1.DLL SetOutPath $INSTDIR File ..\LICENSE File /oname=LIBEXPAT_COPYING C:\strawberry\licenses\libexpat\COPYING SectionEnd Section -post SEC0001 WriteRegStr HKLM "${REGKEY}" Path $INSTDIR SetOutPath $INSTDIR WriteUninstaller $INSTDIR\uninstall-parse-dia-sql.exe SetOutPath $SMPROGRAMS\$StartMenuGroup CreateShortcut "$SMPROGRAMS\$StartMenuGroup\Parse-Dia-Sql command line.lnk" $SYSDIR\cmd.exe "/K PATH=%PATH%;$INSTDIR\bin" WriteRegStr HKLM "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\$(^Name)" DisplayName "$(^Name)" WriteRegStr HKLM "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\$(^Name)" DisplayVersion "${VERSION}" WriteRegStr HKLM "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\$(^Name)" Publisher "${COMPANY}" WriteRegStr HKLM "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\$(^Name)" URLInfoAbout "${URL}" WriteRegStr HKLM "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\$(^Name)" DisplayIcon $INSTDIR\uninstall-parse-dia-sql.exe WriteRegStr HKLM "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\$(^Name)" UninstallString $INSTDIR\uninstall-parse-dia-sql.exe WriteRegDWORD HKLM "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\$(^Name)" NoModify 1 WriteRegDWORD HKLM "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\$(^Name)" NoRepair 1 SectionEnd # Macro for selecting uninstaller sections !macro SELECT_UNSECTION SECTION_NAME UNSECTION_ID Push $R0 ReadRegStr $R0 HKLM "${REGKEY}\Components" "${SECTION_NAME}" StrCmp $R0 1 0 next${UNSECTION_ID} !insertmacro SelectSection "${UNSECTION_ID}" GoTo done${UNSECTION_ID} next${UNSECTION_ID}: !insertmacro UnselectSection "${UNSECTION_ID}" done${UNSECTION_ID}: Pop $R0 !macroend # Uninstaller sections Section "Uninstall" Delete /REBOOTOK $INSTDIR\bin\parsediasql.exe Delete /REBOOTOK $INSTDIR\bin\libstdc++-6.dll Delete /REBOOTOK $INSTDIR\bin\libexpat-1_.dll Delete /REBOOTOK $INSTDIR\bin\LIBGCC_S_SJLJ-1.DLL Delete /REBOOTOK $INSTDIR\LICENSE Delete /REBOOTOK $INSTDIR\LIBEXPAT_COPYING DeleteRegValue HKLM "${REGKEY}\Components" Main DeleteRegKey HKLM "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\$(^Name)" Delete /REBOOTOK "$SMPROGRAMS\$MUI_STARTMENUPAGE_DEFAULTFOLDER\Parse-Dia-Sql command line.lnk" Delete /REBOOTOK $INSTDIR\uninstall-parse-dia-sql.exe DeleteRegValue HKLM "${REGKEY}" StartMenuGroup DeleteRegValue HKLM "${REGKEY}" Path DeleteRegKey /IfEmpty HKLM "${REGKEY}\Components" DeleteRegKey /IfEmpty HKLM "${REGKEY}" RmDir /REBOOTOK $SMPROGRAMS\$MUI_STARTMENUPAGE_DEFAULTFOLDER RmDir /REBOOTOK $INSTDIR\bin RmDir /REBOOTOK $INSTDIR Push $R0 StrCpy $R0 $StartMenuGroup 1 StrCmp $R0 ">" no_smgroup no_smgroup: Pop $R0 SectionEnd # Installer functions Function .onInit InitPluginsDir ${If} ${AtLeastWin7} ${Else} MessageBox MB_OK "Windows 7 or higher is required for this Parse-Dia-Sql version." Abort "Windows 7 or higher is required for this Parse-Dia-Sql version." ${EndIf} FunctionEnd # Uninstaller functions Function un.onInit ReadRegStr $INSTDIR HKLM "${REGKEY}" Path !insertmacro MUI_STARTMENU_GETFOLDER Application $StartMenuGroup FunctionEnd Parse-Dia-SQL-0.30/MANIFEST0000644000175000017500000001033213105115727013042 0ustar affaffAUTHORS bin/parsediasql Changes installer/parsediasql-setup.nsi lib/Parse/Dia/SQL.pm lib/Parse/Dia/SQL/Const.pm lib/Parse/Dia/SQL/Logger.pm lib/Parse/Dia/SQL/Output.pm lib/Parse/Dia/SQL/Output/DB2.pm lib/Parse/Dia/SQL/Output/HTML.pm lib/Parse/Dia/SQL/Output/Informix.pm lib/Parse/Dia/SQL/Output/Ingres.pm lib/Parse/Dia/SQL/Output/MySQL.pm lib/Parse/Dia/SQL/Output/MySQL/InnoDB.pm lib/Parse/Dia/SQL/Output/MySQL/MyISAM.pm lib/Parse/Dia/SQL/Output/Oracle.pm lib/Parse/Dia/SQL/Output/Postgres.pm lib/Parse/Dia/SQL/Output/Sas.pm lib/Parse/Dia/SQL/Output/SQLite3.pm lib/Parse/Dia/SQL/Output/SQLite3fk.pm lib/Parse/Dia/SQL/Output/Sybase.pm lib/Parse/Dia/SQL/Utils.pm LICENSE Makefile.PL MANIFEST MANIFEST.SKIP README t/000-load.t t/001-new.t t/100-parse-small-packages.t t/201-parse-classes.t t/202-parse-classes-type.t t/203-parse-classes-attlist.t t/204-parse-classes-atts.t t/205-parse-classes-pk.t t/206-parse-classes-uindxc.t t/207-parse-classes-uindxn.t t/208-parse-classes-ops.t t/210-check-versions.t t/211-parse-versions.t t/220-parse-classes-database.t t/225-parse-classes-pk.t t/300-parse-classes-many-to-many.t t/400-parse-typemap.t t/500-get-associations.t t/501-get-associations-implicit.t t/502-get-associations_version_2.t t/600-output-load.t t/610-output-getinstance.t t/611-output-format-columns.t t/612-output-get-comment.t t/620-output-get-schema-create-col-comment.t t/620-output-get-schema-create-db-model-nullable.t t/620-output-get-schema-create-db-model.t t/620-output-get-schema-create-many-to-many.t t/620-output-get-schema-create.t t/621-output-get-create-table-sql.t t/621-output-get-schema-create-many-to-many-uml.t t/621-output-get-schema-create-mysql-innodb-backticks.t t/622-output-get-create-view-sql.t t/623-output-get-view-create.t t/640-output-get-schema-drop-sql.t t/641-output-get-drop-view-sql.t t/642-output-get-drop-associations-sql.t t/643-output-get-drop-permissions-sql-innodb-backticks.t t/643-output-get-drop-permissions-sql.t t/644-output-mysql-get-drop-index-sql.t t/645-output-ingres-get-drop-index-sql.t t/645-output-mysql-innodb-get-drop-index-sql.t t/646-output-get-schema-drop-sql-mysql-innodb.t t/650-output-get-create-associations-many-to-many-097.t t/650-output-get-create-associations-many-to-many.t t/650-output-get-create-associations.t t/651-output-get-create-associations-sybase.t t/652-output-get-create-associations-index-options.t t/660-output-get-create-permissions-sql-innodb-backticks.t t/660-output-get-create-permissions-sql.t t/670-output-get-pre-sql.t t/671-output-get-post-sql.t t/672-output-get-inserts.t t/680-output-db2-create-pk-string.t t/681-output-db2-get-sql.t t/682-output-sybase-get-sql.t t/683-output-oracle-get-sql.t t/684-output-ingres-get-sql.t t/685-output-postgres-get-sql.t t/686-output-sas-get-sql.t t/687-output-mysql-innodb-get-sql-alter-table-backticks.t t/687-output-mysql-innodb-get-sql.t t/688-output-mysql-myisam-get-sql.t t/689-output-db2-create-constraint-name.t t/689-output-mysql-innodb-get-sql-comment.t t/690-output-sqlite3-get-sql.t t/691-output-html-get-sql.t t/692-output-sqlite3fk-get-sql.t t/700-utils-load.t t/701-utils-mangle-name.t t/702-utils-make-name.t t/703-utils-get-base-name.t t/704-utils-split-type.t t/710-const-load.t t/720-logger-load.t t/900-boilerplate.t t/901-pod-coverage.t t/902-pod.t t/903-perlcritic.t t/904-kwalitee.t t/905-strict.t t/906-cover.t t/907-test-explicit-plan.t t/950-rt51433.t t/951-rt50906.t t/952-rt52755.t t/953-rt53783-postgres.t t/953-rt53783-sqlite3.t t/960-rt56357-database-model.t t/961-rt57182-charset.t t/962-rt57842-postsgres-int.t t/963-rt66031.t t/data/association_dia_0_97.dia t/data/db-model-fk.dia t/data/db2.pre.dupe.dia t/data/implicit_role.dia t/data/index.option.dia t/data/long_fk_name.dia t/data/many_to_many.097.dia t/data/many_to_many.dia t/data/non-latin1-chars.dia t/data/nullable.dia t/data/rt50906.dia t/data/rt51433.dia t/data/rt52755.dia t/data/rt53783.dia t/data/rt56357.dia t/data/rt57842.dia t/data/rt66031.dia t/data/table.col.comment.dia t/data/table_output_options.dia t/data/TestERD.dia t/data/typemap.dia t/data/version.supported.dia t/data/version.unsupported.dia TODO META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Parse-Dia-SQL-0.30/bin/0000755000175000017500000000000013105115727012462 5ustar affaffParse-Dia-SQL-0.30/bin/parsediasql0000644000175000017500000000512113035770476014726 0ustar affaff#!perl # $Id: parsediasql,v 1.10 2011/02/16 10:23:11 aff Exp $ use strict; use warnings; use Getopt::Long; use Pod::Usage; use lib q{lib}; use Parse::Dia::SQL; my $help = undef; my $file = undef; my $ignore_type_mismatch = undef; my $db = undef; my $uml = undef; my $loglevel = undef; my $backticks = undef; my $htmlformat = undef; GetOptions( "help|?" => \$help, "file=s" => \$file, "db=s" => \$db, "uml" => \$uml, "loglevel=s" => \$loglevel, "backticks=i" => \$backticks, "ignore_type_mismatch" => \$ignore_type_mismatch, "htmlformat=s" => \$htmlformat, ) or pod2usage(2); pod2usage(1) if $help; pod2usage(qq{Missing argument 'file'}) if !$file; pod2usage(qq{Missing argument 'db'}) if !$db; my $dia = Parse::Dia::SQL->new( file => $file, db => $db, ignore_type_mismatch => $ignore_type_mismatch, uml => $uml, loglevel => $loglevel, backticks => $backticks, htmlformat => $htmlformat, ); print $dia->get_sql(); __END__ =pod =head1 NAME parsediasql - Command-line interface to Parse::Dia::SQL =head1 SYNOPSIS parsediasql [OPTIONS] --file FILE --db DB =head1 OPTIONS file - Filename of Dia file db - Database type (e.g. 'db2') ignore_type_mismatch - Allows foreign keys to have a different type than the primary key it references, if true. Default false. uml - Use UML interpretation of the diagram, default is ERD interpretation. loglevel - Log verbosity, valid values are DEBUG|INFO|WARN|ERROR|FATAL|TRACE|ALL|OFF. backticks - Use `backtick` notation (mysql-innodb only). htmlformat - Optional custom format file (html only). =head1 DESCRIPTION Dia is a diagram creation program for Linux, Unix and Windows released under the GPL license. parsediasql is a Command-line interface to Parse::Dia::SQL Parse::Dia::SQL converts Dia class diagrams into SQL. =head1 TODO =over =item * Add options that correspond to %param in Parse::Dia::SQL::new =back =head1 SEE ALSO Parse::Dia::SQL =head1 AUTHOR Parse::Dia::SQL is based on I by Tim Ellis and others. See the I file for details. Modified by Andreas Faafeng, C<< >> for release on CPAN. =cut Parse-Dia-SQL-0.30/META.yml0000664000175000017500000000210213105115727013160 0ustar affaff--- abstract: 'Convert Dia class diagrams into SQL.' author: - 'Andreas Faafeng ' build_requires: CPAN::Meta: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.0401, CPAN::Meta::Converter version 2.150005' keywords: - Parse - Dia - SQL - DDL - RDBMS - DB2 - Informix - Ingres - InnoDB - MyISAM - MySQL - Oracle - Postgres - SQLite3 - Sas - Sybase license: open_source meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Parse-Dia-SQL no_index: directory: - t - inc requires: Data::Dumper: '0' Digest::MD5: '0' Fatal: '0' File::Find: '0' File::Spec::Functions: '0' File::Temp: '0' Getopt::Long: '0' HTML::Lint: '0' IO::All: '0' IO::Uncompress::Gunzip: '0' Log::Log4perl: '0' POSIX: '0' Test::Exception: '0' Test::More: '0' Text::Table: '0' XML::DOM: '0' resources: repository: https://github.com/aff/Parse-Dia-SQL version: '0.30' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Parse-Dia-SQL-0.30/t/0000755000175000017500000000000013105115727012155 5ustar affaffParse-Dia-SQL-0.30/t/652-output-get-create-associations-index-options.t0000644000175000017500000000261413035770477023543 0ustar affaff# $Id: 652-output-get-create-associations-index-options.t,v 1.2 2009/05/16 12:24:28 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use Test::Exception; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 10; use_ok ('Parse::Dia::SQL'); my $diasql = Parse::Dia::SQL->new( file => catfile(qw(t data index.option.dia)), db => 'db2' ); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); ok $diasql->convert(); # Output my $output = undef; isa_ok($diasql, 'Parse::Dia::SQL'); lives_ok(sub { $output = $diasql->get_output_instance(); }, q{get_output_instance (db2) should not die}); isa_ok($output, 'Parse::Dia::SQL::Output') or diag(Dumper($output)); isa_ok($output, 'Parse::Dia::SQL::Output::DB2') or diag(Dumper($output)); can_ok($output, 'get_associations_create'); # associations = foreign keys + indices my $association_str = $output->get_associations_create(); # Check for index option like($association_str, qr|.* create \s+ index \s+ \w+ \s+ on \s+ foo \s* \( \s* \w+, \w+ \s* \) \s* disallow \s+ reverse \s+ scans \s* (;)? .* |six, q{Expect index option "disallow reverse scans" on table foo}); like($association_str, qr|.* create \s+ index \s+ \w+ \s+ on \s+ bar \s* \( \s* \w+, \w+ \s* \) \s* allow \s+ reverse \s+ scans \s* (;)? .* |six, q{Expect default index option "allow reverse scans" on table bar}); __END__ Parse-Dia-SQL-0.30/t/671-output-get-post-sql.t0000644000175000017500000000220713035770477016566 0ustar affaff# $Id: 671-output-get-post-sql.t,v 1.4 2009/02/25 08:43:31 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use Test::Exception; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 11; use lib q{lib}; use_ok ('Parse::Dia::SQL'); use_ok ('Parse::Dia::SQL::Output'); use_ok ('Parse::Dia::SQL::Output::DB2'); my $diasql = Parse::Dia::SQL->new( files => [catfile(qw(t data TestERD.dia))], db => 'db2' ); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); # Parse and convert cmp_ok($diasql->convert(), q{==}, 1,q{Expect convert to return 1}); my $output = undef; isa_ok($diasql, 'Parse::Dia::SQL'); lives_ok(sub { $output = $diasql->get_output_instance(); }, q{get_output_instance (db2) should not die}); isa_ok($output, 'Parse::Dia::SQL::Output') or diag(Dumper($output)); isa_ok($output, 'Parse::Dia::SQL::Output::DB2') or diag(Dumper($output)); can_ok($output, 'get_smallpackage_post_sql'); my $postsql = $output->get_smallpackage_post_sql(); is($postsql,q[-- statements to do AFTER creating -- the tables (schema) --drop trigger . . . . --create trigger . . . .]); __END__ Parse-Dia-SQL-0.30/t/621-output-get-create-table-sql.t0000644000175000017500000001072013035770477020123 0ustar affaff# $Id: 621-output-get-create-table-sql.t,v 1.4 2009/02/28 06:54:57 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use Test::Exception; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 9; use lib q{lib}; use_ok ('Parse::Dia::SQL'); use_ok ('Parse::Dia::SQL::Output'); use_ok ('Parse::Dia::SQL::Output::DB2'); # 1. pre-parsed input for simplicity and speed. # $table is here a hash ref containing one class ('extremes') my $table = { 'name' => 'extremes', 'type' => 'table', 'atts' => { 'maxval' => [ 'maxVal', 'numeric (15)', '', '0', undef ], 'fmorg' => [], 'minval' => [ 'minVal', 'numeric (15)', '', '0', undef ], 'public' => [], 'name' => [ 'name', 'varchar (32)', '', '2', undef ], 'colname' => [ 'colName', 'varchar (64)', '', '0', undef ] }, 'ops' => [ [ 'select', 'grant', ['public'], '', undef ], [ 'all', 'grant', ['fmorg'], '', undef ] ], 'uindxn' => {}, 'pk' => [ [ 'name', 'varchar (32)', '', '2', undef ], ], 'uindxc' => {}, 'attList' => [ [ 'name', 'varchar (32)', '', '2', undef ], [ 'colName', 'varchar (64)', '', '0', undef ], [ 'minVal', 'numeric (15)', '', '0', undef ], [ 'maxVal', 'numeric (15)', '', '0', undef ] ], }; my $diasql = Parse::Dia::SQL->new(db => 'db2'); my $output = undef; isa_ok($diasql, 'Parse::Dia::SQL'); # Fool Parse::Dia::SQL into thinking convert() was called $diasql->{converted} = 1; lives_ok(sub { $output = $diasql->get_output_instance(); }, q{get_output_instance (db2) should not die}); isa_ok($output, 'Parse::Dia::SQL::Output::DB2') or diag(Dumper($output)); can_ok($output, 'get_schema_create'); my $create_table = $output->_get_create_table_sql($table); #diag($create_table); like($create_table, qr|.* create \s+ table \s+ extremes \s* \( \s+ name \s+ varchar \s* \(32\) \s+ not \s+ null \s* , \s+ colName \s+ varchar \s* \(64\) \s* , \s+ minVal \s+ numeric \s* \(15\) \s* , \s+ maxVal \s+ numeric \s* \(15\) \s* , \s+ constraint \s+ pk_\w+ \s+ primary \s+ key \s* \(name\) \s* \) \s* (;)? .*|six, q{Check syntax for sql create table extremes}); # Test for table where column ('host') is both pk and marked 'not null': my $table2 = { 'atts' => { 'nrecv' => [ 'nrecv', 'integer', '0', '0', '' ], 'level' => [ 'level', 'integer', '0', '0', '' ], 'status' => [ 'status', 'varchar(20)', '', '0', '' ], 'time' => [ 'time', 'timestamp', 'not null', '0', '' ], 'host' => [ 'host', 'varchar(20)', 'not null', '2', '' ], 'gui' => [ 'gui', 'integer', '0', '0', '' ], 'rate' => [ 'rate', 'timestamp', 'not null', '0', '' ], 'nsent' => [ 'nsent', 'integer', '0', '0', '' ], 'id' => [ 'id', 'bigint', 'not null', '0', '' ] }, 'ops' => [ [ 'idx_node_id', 'index', ['id'], '', '' ], [ 'idx_node_host_rate', 'index', [ 'host', 'rate' ], '', '' ] ], 'uindxn' => {}, 'pk' => [ [ 'host', 'varchar(20)', 'not null', '2', '' ] ], 'name' => 'node', 'uindxc' => {}, 'attList' => [ [ 'id', 'bigint', 'not null', '0', '' ], [ 'host', 'varchar(20)', 'not null', '2', '' ], [ 'time', 'timestamp', 'not null', '0', '' ], [ 'level', 'integer', '0', '0', '' ], [ 'gui', 'integer', '0', '0', '' ], [ 'rate', 'timestamp', 'not null', '0', '' ], [ 'nrecv', 'integer', '0', '0', '' ], [ 'nsent', 'integer', '0', '0', '' ], [ 'status', 'varchar(20)', '', '0', '' ], ], 'type' => 'table' }; my $create_table2 = $output->_get_create_table_sql($table2); #diag($create_table2); like($create_table2, qr|.* create \s+ table \s+ node \s* \( \s* id \s+ bigint \s+ not \s+ null \s* , \s+ host \s+ varchar \s* \( \s* 20 \s* \) \s* \s+ not \s+ null \s* , \s+ time \s+ timestamp \s+ not \s+ null \s* , \s+ level \s+ integer \s+ default \s+ 0 \s* , \s+ gui \s+ integer \s+ default \s+ 0 \s* , \s+ rate \s+ timestamp \s+ not \s+ null \s* , \s+ nrecv \s+ integer \s+ default \s+ 0 \s* , \s+ nsent \s+ integer \s+ default \s+ 0 \s* , \s+ status \s+ varchar \s* \( \s* 20 \s* \) \s* \s* , \s+ constraint \s+ pk_node \s+ primary \s+ key \s+ \s* \( \s* host \s* \) \s* \) \s* (;)? .*|six, q{Check syntax for column both pk and marked 'not null':}); __END__ Parse-Dia-SQL-0.30/t/684-output-ingres-get-sql.t0000644000175000017500000000150213035770477017071 0ustar affaff# $Id: 684-output-ingres-get-sql.t,v 1.3 2009/02/28 06:54:57 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use Test::Exception; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 7; diag 'Ingres support is experimental'; use lib q{lib}; use_ok ('Parse::Dia::SQL'); use_ok ('Parse::Dia::SQL::Output'); use_ok ('Parse::Dia::SQL::Output::Ingres'); my $diasql = Parse::Dia::SQL->new(file => catfile(qw(t data TestERD.dia)), db => 'ingres'); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); is($diasql->convert(), 1, q{Expect convert() == 1}); can_ok($diasql, q{get_output_instance}); my $subclass = $diasql->get_output_instance(); isa_ok( $subclass, q{Parse::Dia::SQL::Output::Ingres}, q{Expect a Parse::Dia::SQL::Output::Ingres object} ); __END__ Parse-Dia-SQL-0.30/t/905-strict.t0000644000175000017500000000063613035770500014170 0ustar affaff # $Id: 905-strict.t,v 1.1 2009/02/23 07:36:17 aff Exp $ use strict; use warnings; use Test::More; use File::Spec::Functions; use lib catdir qw ( blib lib ); BEGIN { plan( skip_all => 'AUTHOR_TEST must be set for boilerplate test; skipping' ) if ( !$ENV { 'AUTHOR_TEST' } ); eval "use Test::Strict"; plan( skip_all => 'Test::Strict not installed; skipping' ) if $@; } all_perl_files_ok(); __END__ Parse-Dia-SQL-0.30/t/689-output-db2-create-constraint-name.t0000644000175000017500000000676013035770477021260 0ustar affaff# $Id: 689-output-db2-create-constraint-name.t,v 1.3 2009/03/16 08:45:03 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use Test::Exception; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 39; use lib q{lib}; use_ok ('Parse::Dia::SQL'); use_ok ('Parse::Dia::SQL::Output'); use_ok ('Parse::Dia::SQL::Output::DB2'); # 1. parse input - although it is not used here my $db = 'db2'; my $diasql = Parse::Dia::SQL->new( file => catfile(qw(t data long_fk_name.dia)), db => $db ); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); is($diasql->convert(), 1, q{Expect convert to return 1}); # 2. output my $output = undef; isa_ok($diasql, 'Parse::Dia::SQL'); lives_ok(sub { $output = $diasql->get_output_instance(); }, q{get_output_instance (db2) should not die}); isa_ok($output, 'Parse::Dia::SQL::Output') or diag(Dumper($output)); isa_ok($output, 'Parse::Dia::SQL::Output::DB2') or diag(Dumper($output)); can_ok($output, '_create_constraint_name'); my $OBJECT_NAME_MAX_LENGTH = 18; # Check tablename of various length - the pk should be $OBJECT_NAME_MAX_LENGTH chars or less (DB2) ok(!defined($output->_create_constraint_name()), q{return undef on undef}); ok(!defined($output->_create_constraint_name('')), q{return undef on empty}); is($output->_create_constraint_name(q{less_than_18}), q{less_than_18}, q{Expect 'less_than_18'}); is($output->_create_constraint_name(q{fk_rule_rule_type_id}), q{fk_rl_rl_typ_d}, q{Expect 'fk_rl_rl_typ_d'}); foreach my $fk ( qw( fk_rule_rule_type_id fk_prof_auth_container_id fk_prof_pres_container_id fk_prof_cb_container_id fk_prof_retr_container_id fk_workflow_type_id fk_wf_datasrc_type_id very_very_very_very_very_very_very_very_very_very_very_long_string )) { cmp_ok(length($output->_create_constraint_name($fk)), q{<=}, $OBJECT_NAME_MAX_LENGTH, qq{$fk Expect length below or equal to $OBJECT_NAME_MAX_LENGTH}); #diag ($fk . " -> " . $output->_create_constraint_name($fk) ); ## uncomment to se the conversion } undef $diasql; undef $output; # No switch to a non-DB2 database and expect constraint_name to be preserved my $diasql2 = Parse::Dia::SQL->new( file => catfile(qw(t data long_fk_name.dia)), db => 'mysql-innodb' ); isa_ok($diasql2, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); is($diasql2->convert(), 1, q{Expect convert to return 1}); # 2. output my $output2 = undef; isa_ok($diasql2, 'Parse::Dia::SQL'); lives_ok(sub { $output2 = $diasql2->get_output_instance(); }, q{get_output_instance (db2) should not die}); isa_ok($output2, 'Parse::Dia::SQL::Output') or diag(Dumper($output2)); isa_ok($output2, 'Parse::Dia::SQL::Output::MySQL::InnoDB') or diag(Dumper($output2)); can_ok($output2, '_create_constraint_name'); # Check tablename of various length - the pk should be preserved (MySQL InnoDB) ok(!defined($output2->_create_constraint_name()), q{return undef on undef}); ok(!defined($output2->_create_constraint_name('')), q{return undef on empty}); foreach my $fk ( qw( fk_rule_rule_type_id fk_prof_auth_container_id fk_prof_pres_container_id fk_prof_cb_container_id fk_prof_retr_container_id fk_workflow_type_id fk_wf_datasrc_type_id very_very_very_very_very_very_very_very_very_very_very_long_string )) { is($output2->_create_constraint_name($fk), $fk, qq{$fk Expect output equal to input}); #diag ($fk . " -> " . $output2->_create_constraint_name($fk) ); ## uncomment to se the conversion } __END__ Parse-Dia-SQL-0.30/t/400-parse-typemap.t0000644000175000017500000000425713035770477015455 0ustar affaff# $Id: 400-parse-typemap.t,v 1.4 2010/02/01 20:45:40 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use Test::Exception; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 6; use lib q{lib}; use_ok ('Parse::Dia::SQL'); use_ok ('Parse::Dia::SQL::Output'); use_ok ('Parse::Dia::SQL::Output::Postgres'); my $diasql = Parse::Dia::SQL->new(file => catfile(qw(t data rt53783.dia)), db => 'postgres'); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); can_ok($diasql, q{_parse_typemap}); my $typemap_hr_input = { 'postgres:typemap' => 'UUID: uuid; string: varchar; TIMESTAMP: timestamp(3);', 'sqlite3:typemap' => 'UUID: text(36); string: text; TIMESTAMP: text(14);' }; my $typemap_hr_output = { 'postgres' => { 'string' => ['varchar'], 'UUID' => ['uuid'], 'TIMESTAMP' => ['timestamp', '(3)'], }, 'sqlite3' => { 'string' => ['text'], 'UUID' => ['text','(36)'], 'TIMESTAMP' => ['text','(14)'], } }; is_deeply($diasql->_parse_typemap($typemap_hr_input), $typemap_hr_output, q[typemap hashref]) or diag "got ". Dumper ( $typemap_hr_input); __END__ =pod Test typemap parsing. =cut =pod =head1 SAMPLE DATASTRUCTURE FOR TYPEMAP { 'postgresql' => { 'string' => 'varchar', 'UUID' => 'uuid', 'TIMESTAMP' => 'timestamp(3)' }, 'sqlite' => { 'string' => 'text', 'UUID' => 'text(36)', 'TIMESTAMP' => 'text(14)' } }; =head1 SAMPLE DIA FILE Add a SmallPackage with stereotype I. Then one each line add entries on the form C, e.g. UUID: uuid; string: varchar; TIMESTAMP: timestamp; =head2 Replacement options Handle mappings that allow the SQL side to replace only the type name, leaving the size unchanged, or to add a size if it's not specified by the user. So, with integer: number(10); string: varchar2; a integer, # allowed -> number(10) b integer(10) # allowed -> number(10) c integer(5) # not allowed d string(80) # allowed -> varchar2(80) e string # allowed -> varchar2 See also I in the C directory. =cut Parse-Dia-SQL-0.30/t/622-output-get-create-view-sql.t0000644000175000017500000000537313035770477020017 0ustar affaff# $Id: 622-output-get-create-view-sql.t,v 1.2 2009/02/28 06:54:57 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use Test::Exception; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 9; use lib q{lib}; use_ok ('Parse::Dia::SQL'); use_ok ('Parse::Dia::SQL::Output'); use_ok ('Parse::Dia::SQL::Output::DB2'); # 1. pre-parsed input for simplicity and speed. # $view is here a array ref containing one view ('ratings_view') my $view = { 'name' => 'ratings_view', 'type' => 'view', 'atts' => { 'c.md5sum' => [ 'c.md5sum', '', '', '0', undef ], 'a.rating' => [ 'a.rating', '', '', '0', undef ], 'b.name' => [ 'b.name', '', '', '0', undef ] }, 'ops' => [ [ 'userImageRating a', 'from', [], '', undef ], [ 'userImageRating z', 'from', [], '', undef ], [ 'userInfo b', 'from', [], '', undef ], [ 'imageInfo c', 'from', [], '', undef ], [ '(((a.userInfo_id = b.id)', 'where', [], '', undef ], [ 'and (a.imageInfo_id = c.id)', 'where', [], '', undef ], [ 'and (a.userInfo_id = z.userInfo_id))', 'where', [], '', undef ], [ 'and (a.userInfo_id <> z.userInfo_id))', 'where', [], '', undef ], [ 'c.md5sum,b.name,a.rating', 'order by', [], '', undef ] ], 'uindxn' => {}, 'pk' => [], 'uindxc' => {}, 'attList' => [ [ 'b.name', '', '', '0', undef ], [ 'c.md5sum', '', '', '0', undef ], [ 'a.rating', '', '', '0', undef ], ], }; # 2. output my $diasql = Parse::Dia::SQL->new(db => 'db2'); my $output = undef; isa_ok($diasql, 'Parse::Dia::SQL'); # Fool Parse::Dia::SQL into thinking convert() was called $diasql->{converted} = 1; lives_ok(sub { $output = $diasql->get_output_instance(); }, q{get_output_instance (db2) should not die}); isa_ok($output, 'Parse::Dia::SQL::Output') or diag(Dumper($output)); isa_ok($output, 'Parse::Dia::SQL::Output::DB2') or diag(Dumper($output)); can_ok($output, 'get_schema_create'); my $create_view = $output->_get_create_view_sql($view); #diag($create_view); like($create_view, qr| create \s+ view \s+ ratings_view \s+ as \s+ select \s+ b.name \s* , \s* c.md5sum \s* , \s*a.rating \s+ from \s+ userImageRating \s+ a \s* , \s* userImageRating \s+ z \s* , \s* userInfo \s+ b \s* , \s* imageInfo \s+ c \s+ where \s+ \(\(\(a.userInfo_id \s* = \s* b.id\) \s+ and \s+ \(a.imageInfo_id \s* = \s* c.id\) \s+ and \s+ \(a.userInfo_id \s* = \s* z.userInfo_id\)\) \s+ and \s+ \(a.userInfo_id \s* <> \s* z.userInfo_id\)\) \s+ order \s+ by \s+ c.md5sum \s* , \s* b.name \s* , \s* a.rating \s* (;)? |six, q{Check syntax for sql create view ratings_view}); __END__ Parse-Dia-SQL-0.30/t/680-output-db2-create-pk-string.t0000644000175000017500000000533413035770477020057 0ustar affaff# $Id: 680-output-db2-create-pk-string.t,v 1.2 2009/02/26 19:58:02 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use Test::Exception; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 23; use lib q{lib}; use_ok ('Parse::Dia::SQL'); use_ok ('Parse::Dia::SQL::Output'); use_ok ('Parse::Dia::SQL::Output::DB2'); # 1. parse input my $db = 'db2'; my $diasql = Parse::Dia::SQL->new( file => catfile(qw(t data TestERD.dia)), db => $db ); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); is($diasql->convert(), 1, q{Expect convert to return 1}); # 2. output my $output = undef; isa_ok($diasql, 'Parse::Dia::SQL'); lives_ok(sub { $output = $diasql->get_output_instance(); }, q{get_output_instance (db2) should not die}); isa_ok($output, 'Parse::Dia::SQL::Output') or diag(Dumper($output)); isa_ok($output, 'Parse::Dia::SQL::Output::DB2') or diag(Dumper($output)); can_ok($output, '_create_pk_string'); # Should return undefined when pk list is empty or undefined ok(!defined($output->_create_pk_string(q{shorttable}, ())), q{Expect undef on empty list}); # Check tablename of various length - the pk should be 18 chars or less (DB2) is($output->_create_pk_string(q{shorttable}, qw(one two three)), q{constraint pk_shorttable primary key (one,two,three)}); is($output->_create_pk_string(q{ImageInfo}, qw(id)), q{constraint pk_ImageInfo primary key (id)}); is($output->_create_pk_string(q{SubImageInfo}, qw(imageInfo_id pixSize)), q{constraint pk_SubImageInfo primary key (imageInfo_id,pixSize)}); is($output->_create_pk_string(q{ImageCategoryList}, qw(imageInfo_id name)), q{constraint pk_ImageCaoryList primary key (imageInfo_id,name)}); is($output->_create_pk_string(q{CategoryNames}, qw(name)), q{constraint pk_CategoryNames primary key (name)}); is($output->_create_pk_string(q{ImageAttribute}, qw(imageInfo_id attributeCategory_id)), q{constraint pk_ImageAttribute primary key (imageInfo_id,attributeCategory_id)}); is($output->_create_pk_string(q{UserInfo}, qw(id)), q{constraint pk_UserInfo primary key (id)}); is($output->_create_pk_string(q{UserAttribute}, qw(userInfo_id attributeCategory_id)), q{constraint pk_UserAttribute primary key (userInfo_id,attributeCategory_id)}); is($output->_create_pk_string(q{UserImageRating}, qw(userInfo_id imageInfo_id)), q{constraint pk_UserImaeRating primary key (userInfo_id,imageInfo_id)}); is($output->_create_pk_string(q{AttributeCategory}, qw(id)), q{constraint pk_Attribuategory primary key (id)}); is($output->_create_pk_string(q{UserSession}, qw(userInfo_id md5sum)), q{constraint pk_UserSession primary key (userInfo_id,md5sum)}); is($output->_create_pk_string(q{Extremes}, qw(name)), q{constraint pk_Extremes primary key (name)}); __END__ Parse-Dia-SQL-0.30/t/953-rt53783-sqlite3.t0000644000175000017500000000540713035770500015305 0ustar affaff# $Id: 953-rt53783-sqlite3.t,v 1.2 2010/02/05 19:30:13 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use Test::Exception; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 8; use lib q{lib}; use_ok ('Parse::Dia::SQL'); use_ok ('Parse::Dia::SQL::Output'); use_ok ('Parse::Dia::SQL::Output::SQLite3'); my $diasql = Parse::Dia::SQL->new(file => catfile(qw(t data typemap.dia)), db => 'sqlite3'); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); can_ok($diasql, q{get_sql}); my $sql = $diasql->get_sql(); isa_ok( $diasql->get_output_instance(), q{Parse::Dia::SQL::Output::SQLite3}, q{Expect Parse::Dia::SQL::Output::SQLite3 to be used as back-end} ); # diag $sql; like($sql, qr/.* create \s* table \s* Item \s* \( \s* \s* id \s* text \s* \( \s* 36 \s* \) \s* not \s* null, \s* -- \s* Primary \s* key \s* timeModified \s* text \s* \( \s* 14 \s* \) \s* , \s* timeCreated \s* text \s* \( \s* 14 \s* \) \s* , \s* personModified \s* text \s* \( \s* 128 \s* \) \s* , .*/six); like($sql, qr/.* create \s* table \s* Item \s* \( \s* \s* id \s* text \s* \( \s* 36 \s* \) \s* not \s* null, \s* -- \s* Primary \s* key \s* timeModified \s* text \s* \( \s* 14 \s* \) \s* , \s* timeCreated \s* text \s* \( \s* 14 \s* \) \s* , \s* personModified \s* text \s* \( \s* 128 \s* \) \s* , \s* personCreated \s* text \s* \( \s* 128 \s* \) \s* , \s* stateID \s* text \s* \( \s* 36 \s* \) \s* , \s* -- \s* - \s* In \s* active \s* storage \s* - \s* Disposed\/destroyed \s* - \s* Handovered \s* back \s* to \s* owner \s* organization \s* projectID \s* text \s* \( \s* 36 \s* \) \s* , \s* descriptionID \s* text \s* \( \s* 36 \s* \) \s* , \s* constraint \s* pk_Item \s* primary \s* key \s* \( \s* id \s* \) \s* \s* \) \s* ; .*/six); __END__ =pod =head1 SAMPLE DATASTRUCTURE FOR TYPEMAP { 'postgresql' => { 'string' => 'varchar', 'UUID' => 'uuid', 'TIMESTAMP' => 'timestamp(3)' }, 'sqlite3' => { 'string' => 'text', 'UUID' => 'text(36)', 'TIMESTAMP' => 'text(14)' } }; =head1 SAMPLE DIA FILE Add a SmallPackage with stereotype I. Then one each line add entries on the form C, e.g. UUID: uuid; string: varchar; TIMESTAMP: timestamp; =head2 Replacement options Handle mappings that allow the SQL side to replace only the type name, leaving the size unchanged, or to add a size if it's not specified by the user. So, with integer: number(10); string: varchar2; a integer, # allowed -> number(10) b integer(10) # allowed -> number(10) c integer(5) # not allowed d string(80) # allowed -> varchar2(80) e string # allowed -> varchar2 See also I in the C directory. =cut Parse-Dia-SQL-0.30/t/643-output-get-drop-permissions-sql.t0000644000175000017500000000467613035770477021131 0ustar affaff# $Id: 643-output-get-drop-permissions-sql.t,v 1.1 2009/02/23 07:36:17 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use Test::Exception; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 23; use lib q{lib}; use_ok ('Parse::Dia::SQL'); use_ok ('Parse::Dia::SQL::Output'); my $diasql = Parse::Dia::SQL->new( file => catfile(qw(t data TestERD.dia)), db => 'db2' ); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); is($diasql->convert(), 1, q{Expect convert() to return 1}); # 2. output my $output = undef; isa_ok($diasql, 'Parse::Dia::SQL'); lives_ok(sub { $output = $diasql->get_output_instance(); }, q{get_output_instance (db2) should not die}); isa_ok($output, 'Parse::Dia::SQL::Output') or diag(Dumper($output)); isa_ok($output, 'Parse::Dia::SQL::Output::DB2') or diag(Dumper($output)); can_ok($output, 'get_permissions_drop'); my $permissions_drop = $output->get_permissions_drop(); like($permissions_drop, qr/.* revoke \s+ all \s+ on \s+ imageInfo \s+ from \s+ fmorg \s* (;)? .*/six); like($permissions_drop, qr/.* revoke \s+ select \s+ on \s+ imageInfo \s+ from \s+ public \s* (;)? .*/six); like($permissions_drop, qr/.* revoke \s+ all \s+ on \s+ subImageInfo \s+ from \s+ fmorg \s* (;)? .*/six); like($permissions_drop, qr/.* revoke \s+ all \s+ on \s+ imageCategoryList \s+ from \s+ fmorg \s* (;)? .*/six); like($permissions_drop, qr/.* revoke \s+ select \s+ on \s+ categoryNames \s+ from \s+ public \s* (;)? .*/six); like($permissions_drop, qr/.* revoke \s+ all \s+ on \s+ categoryNames \s+ from \s+ fmorg \s* (;)? .*/six); like($permissions_drop, qr/.* revoke \s+ all \s+ on \s+ imageAttribute \s+ from \s+ fmorg \s* (;)? .*/six); like($permissions_drop, qr/.* revoke \s+ all \s+ on \s+ userInfo \s+ from \s+ fmorg \s* (;)? .*/six); like($permissions_drop, qr/.* revoke \s+ all \s+ on \s+ userAttribute \s+ from \s+ fmorg \s* (;)? .*/six); like($permissions_drop, qr/.* revoke \s+ all \s+ on \s+ userImageRating \s+ from \s+ fmorg \s* (;)? .*/six); like($permissions_drop, qr/.* revoke \s+ all \s+ on \s+ attributeCategory \s+ from \s+ fmorg \s* (;)? .*/six); like($permissions_drop, qr/.* revoke \s+ all \s+ on \s+ userSession \s+ from \s+ fmorg \s* (;)? .*/six); like($permissions_drop, qr/.* revoke \s+ select \s+ on \s+ extremes \s+ from \s+ public \s* (;)? .*/six); like($permissions_drop, qr/.* revoke \s+ all \s+ on \s+ extremes \s+ from \s+ fmorg \s* (;)? .*/six); __END__ Parse-Dia-SQL-0.30/t/208-parse-classes-ops.t0000644000175000017500000001005713035770477016233 0ustar affaff# $Id: 208-parse-classes-ops.t,v 1.3 2009/03/30 10:57:44 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 47; use_ok ('Parse::Dia::SQL'); my $diasql = Parse::Dia::SQL->new( file => catfile(qw(t data TestERD.dia)), db => 'db2' ); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); # TODO: Add test on return value - call wrapper $diasql->convert(); my $classes = $diasql->get_classes_ref(); # Expect an array ref with 14 elements isa_ok($classes, 'ARRAY'); cmp_ok(scalar(@$classes), q{==}, 14, q{Expect 14 classes}); # Hash with class/view names as keys and operations (if any) as # (hashref) elements my %ops = ( imageInfo => [ [ 'idx_iimd5', 'unique index', [ 'md5sum' ], '', '' ], [ 'idx_iiid', 'index', [ 'id' ], '', '' ], [ 'all', 'grant', [ 'fmorg' ], '', '' ], [ 'select', 'grant', [ 'public' ], '', '' ] ], subImageInfo => [ [ 'idx_siiid', 'index', [ 'imageInfo_id' ], '', '' ], [ 'idx_siips', 'index', [ 'pixSize' ], '', '' ], [ 'all', 'grant', [ 'fmorg' ], '', '' ] ], imageCategoryList => [ [ 'idx_iclidnm', 'index', [ 'imageInfo_id', 'name' ], '', '' ], [ 'all', 'grant', [ 'fmorg' ], '', '' ] ], categoryNames => [ [ 'select', 'grant', [ 'public' ], '', '' ], [ 'all', 'grant', [ 'fmorg' ], '', '' ] ], imageAttribute => [ [ 'all', 'grant', [ 'fmorg' ], '', '' ] ], userInfo => [ [ 'idx_uinm', 'unique index', [ 'name', 'md5sum' ], '', '' ], [ 'idx_uiid', 'index', [ 'id' ], '', '' ], [ 'all', 'grant', [ 'fmorg' ], '', '' ] ], userAttribute => [ [ 'idx_uauiid', 'index', [ 'userInfo_id' ], '', '' ], [ 'all', 'grant', [ 'fmorg' ], '', '' ] ], userImageRating => [ [ 'idx_uiruid', 'index', [ 'userInfo_id' ], '', '' ], [ 'all', 'grant', [ 'fmorg' ], '', '' ] ], attributeCategory => [ [ 'idx_acid', 'index', [ 'id' ], '', '' ], [ 'all', 'grant', [ 'fmorg' ], '', '' ] ], userSession => [ [ 'idx_usmd5', 'index', [ 'md5sum' ], '', '' ], [ 'all', 'grant', [ 'fmorg' ], '', '' ] ], extremes => [ [ 'select', 'grant', [ 'public' ], '', '' ], [ 'all', 'grant', [ 'fmorg' ], '', '' ] ], ratings_view => [ [ 'userImageRating a', 'from', [], '', '' ], [ 'userImageRating z', 'from', [], '', '' ], [ 'userInfo b', 'from', [], '', '' ], [ 'imageInfo c', 'from', [], '', '' ], [ '(((a.userInfo_id = b.id)', 'where', [], '', '' ], [ 'and (a.imageInfo_id = c.id)', 'where', [], '', '' ], [ 'and (a.userInfo_id = z.userInfo_id))', 'where', [], '', '' ], [ 'and (a.userInfo_id <> z.userInfo_id))', 'where', [], '', '' ], [ 'c.md5sum,b.name,a.rating', 'order by', [], '', '' ] ], whorated_view => [ [ 'userInfo a', 'from', [], '', '' ], [ 'userImageRating b', 'from', [], '', '' ], [ '(a.id = b.userInfo_id)', 'where', [], '', '' ], [ 'a.name', 'group by', [], '', '' ] ], users_view => [ [ 'userInfo', 'from', [], '', '' ], [ 'userInfo.name', 'order by', [], '', '' ] ], ); # Check that each class has of the expected ops attributes foreach my $class (@$classes) { isa_ok($class, 'HASH'); ok(exists($ops{$class->{name}})) or diag($class->{name} . ' ops :' . Dumper($class->{ops})); # check contents is_deeply( $class->{ops}, $ops{ $class->{name} }, q{ops for } . $class->{name} ); # remove class from hash delete $ops{$class->{name}}; } # Expect no classes left now cmp_ok(scalar(keys %ops), q{==}, 0, q{Expect 0 classes left}); __END__ Parse-Dia-SQL-0.30/t/701-utils-mangle-name.t0000644000175000017500000000200713035770477016200 0ustar affaff# $Id: 701-utils-mangle-name.t,v 1.1 2009/02/23 07:36:17 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 10; use lib q{lib}; use_ok ('Parse::Dia::SQL::Utils'); my $utils = Parse::Dia::SQL::Utils->new(); isa_ok($utils, 'Parse::Dia::SQL::Utils'); # mangle_name Parse::Dia::SQL::Logger::log_off() or diag(q{Failed to turn off logging}); is($utils->mangle_name(undef,undef), undef); is($utils->mangle_name(q{},-1),undef); Parse::Dia::SQL::Logger::log_on() or diag(q{Failed to turn on logging}); is($utils->mangle_name(q{a},5),q{a}); is($utils->mangle_name(q{short},5),q{short}); is($utils->mangle_name(q{longer},6),q{longer}); is($utils->mangle_name(q{longer},4),q{loer}); is($utils->mangle_name(q{imalumberjackbutimok},14),q{imalumbbutimok}); # chop here and there is($utils->mangle_name(q{imalumberjackbutimokiworkallnightandisleepallday},14),q{pSo8US4paCtxKI}); # turns to base64 when input overflows limit by 6 chars __END__ Parse-Dia-SQL-0.30/t/610-output-getinstance.t0000644000175000017500000000175213035770477016530 0ustar affaff# $Id: 610-output-getinstance.t,v 1.3 2009/02/28 06:54:57 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use Test::Exception; # test code that dies use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 8; use lib q{lib}; use_ok ('Parse::Dia::SQL'); use_ok ('Parse::Dia::SQL::Logger'); my $diasql = undef; # Test that lives - db => 'db2' $diasql = Parse::Dia::SQL->new(db => 'db2'); isa_ok($diasql, 'Parse::Dia::SQL'); # Fool Parse::Dia::SQL into thinking convert() was called $diasql->{converted} = 1; my $subclass = undef; lives_ok( sub { $subclass = $diasql->get_output_instance(); }, q{get_output_instance (db2) should not die} ); isa_ok($subclass, 'Parse::Dia::SQL::Output::DB2'); # Test that dies - db => 'foo' undef $diasql; ok(Parse::Dia::SQL::Logger::log_off()); throws_ok( sub { $diasql = Parse::Dia::SQL->new(db => 'foo'); }, qr/Unsupported database/i, q{new(foo) should die} ); ok(Parse::Dia::SQL::Logger::log_on()); __END__ Parse-Dia-SQL-0.30/t/720-logger-load.t0000644000175000017500000000041013035770477015052 0ustar affaff# $Id: 720-logger-load.t,v 1.1 2009/02/23 07:36:17 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 1; use lib q{lib}; use_ok ('Parse::Dia::SQL::Logger'); __END__ Parse-Dia-SQL-0.30/t/211-parse-versions.t0000644000175000017500000000214413035770477015637 0ustar affaff# $Id: 211-parse-versions.t,v 1.1 2009/06/21 13:24:37 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use Test::Exception; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 7; use_ok ('Parse::Dia::SQL'); # supported my $pds = Parse::Dia::SQL->new( file => catfile(qw(t data version.supported.dia)), db => 'db2' ); isa_ok($pds, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); # parse and convert is($pds->convert(), 1, q{Expect convert() to return 1}); my $classes = $pds->get_classes_ref(); #diag(Dumper($classes)); cmp_ok (scalar @$classes, q[==], 14, q{Expect an array ref with 14 elements}); # unsupported undef $pds; undef $classes; $pds = Parse::Dia::SQL->new( file => catfile(qw(t data version.unsupported.dia)), db => 'db2' ); isa_ok($pds, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); # parse and convert is($pds->convert(), 1, q{Expect convert() to return 1}); $classes = $pds->get_classes_ref(); #diag(Dumper($classes)); is_deeply ($classes, [], q{Expect an empty array ref}); __END__ =pod =head1 Test of XML object versions. =cut Parse-Dia-SQL-0.30/t/000-load.t0000644000175000017500000000203113035770477013565 0ustar affaff# $Id: 000-load.t,v 1.3 2009/04/01 07:22:14 aff Exp $ use warnings; use strict; use Test::More tests => 16; use Config; use File::Spec::Functions; use lib catdir qw ( blib lib ); BEGIN { use_ok( 'Parse::Dia::SQL' ); use_ok( 'Parse::Dia::SQL::Const' ); use_ok( 'Parse::Dia::SQL::Logger' ); use_ok( 'Parse::Dia::SQL::Output' ); use_ok( 'Parse::Dia::SQL::Output::DB2' ); use_ok( 'Parse::Dia::SQL::Output::Informix' ); use_ok( 'Parse::Dia::SQL::Output::Ingres' ); use_ok( 'Parse::Dia::SQL::Output::MySQL' ); use_ok( 'Parse::Dia::SQL::Output::MySQL::InnoDB' ); use_ok( 'Parse::Dia::SQL::Output::MySQL::MyISAM' ); use_ok( 'Parse::Dia::SQL::Output::Oracle' ); use_ok( 'Parse::Dia::SQL::Output::Postgres' ); use_ok( 'Parse::Dia::SQL::Output::SQLite3' ); use_ok( 'Parse::Dia::SQL::Output::Sas' ); use_ok( 'Parse::Dia::SQL::Output::Sybase' ); use_ok( 'Parse::Dia::SQL::Utils' ); } diag( "Testing Parse::Dia::SQL $Parse::Dia::SQL::VERSION, Perl $], $^X, archname=$Config{archname}, byteorder=$Config{byteorder}" ); __END__ Parse-Dia-SQL-0.30/t/620-output-get-schema-create-db-model-nullable.t0000644000175000017500000000327313035770477022760 0ustar affaff# $Id: 620-output-get-schema-create-db-model.t,v 1.2 2010/04/16 05:07:34 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use Test::Exception; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 11; use lib q{lib}; use_ok ('Parse::Dia::SQL'); use_ok ('Parse::Dia::SQL::Output'); use_ok ('Parse::Dia::SQL::Output::DB2'); # 1. parse input my $db = 'db2'; my $diasql = Parse::Dia::SQL->new( file => catfile(qw(t data nullable.dia)), db => $db ); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); is($diasql->convert(), 1, q{Expect convert to return 1}); my $classes = $diasql->get_classes_ref(); # check parsed content ok(defined($classes) && ref($classes) eq q{ARRAY} && scalar(@$classes), q{Non-empty array ref}); # 2. get output instance my $subclass = undef; lives_ok(sub { $subclass = $diasql->get_output_instance(); }, q{get_output_instance (db2) should not die}); isa_ok($subclass, 'Parse::Dia::SQL::Output') or diag(Dumper($subclass)); isa_ok($subclass, 'Parse::Dia::SQL::Output::DB2') or diag(Dumper($subclass)); can_ok($subclass, 'get_schema_create'); # 3. create sql my $create_table = $subclass->get_schema_create(); #diag $create_table; like($create_table, qr|.* create \s+ table \s+ bar \s* \( \s* id \s+ int \s+ not \s+ null \s* , \s* col1_nullable \s+ int \s* , \s* col2_not_nullable \s+ int \s+ not \s+ null \s* , \s* constraint \s+ pk_\w+ \s+ primary \s+ key \s* \(id\) \s* \) \s* (;)? .*|six, q{Check syntax for sql create table bar with nullable property. (1 col nullable, 1 col not null)}); __END__ =pod =head1 SUMMARY Related to bug submitted by 'jochenberger' on github.com =cut Parse-Dia-SQL-0.30/t/687-output-mysql-innodb-get-sql.t0000644000175000017500000000267213035770477020232 0ustar affaff# $Id: 687-output-mysql-innodb-get-sql.t,v 1.5 2009/09/28 19:12:06 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use Test::Exception; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 9; use lib q{lib}; use_ok ('Parse::Dia::SQL'); use_ok ('Parse::Dia::SQL::Output'); use_ok ('Parse::Dia::SQL::Output::MySQL'); use_ok ('Parse::Dia::SQL::Output::MySQL::InnoDB'); my $diasql = Parse::Dia::SQL->new(file => catfile(qw(t data TestERD.dia)), db => 'mysql-innodb'); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); can_ok($diasql, q{get_sql}), # object should have method get_sql() my $sql = $diasql->get_sql(); isa_ok( $diasql->get_output_instance(), q{Parse::Dia::SQL::Output::MySQL::InnoDB}, q{Expect Parse::Dia::SQL::Output::MySQL::InnoDB to be used as back-end} ); #diag($sql); like( $sql, qr/ENGINE=InnoDB DEFAULT CHARSET=latin1/, q{Expect sql to contain ENGINE=InnoDB DEFAULT CHARSET=latin1} ); # Check that all indices are created before any "alter table .. add # constraint". # http://dev.mysql.com/doc/refman/5.1/en/innodb-foreign-key-constraints.html # "When you add a foreign key constraint to a table using ALTER # TABLE, remember to create the required indexes first." unlike( $sql, qr/.* add \s+ constraint .* create \s* (unique) \s+ index .*/six, q{Expect all indices to be created before any foreign key constraints} ); __END__ Parse-Dia-SQL-0.30/t/100-parse-small-packages.t0000644000175000017500000000237113035770477016652 0ustar affaff# $Id: 100-parse-small-packages.t,v 1.2 2009/02/26 13:46:44 aff Exp $ use warnings; use strict; use Test::More; use File::Spec::Functions; use lib catdir qw ( blib lib ); use Data::Dumper; plan tests => 7; use_ok ('Parse::Dia::SQL'); my $diasql = Parse::Dia::SQL->new( files => [catfile(qw(t data TestERD.dia))], db => 'db2' ); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); # Parse and convert cmp_ok($diasql->convert(), q{==}, 1,q{Expect convert to return 1}); # check that nodelists returns array of XML::DOM::NodeList my $nodelists = $diasql->_get_nodelists(); foreach my $nodelist (@{$nodelists}){ isa_ok($nodelist, q{XML::DOM::NodeList}); } my $expected = [ { 'oracle,postgres,db2:pre' => '-- statements to do BEFORE creating -- the tables (schema) drop sequence imageInfo_id; create sequence imageInfo_id;' }, { 'oracle,postgres,db2:post' => '-- statements to do AFTER creating -- the tables (schema) --drop trigger . . . . --create trigger . . . .' }, ]; # Check contents of small packages my $smallpackages_ref = $diasql->get_smallpackages_ref(); #diag(Dumper($smallpackages_ref)); isa_ok($smallpackages_ref, 'ARRAY'); is_deeply($smallpackages_ref, $expected, q{Expect arrayref of hashrefs}); __END__ Parse-Dia-SQL-0.30/t/203-parse-classes-attlist.t0000644000175000017500000001167013035770477017113 0ustar affaff# $Id: 203-parse-classes-attlist.t,v 1.4 2009/04/01 08:10:43 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 47; use_ok ('Parse::Dia::SQL'); my $diasql = Parse::Dia::SQL->new( file => catfile(qw(t data TestERD.dia)), db => 'db2' ); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); # TODO: Add test on return value - call wrapper $diasql->convert(); my $classes = $diasql->get_classes_ref(); # Expect an array ref with 14 elements isa_ok($classes, 'ARRAY'); cmp_ok(scalar(@$classes), q{==}, 14, q{Expect 14 classes}); # Hash with class/view names as keys and attribute list as (hashref) elements my %attList = ( imageInfo => [ [ 'id', 'numeric (18)', '', '2', '' ], [ 'insertionDate', 'timestamp', 'not null', '0', '' ], [ 'md5sum', 'char (32)', 'not null', '0', '' ], [ 'binaryType', 'varchar (16)', '\'jpg\' null', '0', '' ], [ 'name', 'varchar (64)', 'not null', '0', '' ], [ 'locationList', 'varchar (128)', '\'//imgserver.org\'', '0', '' ], [ 'description', 'varchar (128)', 'null', '0', '' ] ], users_view => [ [ 'id', '', '', '0', '' ], [ 'birthDate', '', '', '0', '' ], [ 'name ||\'<\'|| email ||\'>\' as whoIsThis', '', '', '0', '' ], [ 'currentCategory', '', '', '0', '' ], [ 'acctBalance', '', '', '0', '' ], [ 'active', '', '', '0', '' ] ], whorated_view => [ [ 'a.name', '', '', '0', '' ], [ 'count (*) as numRatings', '', '', '0', '' ] ], ratings_view => [ [ 'b.name', '', '', '0', '' ], [ 'c.md5sum', '', '', '0', '' ], [ 'a.rating', '', '', '0', '' ] ], extremes => [ [ 'name', 'varchar (32)', '', '2', '' ], [ 'colName', 'varchar (64)', '', '0', '' ], [ 'minVal', 'numeric (15)', '', '0', '' ], [ 'maxVal', 'numeric (15)', '', '0', '' ] ], userSession => [ [ 'userInfo_id', 'numeric (18)', '', '2', '' ], [ 'md5sum', 'char (32)', '', '2', '' ], [ 'insertionDate', 'timestamp', '', '0', '' ], [ 'expireDate', 'timestamp', '', '0', '' ], [ 'ipAddress', 'varchar (24)', '', '0', '' ] ], attributeCategory => [ [ 'id', 'numeric (18)', '', '2', '' ], [ 'attributeDesc', 'varchar (128)', '', '0', '' ] ], userImageRating => [ [ 'userInfo_id', 'numeric (18)', '', '2', '' ], [ 'imageInfo_id', 'numeric (15)', '', '2', '' ], [ 'rating', 'integer', '', '0', '' ] ], userAttribute => [ [ 'userInfo_id', 'numeric (18)', '', '2', '' ], [ 'attributeCategory_id', 'numeric (18)', '', '2', '' ], [ 'numValue', 'numeric (5,4)', '', '0', '' ] ], userInfo => [ [ 'id', 'numeric (18)', '', '2', '' ], [ 'insertionDate', 'timestamp', '', '0', '' ], [ 'md5sum', 'char (32)', '', '0', '' ], [ 'birthDate', 'timestamp', '', '0', '' ], [ 'gender', 'char (1)', '', '0', '' ], [ 'name', 'varchar (32)', '', '0', '' ], [ 'email', 'varchar (96)', '', '0', '' ], [ 'currentCategory', 'varchar (32)', '', '0', '' ], [ 'lastDebitDate', 'timestamp', '', '0', '' ], [ 'acctBalance', 'numeric (10,2)', '', '0', '' ], [ 'active', 'integer', '', '0', '' ] ], imageAttribute => [ [ 'imageInfo_id', 'numeric (18)', '', '2', '' ], [ 'attributeCategory_id', 'numeric (18)', '', '2', '' ], [ 'numValue', 'numeric (8)', '', '0', '' ], [ 'category', 'numeric (4)', '', '0', '' ] ], categoryNames => [ [ 'name', 'varchar (32)', '', '2', '' ] ], imageCategoryList => [ [ 'imageInfo_id', 'numeric (18)', '', '2', '' ], [ 'name', 'varchar (32)', '', '2', '' ] ], subImageInfo => [ [ 'imageInfo_id', 'numeric (18)', '', '2', '' ], [ 'pixSize', 'integer', '', '2', '' ] ], ); # Check that each class has of the expected attList attributes foreach my $class (@$classes) { #diag (Dumper($class)); isa_ok($class, 'HASH'); ok(exists($attList{$class->{name}})); # check contents is_deeply( $class->{attList}, $attList{ $class->{name} }, q{attList for } . $class->{name} ); # remove key-value pair from hash delete $attList{$class->{name}}; } # Expect no classes left now cmp_ok(scalar(keys %attList), q{==}, 0, q{Expect 0 classes}); __END__ Parse-Dia-SQL-0.30/t/672-output-get-inserts.t0000644000175000017500000000435613035770477016503 0ustar affaff# $Id: 672-output-get-inserts.t,v 1.2 2009/02/24 05:44:27 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use Test::Exception; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 20; use lib q{lib}; use_ok ('Parse::Dia::SQL'); use_ok ('Parse::Dia::SQL::Output'); my $diasql = Parse::Dia::SQL->new( file => catfile(qw(t data TestERD.dia)), db => 'db2' ); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); is($diasql->convert(), 1, q{Expect convert() to return 1}); my $output = undef; isa_ok($diasql, 'Parse::Dia::SQL'); lives_ok(sub { $output = $diasql->get_output_instance(); }, q{get_output_instance (db2) should not die}); isa_ok($output, 'Parse::Dia::SQL::Output') or diag(Dumper($output)); isa_ok($output, 'Parse::Dia::SQL::Output::DB2') or diag(Dumper($output)); can_ok($output, 'get_inserts'); my $inserts = $output->get_inserts(); like($inserts, qr/.* insert \s+ into \s+ categoryNames \s+ values \s* \( \s* 'Buildings' \s* \) \s* \s* ; .*/six); like($inserts, qr/.* insert \s+ into \s+ categoryNames \s+ values \s* \( \s* 'Landscapes' \s* \) \s* ; .*/six); like($inserts, qr/.* insert \s+ into \s+ categoryNames \s+ values \s* \( \s* 'Nudes' \s* \) \s* ; .*/six); like($inserts, qr/.* insert \s+ into \s+ categoryNames \s+ values \s* \( \s* 'Life \s+ Studies' \s* \) \s* ; .*/six); like($inserts, qr/.* insert \s+ into \s+ categoryNames \s+ values \s* \( \s* 'Portraits' \s* \) \s* ; .*/six); like($inserts, qr/.* insert \s+ into \s+ categoryNames \s+ values \s* \( \s* 'Abstracts' \s* \) \s* ; .*/six); like($inserts, qr/.* insert \s+ into \s+ attributeCategory \s+ values \s* \( \s* 1 \s* , \s* 'Blurriness' \s* \) \s* ; .*/six); like($inserts, qr/.* insert \s+ into \s+ attributeCategory \s+ values \s* \( \s* 2 \s* , \s* 'Contrastiness' \s* \) \s* ; .*/six); like($inserts, qr/.* insert \s+ into \s+ attributeCategory \s+ values \s* \( \s* 3 \s* , \s* 'Saturation' \s* \) \s* ; .*/six); like($inserts, qr/.* insert \s+ into \s+ attributeCategory \s+ values \s* \( \s* 4 \s* , \s* 'Size' \s* \) \s* ; .*/six); like($inserts, qr/.* insert \s+ into \s+ attributeCategory \s+ values \s* \( \s* 5 \s* , \s* 'Relevence' \s* \) \s* ; .*/six); __END__ Parse-Dia-SQL-0.30/t/650-output-get-create-associations-many-to-many-097.t0000644000175000017500000000633413035770477023607 0ustar affaff# $Id: 650-output-get-create-associations-many-to-many-097.t,v 1.2 2011/02/15 20:15:54 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use Test::Exception; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 19; use_ok ('Parse::Dia::SQL'); # ------- many-to-many relations ------- my $diasql_m2m = Parse::Dia::SQL->new( file => catfile(qw(t data many_to_many.097.dia)), db => 'db2' ); isa_ok($diasql_m2m, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); ok $diasql_m2m->convert(); my $association_m2m_arrayref = $diasql_m2m->get_associations_ref(); #diag("association_m2m_arrayref: ".Dumper($association_m2m_arrayref)); my $expected_m2m = [ [ 'student_course', 'stdn_crs_fk_StntSn', 'ssn', 'student', 'ssn', 'on delete cascade' ], [ 'student_course', 'lTeT8iBKfXObJYiSrq', 'course_id', 'course', 'course_id', 'on delete cascade' ] ]; is_deeply( $association_m2m_arrayref, $expected_m2m ); # or diag( q{association_m2m_arrayref: } # . Dumper($association_m2m_arrayref) # . q{ expected } # . Dumper($expected_m2m) ); my $output_m2m = undef; isa_ok($diasql_m2m, 'Parse::Dia::SQL'); lives_ok(sub { $output_m2m = $diasql_m2m->get_output_instance(); }, q{get_output_instance (db2) should not die}); isa_ok($output_m2m, 'Parse::Dia::SQL::Output') or diag(Dumper($output_m2m)); isa_ok($output_m2m, 'Parse::Dia::SQL::Output::DB2') or diag(Dumper($output_m2m)); can_ok($output_m2m, 'get_associations_create'); # associations = foreign keys + indices my $association_str_m2m = $output_m2m->get_associations_create(); # check 2 foreign keys like($association_str_m2m, qr/.* alter \s+ table \s+ student_course \s+ add \s+ constraint \s+ stdn_crs_fk_StntSn \s+ foreign \s+ key \s* \( \s* ssn \s* \) \s+ references \s+ student \s* \( \s* ssn \s* \) \s* on \s+ delete \s+ cascade .*/six); like($association_str_m2m, qr/.* alter \s+ table \s+ student_course \s+ add \s+ constraint \s+ lTeT8iBKfXObJYiSrq \s+ foreign \s+ key \s* \( \s* course_id \s* \) \s* references \s+ course \s+ \s* \( \s* course_id \) \s* on \s+ delete \s+ cascade .*/six); # ------ implicit role ------ my $diasql_ir = Parse::Dia::SQL->new( file => catfile(qw(t data implicit_role.dia)), db => 'db2' ); isa_ok($diasql_ir, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); ok $diasql_ir->convert(); my $output_ir = undef; isa_ok($diasql_ir, 'Parse::Dia::SQL'); lives_ok(sub { $output_ir = $diasql_ir->get_output_instance(); }, q{get_output_instance (db2) should not die}); isa_ok($output_ir, 'Parse::Dia::SQL::Output') or diag(Dumper($output_ir)); isa_ok($output_ir, 'Parse::Dia::SQL::Output::DB2') or diag(Dumper($output_ir)); can_ok($output_ir, 'get_associations_create'); # associations = foreign keys + indices my $association_str_ir = $output_ir->get_associations_create(); #diag $association_str_ir; like($association_str_ir, qr/.* alter \s+ table \s+ emp \s+ add \s+ constraint \s+ emp_fk_Dept_id \s+ foreign \s+ key \s+ \( \s* dept_id \s* \) \s+ references \s+ dept \s+ \( \s* id \s* \) \s+ ; .*/six); __END__ Parse-Dia-SQL-0.30/t/611-output-format-columns.t0000644000175000017500000000207313035770477017170 0ustar affaff# $Id: 611-output-format-columns.t,v 1.3 2009/03/16 07:46:16 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use Test::Exception; # test code that dies use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 6; use lib q{lib}; use_ok ('Parse::Dia::SQL'); use_ok ('Parse::Dia::SQL::Output'); use_ok ('Parse::Dia::SQL::Output'); my $diasql = Parse::Dia::SQL->new(db => 'db2'); $diasql->{converted} = 1; # Fool Parse::Dia::SQL into thinking convert() was called my $subclass = undef; lives_ok( sub { $subclass = $diasql->get_output_instance(); }, q{get_output_instance (db2) should not die}); isa_ok($subclass, 'Parse::Dia::SQL::Output::DB2'); my @columns = ( [ 'one', 'two', 'three' ], [ 'her we go',, 'again' ], [ 'once upon a time there was', 'three bears', 'who ..' ] ); my @form_cols = (); lives_ok( sub { @form_cols = $subclass->_format_columns(@columns); }, q{_format_columns should not die}); #$diasql->_format_columns() diag("TODO: check contents of form_cols"); __END__ Parse-Dia-SQL-0.30/t/202-parse-classes-type.t0000644000175000017500000000317713035770477016412 0ustar affaff# $Id: 202-parse-classes-type.t,v 1.2 2009/02/26 13:49:07 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 47; use_ok ('Parse::Dia::SQL'); my $diasql = Parse::Dia::SQL->new( file => catfile(qw(t data TestERD.dia)), db => 'db2' ); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); # TODO: Add test on return value - call wrapper $diasql->convert(); my $classes = $diasql->get_classes_ref(); # Expect an array ref with 14 elements isa_ok($classes, 'ARRAY'); cmp_ok(scalar(@$classes), q{==}, 14, q{Expect 14 classes}); # List of objects and types my %classname = ( imageInfo => 'table', subImageInfo => 'table', imageCategoryList => 'table', categoryNames => 'table', imageAttribute => 'table', userInfo => 'table', userAttribute => 'table', userImageRating => 'table', attributeCategory => 'table', userSession => 'table', extremes => 'table', ratings_view => 'view', whorated_view => 'view', users_view => 'view', ); # Check that each class is of the expected type (table or view) foreach my $class (@$classes) { isa_ok($class, 'HASH'); ok(exists($classname{$class->{name}})); is($class->{type}, $classname{$class->{name}}, $class->{name} . q{ is of type } . $class->{type} . q{ expected } . $classname{ $class->{name}}); delete $classname{$class->{name}}; } # Expect no classes left now cmp_ok(scalar(keys %classname), q{==}, 0, q{Expect 0 classes}); __END__ Parse-Dia-SQL-0.30/t/621-output-get-schema-create-many-to-many-uml.t0000644000175000017500000000453613035770477022626 0ustar affaff# $Id: 621-output-get-schema-create-many-to-many-uml.t,v 1.1 2011/02/15 20:15:54 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use Test::Exception; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 16; use lib q{lib}; use_ok ('Parse::Dia::SQL'); use_ok ('Parse::Dia::SQL::Output'); use_ok ('Parse::Dia::SQL::Output::DB2'); # 1. parse input my $diasql = Parse::Dia::SQL->new( file => catfile(qw(t data many_to_many.dia)), db => 'db2', uml => 1 ); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); is($diasql->convert(), 1, q{Expect convert to return 1}); my $classes = $diasql->get_classes_ref(); my $associations = $diasql->get_associations_ref(); my $smallpackages = $diasql->get_smallpackages_ref(); # check parsed content ok(defined($classes) && ref($classes) eq q{ARRAY} && scalar(@$classes), q{Non-empty array ref}); ok(defined($associations) && ref($associations) eq q{ARRAY} && scalar(@$associations), q{Non-empty array ref}); # 2. get output instance my $subclass = undef; lives_ok(sub { $subclass = $diasql->get_output_instance(); }, q{get_output_instance (db2) should not die}); isa_ok($subclass, 'Parse::Dia::SQL::Output') or diag(Dumper($subclass)); isa_ok($subclass, 'Parse::Dia::SQL::Output::DB2') or diag(Dumper($subclass)); can_ok($subclass, 'get_schema_create'); # 3. schema my $schema = $subclass->get_schema_create(); like($schema, qr|.* create \s+ table \s+ student \s* .*|six, q{Check syntax for sql create table student}); like($schema, qr|.* create \s+ table \s+ course \s* .*|six, q{Check syntax for sql create table course}); like($schema, qr|.* create \s+ table \s+ student_course \s* .*|six, q{Check syntax for sql create table student_course}); # 4. associations my $assoc = $subclass->get_associations_create(); like($assoc, qr|.* alter \s+ table \s+ student_course \s+ add \s+ constraint \s+ \w+ \s+ foreign \s+ key \s+ \(ssn\) \s+ references \s+ student \s+ \(ssn\) \s+ on \s+ delete \s+ cascade; \s* .*|six, q{Check syntax for sql alter table add constraint rel1}); like($assoc, qr|.* alter \s+ table \s+ student_course \s+ add \s+ constraint \s+ \w+ \s+ foreign \s+ key \s+ \(course_id\) \s+ references \s+ course \s+ \(course_id\) \s+ on \s+ delete \s+ cascade; \s* .*|six, q{Check syntax for sql alter table add constraint rel2}); __END__ Parse-Dia-SQL-0.30/t/650-output-get-create-associations.t0000644000175000017500000000647413035770477020753 0ustar affaff# $Id: 650-output-get-create-associations.t,v 1.3 2009/10/01 18:22:46 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use Test::Exception; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 21; use_ok ('Parse::Dia::SQL'); my $diasql = Parse::Dia::SQL->new( file => catfile(qw(t data TestERD.dia)), db => 'db2' ); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); ok $diasql->convert(); # Output my $output = undef; isa_ok($diasql, 'Parse::Dia::SQL'); lives_ok(sub { $output = $diasql->get_output_instance(); }, q{get_output_instance (db2) should not die}); isa_ok($output, 'Parse::Dia::SQL::Output') or diag(Dumper($output)); isa_ok($output, 'Parse::Dia::SQL::Output::DB2') or diag(Dumper($output)); can_ok($output, 'get_associations_create'); # associations = foreign keys + indices my $association_str = $output->get_associations_create(); # unique index like($association_str, qr|.* create \s+ unique \s+ index \s+ idx_iimd5 \s+ on \s+ imageInfo \s* \( \s* md5sum \s* \) \s* allow \s+ reverse \s+ scans \s* (;)? .* |six, q{Expect unique index on imageInfo}); like($association_str, qr|.* create \s+ unique \s+ index \s+ idx_uinm \s+ on \s+ userInfo \s* \(name,md5sum\) \s* allow \s+ reverse \s+ scans \s* (;)? |six, q{Expect unique index}); like($association_str, qr|.* create \s+ unique \s+ index \s+ idx_iimd5 \s+ on \s+ imageInfo \s* \(md5sum\) \s* allow \s+ reverse \s+ scans \s* (;)? |six, q{Expect unique index}); # index like($association_str, qr|.* create \s+ index \s+ idx_iiid \s+ on \s+ imageInfo \s* \(id\) \s* allow \s+ reverse \s+ scans \s* (;)? |six, q{Expect index}); like($association_str, qr|.* create \s+ index \s+ idx_siiid \s+ on \s+ subImageInfo \s* \(imageInfo_id\) \s* allow \s+ reverse \s+ scans \s* (;)? |six, q{Expect index}); like($association_str, qr|.* create \s+ index \s+ idx_siips \s+ on \s+ subImageInfo \s* \(pixSize\) \s* allow \s+ reverse \s+ scans \s* (;)? |six, q{Expect index}); like($association_str, qr|.* create \s+ index \s+ idx_iclidnm \s+ on \s+ imageCategoryList \s* \(imageInfo_id,name\) \s* allow \s+ reverse \s+ scans \s* (;)? |six, q{Expect index}); like($association_str, qr|.* create \s+ index \s+ idx_uiid \s+ on \s+ userInfo \s* \(id\) \s* allow \s+ reverse \s+ scans \s* (;)? |six, q{Expect index}); like($association_str, qr|.* create \s+ index \s+ idx_uauiid \s+ on \s+ userAttribute \s* \(userInfo_id\) \s* allow \s+ reverse \s+ scans \s* (;)? |six, q{Expect index}); like($association_str, qr|.* create \s+ index \s+ idx_uiruid \s+ on \s+ userImageRating \s* \(userInfo_id\) \s* allow \s+ reverse \s+ scans \s* (;)? |six, q{Expect index}); like($association_str, qr|.* create \s+ index \s+ idx_acid \s+ on \s+ attributeCategory \s* \(id\) \s* allow \s+ reverse \s+ scans \s* (;)? |six, q{Expect index}); like($association_str, qr|.* create \s+ index \s+ idx_usmd5 \s+ on \s+ userSession \s* \(md5sum\) \s* allow \s+ reverse \s+ scans \s* (;)? |six, q{Expect index}); # foreign keys like($association_str, qr|.* alter \s+ table \s+ subImageInfo \s+ add \s+ constraint \s+ fk_iisii \s+ foreign \s+ key \s* \( \s* imageInfo_id \s* \) \s* \s+ references \s+ imageInfo \s* \( \s* id \s* \) \s* (;)? .* |six, q{Expect foreign key fk_iisii on subImageInfo}); diag(q{TODO: add all foreign keys}); undef $diasql; __END__ Parse-Dia-SQL-0.30/t/692-output-sqlite3fk-get-sql.t0000644000175000017500000000152713035770477017515 0ustar affaff# $Id: 692-output-sqlite3fk-get-sql.t,v 1.2 2009/04/01 08:14:19 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use Test::Exception; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 6; diag 'SQLite3fk support is experimental'; use lib q{lib}; use_ok ('Parse::Dia::SQL'); use_ok ('Parse::Dia::SQL::Output'); use_ok ('Parse::Dia::SQL::Output::SQLite3fk'); my $diasql = Parse::Dia::SQL->new(file => catfile(qw(t data TestERD.dia)), db => 'sqlite3fk'); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); can_ok($diasql, q{get_sql}); my $sql = $diasql->get_sql(); #diag($sql); isa_ok( $diasql->get_output_instance(), q{Parse::Dia::SQL::Output::SQLite3fk}, q{Expect Parse::Dia::SQL::Output::SQLite3fk to be used as back-end} ); diag(q{TODO: Add checks of the sql}); __END__ Parse-Dia-SQL-0.30/t/690-output-sqlite3-get-sql.t0000644000175000017500000000147613035770477017175 0ustar affaff# $Id: 690-output-sqlite3-get-sql.t,v 1.2 2009/04/01 08:14:19 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use Test::Exception; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 6; diag 'SQLite3 support is experimental'; use lib q{lib}; use_ok ('Parse::Dia::SQL'); use_ok ('Parse::Dia::SQL::Output'); use_ok ('Parse::Dia::SQL::Output::SQLite3'); my $diasql = Parse::Dia::SQL->new(file => catfile(qw(t data TestERD.dia)), db => 'sqlite3'); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); can_ok($diasql, q{get_sql}); my $sql = $diasql->get_sql(); isa_ok( $diasql->get_output_instance(), q{Parse::Dia::SQL::Output::SQLite3}, q{Expect Parse::Dia::SQL::Output::SQLite3 to be used as back-end} ); diag(q{TODO: Add checks of the sql}); __END__ Parse-Dia-SQL-0.30/t/691-output-html-get-sql.t0000644000175000017500000000276113035770477016554 0ustar affaff# $Id: $ use warnings; use strict; use Data::Dumper; use Test::More; use Test::Exception; use File::Spec::Functions; use HTML::Lint; use lib catdir qw ( blib lib ); plan tests => 8; diag 'HTML support is experimental'; use lib q{lib}; use_ok ('Parse::Dia::SQL'); use_ok ('Parse::Dia::SQL::Output'); use_ok ('Parse::Dia::SQL::Output::HTML'); my $diasql = Parse::Dia::SQL->new(file => catfile(qw(t data TestERD.dia)), db => 'html'); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); can_ok($diasql, q{get_sql}); my $sql = $diasql->get_sql(); # diag($sql); isa_ok( $diasql->get_output_instance(), q{Parse::Dia::SQL::Output::HTML}, q{Expect Parse::Dia::SQL::Output::HTML to be used as back-end} ); # Replace   with   (because the latter is valid XML, while # the former isn't - even though it's fine as HTML) my $xml = $sql; $xml =~ s/ / /gi; # Check the XML with XML::DOM::Parser my $parser = new XML::DOM::Parser; eval { my $doc = $parser->parse($xml); }; ($@) ? fail("Failed test using XML::DOM::Parser - invalid XML") : pass("Passed test using XML::DOM::Parser - valid XML"); # Check the HTML with HTML::Lint my $lint = HTML::Lint->new; $lint->parse( $sql ); $lint->eof(); my $error_count = $lint->errors; ($error_count > 0) ? fail("Failed test using HTML::Lint - invalid HTML") : pass("Passed test using HTML::Lint - valid HTML"); # Print each error message foreach my $error ($lint->errors) { diag(q{HTML-Lint: } . Dumper($error)); } __END__ Parse-Dia-SQL-0.30/t/963-rt66031.t0000644000175000017500000000175313035770500013712 0ustar affaff# $Id: 951-rt50906.t,v 1.3 2009/11/17 11:00:02 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use Test::Exception; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 7; use lib q{lib}; use_ok ('Parse::Dia::SQL'); use_ok ('Parse::Dia::SQL::Output'); use_ok ('Parse::Dia::SQL::Output::Postgres'); my $diasql = Parse::Dia::SQL->new(file => catfile(qw(t data rt66031.dia)), db => 'postgres', uml => 1); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); can_ok($diasql, q{get_sql}); my $sql = $diasql->get_sql(); isa_ok( $diasql->get_output_instance(), q{Parse::Dia::SQL::Output::Postgres}, q{Expect Parse::Dia::SQL::Output::Postgres to be used as back-end} ); like($sql, qr/.* alter \s+ table \s+ tbl_detail \s+ add \s+ constraint \s+ tbl_detail_fk_Fk_main \s+ foreign \s+ key \s+ \( \s* fk_main \s* \) \s+ references \s+ tbl_main \s+ \( \s* pk_main \s* \) \s+ ON \s+ DELETE \s+ CASCADE \s* ; .*/six); __END__ Parse-Dia-SQL-0.30/t/207-parse-classes-uindxn.t0000644000175000017500000000342213035770477016734 0ustar affaff# $Id: 207-parse-classes-uindxn.t,v 1.2 2009/02/26 13:49:07 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 47; use_ok ('Parse::Dia::SQL'); my $diasql = Parse::Dia::SQL->new( file => catfile(qw(t data TestERD.dia)), db => 'db2' ); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); # TODO: Add test on return value - call wrapper $diasql->convert(); my $classes = $diasql->get_classes_ref(); # Expect an array ref with 14 elements isa_ok($classes, 'ARRAY'); cmp_ok(scalar(@$classes), q{==}, 14, q{Expect 14 classes}); # Hash with class/view names as keys and unique index (if any) as # (hashref) elements my %uindxn = ( imageInfo => { 'idx_iimd5' => [ [ 'md5sum', 'char (32)' ] ] }, subImageInfo => {}, imageCategoryList => {}, categoryNames => {}, imageAttribute => {}, userInfo => { 'idx_uinm' => [ [ 'name', 'varchar (32)' ], [ 'md5sum', 'char (32)' ] ] }, userAttribute => {}, userImageRating => {}, attributeCategory => {}, userSession => {}, extremes => {}, ratings_view => {}, whorated_view => {}, users_view => {}, ); # Check that each class has of the expected uindxn attributes foreach my $class (@$classes) { isa_ok($class, 'HASH'); ok(exists($uindxn{$class->{name}})) or diag($class->{name} . ' uindxn :' . Dumper($class->{uindxn})); # check contents is_deeply( $class->{uindxn}, $uindxn{ $class->{name} }, q{uindxn for } . $class->{name} ); # remove class from hash delete $uindxn{$class->{name}}; } # Expect no classes left now cmp_ok(scalar(keys %uindxn), q{==}, 0, q{Expect 0 classes left}); __END__ Parse-Dia-SQL-0.30/t/645-output-mysql-innodb-get-drop-index-sql.t0000644000175000017500000001166713035770477022277 0ustar affaff# $Id: 644-output-mysql-get-drop-index-sql.t,v 1.1 2009/02/23 07:36:17 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use Test::Exception; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 48; use lib q{lib}; use_ok ('Parse::Dia::SQL'); use_ok ('Parse::Dia::SQL::Output'); use_ok ('Parse::Dia::SQL::Output::MySQL'); my $diasql = Parse::Dia::SQL->new( file => catfile(qw(t data TestERD.dia)), db => 'mysql-myisam' ); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); is($diasql->convert(), 1, q{Expect convert() to return 1}); my $output = undef; isa_ok($diasql, 'Parse::Dia::SQL'); lives_ok(sub { $output = $diasql->get_output_instance(); }, q{get_output_instance (mysql-myisam) should not die}); isa_ok($output, 'Parse::Dia::SQL::Output'); isa_ok($output, 'Parse::Dia::SQL::Output::MySQL'); isa_ok($output, 'Parse::Dia::SQL::Output::MySQL::MyISAM'); can_ok($output, 'get_constraints_drop'); my $drop_constraints = $output->get_constraints_drop(); #diag($drop_constraints); # indices like($drop_constraints, qr/.* drop \s+ index \s+ idx_iimd5 \s+ on \s+ imageInfo \s* (;)? .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ idx_iiid \s+ on \s+ imageInfo \s* (;)? .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ idx_siiid \s+ on \s+ subImageInfo \s* (;)? .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ idx_siips \s+ on \s+ subImageInfo \s* (;)? .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ idx_iclidnm \s+ on \s+ imageCategoryList \s* (;)? .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ idx_uinm \s+ on \s+ userInfo \s* (;)? .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ idx_uiid \s+ on \s+ userInfo \s* (;)? .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ idx_uauiid \s+ on \s+ userAttribute \s* (;)? .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ idx_uiruid \s+ on \s+ userImageRating \s* (;)? .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ idx_acid \s+ on \s+ attributeCategory \s* (;)? .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ idx_usmd5 \s+ on \s+ userSession \s* (;)? .*/six); # do it all again this time for InnoDB with backticks $diasql = Parse::Dia::SQL->new( file => catfile(qw(t data TestERD.dia)), db => 'mysql-innodb', backticks => 1); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); is($diasql->convert(), 1, q{Expect convert() to return 1}); $output = undef; isa_ok($diasql, 'Parse::Dia::SQL'); lives_ok(sub { $output = $diasql->get_output_instance(); }, q{get_output_instance (mysql-innodb) should not die}); isa_ok($output, 'Parse::Dia::SQL::Output'); isa_ok($output, 'Parse::Dia::SQL::Output::MySQL'); isa_ok($output, 'Parse::Dia::SQL::Output::MySQL::InnoDB'); can_ok($output, 'get_constraints_drop'); $drop_constraints = $output->get_constraints_drop(); #diag($drop_constraints); # foreign keys like($drop_constraints, qr/.* alter \s+ table \s+ `imageCategoryList` \s+ drop \s+ foreign \s+ key \s+ `fk_iiicl` \s* (;)? .*/six); like($drop_constraints, qr/.* alter \s+ table \s+ `imageAttribute` \s+ drop \s+ foreign \s+ key \s+ `fk_iiia` \s* (;)? .*/six); like($drop_constraints, qr/.* alter \s+ table \s+ `userImageRating` \s+ drop \s+ foreign \s+ key \s+ `fk_uiuir` \s* (;)? .*/six); like($drop_constraints, qr/.* alter \s+ table \s+ `userAttribute` \s+ drop \s+ foreign \s+ key \s+ `fk_uiua` \s* (;)? .*/six); like($drop_constraints, qr/.* alter \s+ table \s+ `userSession` \s+ drop \s+ foreign \s+ key \s+ `fk_uius` \s* (;)? .*/six); like($drop_constraints, qr/.* alter \s+ table \s+ `imageAttribute` \s+ drop \s+ foreign \s+ key \s+ `fk_iaac` \s* (;)? .*/six); like($drop_constraints, qr/.* alter \s+ table \s+ `userAttribute` \s+ drop \s+ foreign \s+ key \s+ `fk_acua` \s* (;)? .*/six); # indices like($drop_constraints, qr/.* drop \s+ index \s+ `idx_iimd5` \s+ on \s+ `imageInfo` \s* (;)? .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ `idx_iiid` \s+ on \s+ `imageInfo` \s* (;)? .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ `idx_siiid` \s+ on \s+ `subImageInfo` \s* (;)? .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ `idx_siips` \s+ on \s+ `subImageInfo` \s* (;)? .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ `idx_iclidnm` \s+ on \s+ `imageCategoryList` \s* (;)? .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ `idx_uinm` \s+ on \s+ `userInfo` \s* (;)? .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ `idx_uiid` \s+ on \s+ `userInfo` \s* (;)? .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ `idx_uauiid` \s+ on \s+ `userAttribute` \s* (;)? .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ `idx_uiruid` \s+ on \s+ `userImageRating` \s* (;)? .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ `idx_acid` \s+ on \s+ `attributeCategory` \s* (;)? .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ `idx_usmd5` \s+ on \s+ `userSession` \s* (;)? .*/six); __END__ Parse-Dia-SQL-0.30/t/620-output-get-schema-create-db-model.t0000644000175000017500000000315513035770477021163 0ustar affaff# $Id: 620-output-get-schema-create-db-model.t,v 1.2 2010/04/16 05:07:34 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use Test::Exception; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 11; use lib q{lib}; use_ok ('Parse::Dia::SQL'); use_ok ('Parse::Dia::SQL::Output'); use_ok ('Parse::Dia::SQL::Output::DB2'); # 1. parse input my $db = 'db2'; my $diasql = Parse::Dia::SQL->new( file => catfile(qw(t data db-model-fk.dia)), db => $db ); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); is($diasql->convert(), 1, q{Expect convert to return 1}); my $classes = $diasql->get_classes_ref(); # check parsed content ok(defined($classes) && ref($classes) eq q{ARRAY} && scalar(@$classes), q{Non-empty array ref}); # 2. get output instance my $subclass = undef; lives_ok(sub { $subclass = $diasql->get_output_instance(); }, q{get_output_instance (db2) should not die}); isa_ok($subclass, 'Parse::Dia::SQL::Output') or diag(Dumper($subclass)); isa_ok($subclass, 'Parse::Dia::SQL::Output::DB2') or diag(Dumper($subclass)); can_ok($subclass, 'get_schema_create'); # 3. create sql my $create_table = $subclass->get_schema_create(); #diag $create_table; like($create_table, qr|.* create \s+ table \s+ man \s* \( \s* id \s+ int \s+ not \s+ null \s* , \s* name \s+ varchar \s* \( \s* 32 \s* \) \s+ not \s+ null \s* , \s* constraint \s+ pk_\w+ \s+ primary \s+ key \s* \(id\) \s* \) \s* (;)? .*|six, q{Check syntax for sql create table man}); __END__ =pod =head1 TODO Add tests for associations when that has been implmenented. =cut Parse-Dia-SQL-0.30/t/646-output-get-schema-drop-sql-mysql-innodb.t0000644000175000017500000000403013035770477022413 0ustar affaff# $Id: 640-output-get-schema-drop-sql.t,v 1.1 2009/02/23 07:36:17 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use Test::Exception; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 21; use_ok ('Parse::Dia::SQL'); my $diasql = Parse::Dia::SQL->new( file => catfile(qw(t data TestERD.dia)), db => 'mysql-innodb', backticks => 1 ); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); is($diasql->convert(), 1, q{Expect convert() to return 1}); my $classes = $diasql->get_classes_ref(); ok(defined($classes) && ref($classes) eq q{ARRAY} && scalar(@$classes), q{Non-empty array ref}); # 2. output my $output = undef; isa_ok($diasql, 'Parse::Dia::SQL'); lives_ok(sub { $output = $diasql->get_output_instance(); }, q{get_output_instance (db2) should not die}); isa_ok($output, 'Parse::Dia::SQL::Output'); isa_ok($output, 'Parse::Dia::SQL::Output::MySQL'); isa_ok($output, 'Parse::Dia::SQL::Output::MySQL::InnoDB'); can_ok($output, 'get_schema_drop'); my $drop_table = $output->get_schema_drop(); #diag($drop_table); like($drop_table, qr/.*drop \s+ table \s+ if \s+ exists \s+ `imageInfo` \s* ;/six); like($drop_table, qr/.*drop \s+ table \s+ if \s+ exists \s+ `subImageInfo` \s* ;/six); like($drop_table, qr/.*drop \s+ table \s+ if \s+ exists \s+ `imageCategoryList` \s* ;/six); like($drop_table, qr/.*drop \s+ table \s+ if \s+ exists \s+ `categoryNames` \s* ;/six); like($drop_table, qr/.*drop \s+ table \s+ if \s+ exists \s+ `imageAttribute` \s* ;/six); like($drop_table, qr/.*drop \s+ table \s+ if \s+ exists \s+ `userInfo` \s* ;/six); like($drop_table, qr/.*drop \s+ table \s+ if \s+ exists \s+ `userAttribute` \s* ;/six); like($drop_table, qr/.*drop \s+ table \s+ if \s+ exists \s+ `userImageRating` \s* ;/six); like($drop_table, qr/.*drop \s+ table \s+ if \s+ exists \s+ `attributeCategory` \s* ;/six); like($drop_table, qr/.*drop \s+ table \s+ if \s+ exists \s+ `userSession` \s* ;/six); like($drop_table, qr/.*drop \s+ table \s+ if \s+ exists \s+ `extremes` \s* ;/six); __END__ Parse-Dia-SQL-0.30/t/700-utils-load.t0000644000175000017500000000040613035770477014736 0ustar affaff# $Id: 700-utils-load.t,v 1.1 2009/02/23 07:36:17 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 1; use lib q{lib}; use_ok ('Parse::Dia::SQL::Utils'); __END__ Parse-Dia-SQL-0.30/t/210-check-versions.t0000644000175000017500000000375313035770477015610 0ustar affaff# $Id: 210-check-versions.t,v 1.2 2009/06/23 19:54:29 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use Test::Exception; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 15; use_ok ('Parse::Dia::SQL::Utils'); my $pds = Parse::Dia::SQL::Utils->new(); isa_ok($pds, q{Parse::Dia::SQL::Utils}, q{Expect a Parse::Dia::SQL::Utils object}); # negative tests ok(!defined $pds->_check_object_version('foo', 0), q{unknown object type}); ok(!defined $pds->_check_object_version('', 0), q{missing object type}); # positive tests ok(defined $pds->_check_object_version('UML - Association', '01'), q{UML - Association 01}); ok(defined $pds->_check_object_version('UML - Association', '02'), q{UML - Association 02}); ok(defined $pds->_check_object_version('UML - Class', 0), q{UML - Class 0}); ok(defined $pds->_check_object_version('UML - Component', 0), q{UML - Component 0}); ok(defined $pds->_check_object_version('UML - Note', 0), q{UML - Note 0}); ok(defined $pds->_check_object_version('UML - SmallPackage', 0), q{UML - SmallPackage 0}); # negative tests - unsupported verions ok(!defined $pds->_check_object_version('UML - Association', 3), q{UML - Association 3}); ok(!defined $pds->_check_object_version('UML - Class', 1), q{UML - Class 1}); ok(!defined $pds->_check_object_version('UML - Component', 1), q{UML - Component 1}); ok(!defined $pds->_check_object_version('UML - Note', 1), q{UML - Note 1}); ok(!defined $pds->_check_object_version('UML - SmallPackage', 1), q{UML - SmallPackage 1}); __END__ =pod =head1 Test of XML object versions. List of supported object versions =cut Parse-Dia-SQL-0.30/t/962-rt57842-postsgres-int.t0000644000175000017500000000216513035770500016540 0ustar affaff # $Id: 962-rt57842-postsgres-int.t,v 1.1 2010/05/27 09:21:47 aff Exp $ use warnings; use strict; use locale; use Data::Dumper; use Test::More; use Test::Exception; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 6; use lib q{lib}; use_ok ('Parse::Dia::SQL'); my $diasql = Parse::Dia::SQL->new(file => catfile(qw(t data rt57842.dia)), db => 'postgres'); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); can_ok($diasql, q{get_sql}); my $sql = undef; lives_ok( sub { $sql = $diasql->get_sql() }, q{get_sql should live on supported model type 'Database - Table'} ); my $outputter = $diasql->get_output_instance(); can_ok($outputter, q{get_associations_create}); my $association_str = $outputter->get_associations_create(); like($association_str, qr|.* alter \s+ table \s+ sales \s+ add \s+ constraint \s+ sales_fk_User_id \s+ foreign \s+ key \s* \( \s* user_id \s* \) \s+ references \s+ users \s* \( \s* user_id \s* \) .* |six, q{Expect constraint on sales}); __END__ =pod =head1 DESCRIPTION https://rt.cpan.org/Public/Bug/Display.html?id=57182 =cut Parse-Dia-SQL-0.30/t/data/0000755000175000017500000000000013105115727013066 5ustar affaffParse-Dia-SQL-0.30/t/data/many_to_many.097.dia0000644000175000017500000000307613035770500016561 0ustar affaffJmany_to_many.097.xml\K6K[ʲl$ZҜZev)Q%^걲%ab+k|3C9H+ϐ2Ddjzl'a=xFs(pOɁstz<U|bb NNR 8%Wp;ɡ$I,Y<G4Q3(O5lڨ!ͫu}'_)_$RLyϋwIɅ"CKA <Gǁյ"fV5&v÷C  .Cx1*l,Er{90ƁrmM3סHj(rD6?/+~H3bha㽩/0|D!V:=kh@ȆeeJ4i]r&# N&꿜i%idQ맋_≳]yPb\7-oBP$O/ԥw_d(oP'c, 71VMϐ# DBY-6ɈْNV\dOm觏9vZܖEI? _&ZtSa1 P X+uӅ\Fbn3QmTme\/fT˅e^C%uRެ^ll'5B|0ئ|zt?x^c:4o C߆"vʤ(xw/~CbW^Ye+"댉j5m&3_[ !  ^\!vF>sCT׈srk% {ܵQvL +嗎kg}ۑ òڣf~ێI"ag"\Zк"f26i^ϗcvr@`45Ӂ/y?068"@-7K":'$45,bBXT{=j M=4t YAmJPQl>nhX U3rR&Ozϡ_%]DIv8p0L%Euj`۹*~"cuEH'4 VjT'€9Z/ͯ?@L+T:vyuMDJ&jq=g?MVҿ9fY\q+kZ]~>x_tqv6#bzG'f%ϟ߿k L~t5ℨ"Эr50ΏF|[ Oq\)]Y'c]2pKH=G>@\F?O~N&}St!B҅P)#ADRدI?z.~7I7n܈q?-ߥ>PHDPaP1q;v(HK +N@lIOX"}Q+}GW0<'Jxόψ"PJ8de;9g=}TiRH}VN;AXjjt)lڠN9vw;0xJxJxJxJxJxJxJxJɵ`.$]HxJ?~$5ҍ}꘾SEҋFM̏%8RRfT)3Q'Ru2UDjCRuu9oIkSEetS5SvҜlD(*~TăwjnJ"^)~?mzZV,_S4vKz*TV%To/\G#Z>( xSm/L!A0ޞQ6 pSy 'W÷n'ٓ3gs56Q.T}dF^`a4TEKδrEo~:.ヰqR(re*NO/Q5Vbk/f͔Wֈ('jS/\+8E5Vpe!k=F^P-nf1b.кi&F0Lu[ָI\WCgbsoϢ.{4!Kgȇ?|iHJ&SUN$i^eVD5yTIX6}82q.a3#/uHoyY"|hp`)Pt0palKB'@񂛖qb-e 8khiJLWԙlz ƳBsnM̯{?¤O{wvG=p=o .&V\kƨ܁9{c4ݽ}N~&w7exParse-Dia-SQL-0.30/t/data/long_fk_name.dia0000644000175000017500000000300113035770500016154 0ustar affaff[KsHWP őSI[l#4a uo VTe^C@%stUģ>"\潏;0*“wsu)Dn4ZV^s (05G`$ԧEkU Cn,B@ јj*_QL\]/u zѺ|fMDGņH.먲FN{oME$x8T/dRDTqopSMӔΰfLN'ù~Xp;e$. 8Xncfb'_1 K#7`?5RVK#weIAq5/?4{no2iǃoC ZA|OlI|uLvtX!J =ￔ{3Cȟ_oHI2U2m;3LmlM&:-0? [<-m|g<4GW4)EISGլMx&2[`-! l=tXH*H}H MmLk!$3p숽Eq1ȹwEe AmΪ3*XM4=P:܊{kRxKPI9ћϽ:;w5˴AP@RLM7ta|ج_ Be䚲!RBy<*\bGV.4ff4D.pbѷQ)kQYVxIyZdj}4B@ꙖO:au&O"Rդ{s5X lq5ϻgaV|5lr7xJ\mt%k#GXlM*xHdWÓO!> x5j_VZ#$q7l0Z3K=?d :Ϗ<<5s=G'Z0j+7yϨfܯњ4˺35SWܙc[Sm)Ҡs_ԦVdE d@d@d@d@d@d@dW d@t eOc5? GVI89ٱ)R #@ Z!( `IiYo~ ͣC =oG~_+^}/~:Ї c0F#C{L#dmcCtQfLdKӒ0q24ƚ>52tRCWrMe?9VfZI:0ۥ EM*"#ũBA̱2<5w<@dWB1tnJ5!AN5 @Nkg֟?Fzn$HRG ɲ"'?n #TzrXoK7կT*][O7!?#MDParse-Dia-SQL-0.30/t/data/association_dia_0_97.dia0000644000175000017500000000263413035770500017437 0ustar affaff[K8@5M2=hfv532oڦӹo_ȃWhW@ʮr; `-k*K0po-ۓ)<|v$< |Il-8?^8 F1 yK. ]SdGJZQJerJmrL<xЦիVűZuQBZT뇄!!aIFOy!I1!xǯԤYW CAGSu cebcξ///bVH(2M HQ9`w,5zxE[H/mz7'Qe\>F W0wĐa(? 8:I>s6jׄ4/^\Y^F.7E(wk`K:iy*ޏg1!_ᙳCzc|n@DܵCG$`)T!9'E-}vԩv*A3x]*bfnhCr P%I );ubck`ʋ;n`n)+īlgRH[B$>~`{EJ-B!YPD4Ҁ1qͺѩ|Fem)&A[y* ,JhaK4/apyN{I\h(,ClՎ#E7#v~q}4bkKu?&ma-$ ,h?hRIDkB L`76FwMOhCN'2Ɖ[k) v44C9r@#ڜ~*VKSʖ"{MU1 m1r.Yxڠ|, |C(_V㥣Md||.%\qa R&@e%] +FPϸKf=LvFvC✵CFgJN9CSL?uʜiE~m̃c[YmOYn֛V6Ҙ- =Yƫ͹14b-}q{qhVyD6_h_(b&eʲ+C;K$F#WHAWn*RVA~D[GyX_ʆ&qBI t_NdS4t䆃pH2+i<"@f'#xzf-Y+ܬ_)TlmCuÿ0r;Parse-Dia-SQL-0.30/t/data/db2.pre.dupe.dia0000644000175000017500000000160413035770500015734 0ustar affaffW[o0~ϯ\&6iO6isdx56MS^wI&RP0s9]-(ͤY}۵PFL3o'ֻy:b Bw3keLz8湦F*Sk#d s,5F 3@M`f4DdV](Tu ˩`=SCtC8SSPu$ӆINqݱ4x~ uQnm$TL40> gi1F?po\ ^,zY:TFQf(YtRG!/1/)ׇ8PNgܱ+={(kUτ~4 8 dΦoyJN&D@?rm:VXv T~+դzUى ~Bh*~|Dޒo v_q1ʱ>`bk(ɳSqf:BG9 7=uG+o!cTR,BDKxR6x>" B0D*p:3OM29bʔWW&9YfsEw|0~T\vQBVT#)"aIBOy&Iq)DOԤI%C+ADHG054M ki/|abι---2eHR IQ`w,S[= !hyjk[>CITh!Olo#+վI+Q_|:I>3Rm˃gC Z?B5iдfuQ/5 LzX'!>-Js]ￔG C[_|lHM핂c=ksI3E~)gz@| [0X<0G F7^zY~~,z`m!aw+LHȃ8!2H㤭 !0D8^B!PTN@Ȧ1ajT~Х@Y$(`#snAu\?Zνp!˽4,aze*6z`mz;ĸ>*7oxVS6 @xRJ( U}<ȱ%UF A ЦX`?S}u0k}-r;YT41n<(֛l9G+O_@.H" u6ǾlNdM)eKzYqV=ßzC`Wk c'pP>7NVuŭxpl <*X+TG՚ߕ>d]$T($x0֨wx0KpDAu=g[\؍5d<;/5w< w=jɱ/e~R}e,Ͱ ]ֈ DyXjeBaIQI~5ᱤgkDJF)SW2''jb&jb&jb&jb&jb&jb&jb&j`&eHhEg,f_еP^ptx拄],;Ll׉+]54u%c|n]bysjFɊfR}_0H2 kuoCqv%$h}UO̵d ",P[ [,G􁀣.C G 4xSѵRBfKiwl2.W t5^JK̅fpY~e`Rq\J'o^y")b:Parse-Dia-SQL-0.30/t/data/rt57842.dia0000644000175000017500000001210013035770500014574 0ustar affaff]n} <eƥ $HL&y(H IO4fzGW|D')ɂyQݨF7W_>|/V< Nj<0bo|{4Yղժ$ԸW_W7nn9ܛ4T_[ynv;'Y&{jjFw RzRP͓ϓ b&7o{x}ދQdKmcH-8rz(&IoSnQL#۷<0"xpz7{̋l')b!S*H's&fAwֿ7VU4phI4D< lsS"^fL=M%ojR1->pyHy۩?nVs4ǗѬjF( IȽtR@[82ś_ugGm|2af!Ca4M'~;֛Y'ܛ(叚J)&dAZӢP gD(.I8K]8uEb&{_J*͟>ÉWL'TrݗllV3VKپFW =GIMX3;j9p/Me{,zn9޵ ʾq}'m0HC/j͜z Z ۲5OÙ>_ǁjnFa x1[9_wٱ,b1ϣl6]řvc%qR '/Oh# %T3jׅ! EEz{4< Fy8 ܛ"MQ{H'.GYn + ELmi2BL$/›#"\1Ju.]=?iS'I9qkUڔ2*SC!L]*B۹RPKeED+هs-ZjQEZjQEZjQEj(pP(ӊBg6Ks#0Fk?.D@r&jߧrjI@j 3尦I\r@]"lP,'Ḵ;=`PVr9UN+7.D9V݇D9Z E9P@E9P@E9P@s1#C!ǁ!Ɂ7jͲ$!@ Q#S{ל&@YeeA#eo,`.-VJV̘ CaaW"ʦ4RzJF;Rprtih )h )h )]{h 4IQΪE\?MG \"x?~|GFhg{d^Mezϯ[}NŐק7ΌԋOwW9"QeB(\bzPQE("@g7mM-bsnJSX4H^Sp}Nd) \Ƹˇ1a"l9`p۱: v9P9) VgAZSߍ5|MM"\*TCC*a;PCqWEɢK-Xt\ўI5:/Ɲ=bϹvv] oE\Юӣ]G2ȂrL:z[ DHbrwȸSJYV߅kӡpXvj~kh*Wb_[/ЯkA1Y~7/jBCE/*2`N.nlw1Prܧ|{vmɲ8}aϙ``&X|/G:ίo?ppAy#Frڒm?yuiOO^"ww4^M^i 9YWlЮkYUxίjeW-Los\"֥T8Cl$q9]njKoℙÂMd?µ'otl\j8j8j8j8j8j8]L 'Q߅gPǩ۬_>r:yzS]Y A(̈́@Q+#'~ā$doC+vzZ.+{Kw4n%8ȁKxH2"=MZi䱬Kh$]FE 0dZ6fZ]< 0&e[^.ҁKrCl.q6*4;2"L֌o?ߒ *l-G8j\ڶ Chh[2m9ԛ/kڝqԼm׊CĦRn?4MM,wj-x4ģ! hGC<x4ģ! hBLbҠlW 0E ?&i8׋PEN?`qkyHʒpL]'H"˝r"g ;|(GqP6~MP9*&0EVa( +$'fsW囪1'z< ] e%62FLpwocǺF|=iX{fmX[Y":N`rV>-4T$[XR˷Mxl{mt1 b?H: V^Vr0)m|_/ƛ.ה[ZNQ4܁kS4eJ^՜׺ήv̶s%"1.Mz=o?XL پ پ پ پ پ پ 9_9.36]& |+9@NW +pTL:{@Щ(tnT$b BqGZ QD \p@68$C_ovnM9ĵNӪWʠDkADkADkAڥ5xd4=@O墔/lq89ݓcYd8Ru|ckK\dCa뤽>ةkdo>8 Йgz9C@ :6%b !mP{i4d֥4f mP̰u|aWu m)`w*ㄛ2b6TWYilk C]C |+5(ڠm6EB-\[ț-dbݬź?j÷Mb7iPˢ_Y\,&'\!,&)T+A~Psqs8 Lԣʾ?y?1Z~}.5϶,jI8 ؟RgWѳ?EEg6fyQoL"mZ̖ڲS{Wjᖶ[)%\ ס,ͦ乨0]mx.J:ב_>,_ԛ}h[d=Parse-Dia-SQL-0.30/t/data/rt52755.dia0000644000175000017500000000331413035770500014601 0ustar affaff\[8~_җV ! m3Zu]uFڷxk0k !nۙ@k2DiԍCx(_^Ozoy| M|#dn[rtbc h\iھp OcpڛOIzuK0=ދEr~FB\!.ǩ":4/6C _E&%r{mVL4 _ 琾X>;l)QX׃aȜ6r9ܼ[8-YD(" AF4q bǺeV@/ft`xkqZOwx3-J< /g- Z%9G!oL05gZZM ˗?Fd'YMeڬj܂@`4aTk NG.G1!E{}Ā .򦽯Fv} *"}mfE(P>; ao>kG7jx`:$LR؆E}`5_rsnRIJ}Kp  65`.+,1plh(:>4(Z,Ugv*aUKk 灂T,}%(*F5(̈́ g~,wt @x5$$,p_IJ8FkIL7B & ?}cOUc^FKV(P-e\?O€෭W+#$#S UVgrXzc2օ5Şt- }#a3s;䌱vx'qFy[p9kT^d~x۸%9'mW%>Z)[{n!k j+qF|uqp v9́-ߙ 'v\rxzT;l2ޙ~; gm?~D()#]"D`[q|=Z?&W~>|Jw2qޯ5郼<}؊VQ`aFfylS>r욋|.U\02wr'5X<@=0JkLdl p6Ey cLءlˮ~ZtK ztYቨ㲣DQT9rI [}m>іI7vʳBYNh3 8P P1b*T Lx]bIRM01; ۙcӲ[ ۺH:αG Tz@UU=TPz@UU=T~.$p.?T" N(QS~XtfD2|7e9Or)L-G=Mm2FMd ,Sv/e˜[d-[圁;+%a6S,ʆK-U㖵%w<6]k2*ٺC$51akd^с>jwY4f\:OoV^!e uCx(?}Ow=>@w,o9>ǛF[8FX}Sc 9S9TBOIzj&˹PW顎s5ゞ3#%^.Ҳ " *"5zG2B|yz8:eh-QXY 6 CÜs}6Mv1n9, )@ $Cfư9sC[-X!WkN)'nAFy|L'%G!L姓V-GCvzlhBمaVѴƗ^60٩dB`4W0M++Q/ܽ<(_1`L=@BcSFheGУff:eY=փp!fdY#[ VہJ1ҲQuj_2&-t!׼^f酣!X!*C ɞ !$uH!D􃥸s3M!BƜ;2LtQ5ҥ@x-r IQJAZkTo?#:]`ryhQf08bCI](v/5[aVŵm~}XagE89@v$$,.TƷIo#LWSi3]nbmLxBmM+"xȢAq0) bh~r42-Pcs洋M^Dn4jI++bkvӧ݌ :lq]ĝt:;WҚ}]yx/\). k3FݤX\TP ~|3z?'F)8AN*ÜX]Il6_s$I4P$˚W@Oi<\+aN#]QMH iZX"qI[xGl^E (ӹhj9kWη_ױGuZAJWr󕜯|%+9_JWr8l] O2-AZSIJ=e:dl |ySL"Ds@9GD&`5d"Dz?CｧL?qQ^$7'SҬ7i S-|2afNfM!|~ yjϵRNF`OVYfE'kjD̵9 愒_QkxfNGx(INu&1S) E5S״_:} }am=cq=].Gf4+g. ì2]Q zNǕU1͓If|ɤr~|W4#VdGParse-Dia-SQL-0.30/t/data/rt56357.dia0000644000175000017500000000161513035770500014605 0ustar affaffKs0 &<i̤N%={!QI^0P$3hZvW<|D[ѱni0}/޳ѓ 8 5 *VOc}.ed @q`A Si>h5")9vc E!uyg1*a\[ 2of\,ЎP.^/m1ueÈ LdULjtVwlr+h0RɖOn-$CL,9o8xνܯ^Ga1aYE@4JCwQ!vh[vw58fk_ނEr>2B ,K`1gO#_>4o~b4dj%NfEynf6ylwcRN%sm3<0x2%"ڝԏm'V] *9 +&uj nY= (1>}ct;4쎴$BǞ©8v!sX ISUi4hwš7Va$|* ļzDѲ!T #f#."2Xv7X].4.)Wo_T!N_Ρ^U@1O?Xbچ2bĥ6Etƪ~[i3b(T2YBU2ux3] *6 $ݫWAv %p ~ 92p@>to_yM\ujӍ}oQʡ3j>h9C,圍UͥǕ.+{ I&Tvޞ4%qS{8 gg 3?mH5Aヹio/}+'2qParse-Dia-SQL-0.30/t/data/table_output_options.dia0000644000175000017500000000220013035770500020017 0ustar affaffXs8~_q!p@ W$izL/FWYr%Om x&]vWKqim1uF@8`cx]ޠ"6RzwrI d\'j -%WPp-^Rrl ]4Lht8ER`Hô8= #3PpXC< zL`%"/#ߑ{/l)K"]L<7$rDGt:p04nOә#㗥b1.92Ki2F>#,HT23,%+8ƀhysʞ\cMH,-3+B΄Sy24Ye5!B-P|yp|l#QfIy,*zZXDKb 0@<ؖiopq$^"Kƾ܀Gж j?=^Ҷ)$36:zf<Ls>A^/$Unoj!"ȝZlp:V$TlF g<\s'kz->)%HEm8baզPGETềEn06xzizhOO߾N?&#%&v}͒CƬXL5\]~줩jє ds6qI#yeBA5QH>d,nTܙ&!9y( ѻ< (Xk`]L2ʄ-լ j"Gsx5uI`R$W1{slU(P-e ?"Tb5_Y -L`:|gd5)\ }Jlr+"4EG?L>Fтpv S8NH3>0ɫɋUJ ~2>AB$>!'c9] n, g"n8*Faӎ >=s4{Gz+8:Gޠ"y ){\VG"g=MD\>؉$h0E3eqmTC7ss;D>8k=d:^ B&2qX1IVBQv~On9[K$}L\*>$ Ɲ1L1ꏇ`tuuu鰰C%GXV) JAw"RвXJq͉k{z}Ç`Qž\o W_}vSy6u6\{|su \z&Dndu䟏ZQ:O,yfo~ު]Q|}OI˗?.0sٽav]T\NYT.w9̲t߿"`ceٿQTYGc`uZ8>J6Gם>z1̚@FQo!4Cj}J~[C[|9ʖ}|O$ޞ&YS(d#•%>dU|>w-_q}=$,\EL cCR0no_2 ؛Y};ilfc[YVwp{9_sv_o{`4b#2lެ:RyEiomi}a^<*YuoL]fG؊U_XhseXto\}M\}_4\Z1eqhaP6 uq``7YZvndx{xW% 5I5vL&1+\rSQT&h[ m"O|Ga;%N b)h3F9YwE&j3t&3 L@g:Йt&3 L<P@Ǟf4n?Gyo%x^VG+AqCHM"_(<M kڲ^+4R^ͶW)Uxu$ ۟V3r^[ Z8WYVQTS탘,[-+8༂ +8༂ +8༂ +h{jq^+C|z=d] 48A(x8UpTbVbVV1c`wGJ{WYM7θiVr.ӨMn Gc^^]7ːVl4jY&i3,V֘&{;gUegUBu7z*jT #9Oo'Bb& عx%U\F8 ĪǑy8cV.O&LΦ,&Gdi:ҌDbi8㡕Y-}T}ηξkw nnRµu*LSFRjk|BE4ZF`9@oyhAUpUZ!BhC+s>oh[t%#a2/=_|!:kLm{^dBBʼnG|R4@2iK,cKL`^lYŨ_os[nB9|ܷ?ej}aØwWmAbҤ[16J>3\ϑ6r^\ JhKTq4@K5tʡRij@CE yl'Θ&9acFa hj1uJc KU5jQo^a Bq]bB XUBYeSh"y^8MlvWj9&BM4)jZ"ue9 b^s^~g}כ74X2NZia_Q ̐Ǭ'My%:ԴWEp$̳VV< ɵӌ|qR< I}:7i[wlSx,?ѱ-uphwDXF+lᬚ"]IYaTĕks-G:lbC8B<[~>zYqX5~ؑ?ո7Nz[B\8@U8vokJ.:xyS\^hV߿: ݣ= ݣhG{G{G{R(kz j )oO)f4/H`0 qo{m|;}  ǕJX!.gʊȮbs1Mݱ h1&R>\FR..D_g0bh_<+γURXp*)qsYQ,fHV3Rkz8SĀg/jGu[ 1ή1nMVň E93(ԎAZjZKm`yʗGUk80ZNU>wPGtzBs#hhZ#Q}\/IJ>lYQޱϬg'xNw1x(H,KC;>m+/!:]#0G\JP(ţtR>$Co28yPhB3 f(4C PhB3Oʠ 7x*d MR JV-5 9H]Be%%%{)12zZZxxx؜;02γj<59;瘪ss#p b*9Bp#s/=wN( s ΁8s ΁8s =!q. A飼JMa7v#?LJ7cd\e?_"PaYhU)Q$'Aˁ`9et [l!Al.I(n_Rrh[-'erv.EbRn15_8@ux,L=H!SC-GB8_x%m!ē]iݘA8!mJRi3Fifo #"?溘8g ]ZiaˏkRD4)DlB{UWJfoo.xml]s6ά; ·zӝ<䶝&WDR27%t~JvLo%Mc !@ە/}q  /$7C /K_?<ˈ$vE^_$W~J&aD|oCbQߧXW?<7phBgOiD|R@W9?/p8Rrv臑/[?vyOɽt#~.~f6^mW0Xn}P>GevbV(X7Ic>v-JV4Zz!k*11duݷKsppѰp^|$^r9CߥuAmg}^2Q /IžZ2\Nր3% s` /澛W/HJTPɿ]ޱGlV*5\yXn<Ǎ+ZLnv^U~ h/p>s~ mYzA8k';ţBٶٯ szA <7~2wo߮M<|NǗq6;QS<2|O&!gt8lǫN{wMiβ?-9{ NTTNK ےٍp@y\^¦7184/|/˃sYKmϮ4=-l|xc;$rgn+x؍=M(Vnz8# D 6$ØiL+Lj7Х:`(D[ hty0KB1)tTs**soH3:#3C;]y:Wj_܈U **r؎5s+Ĩr36F UK|(D~97_qoO64! nKh`E[#*ۏr_өx5yh9^Ⴝ=Cٚ*нEr&.8E03=2\"VLD*2`qe(D(2фLtQ- [LěЙ(Zz|L@g1t&c@gF~ L@g"@g:1>qH74pv<$LŢor~ɹV]+g=HWJwNXfa%)VV<2YZ\ Û%YB3ÚfWFuiyƚʖ=!}+qCj{H@\Dj JͦG~j51*CitM bLT( 3tJ5*te*Di%Rnԉe'!nC/LS$쨬n"ĎG8Q쨜jQ;*r;*K*Ya+X9(uV0z̭`8x#0rS2q|WT0kb v ޝck6?ڝ6E+wASJz J^PRhhuJ,]TK3\i40Xcf Bh@ `,c Ѐn(']/hFO{9`NE\ɣ۬oxUjuTXP3WY&-HU Ȩ @1Ĝ^AȂW%9ڦs4rR3ϨצʷqDf:1T{**E +[qY*FKczz[- Hu&t޺z3{TSF/muMLd~l4ȌtB]T-.Jrqei&v#eA-hТۛ%huѢe[-C hѠE]?@-z?-9`Z4؛5Ȝ{3/`cz>xO ;i*;J't S0cě`%QXY܋ -qÏSQ+)20O+qWoLmZ~N~M.n-D$V;L%`D팈v|U QU`GaGe8>8ہNAG;^oؑ)zl)qoO4 aB1{TTqWV6p YJ\ rQ_TTO8."^EQ;;&Qzhtt&^JASX]|oiv?lfQb7zs_rVUrVMrVu grV gբս.N%.tN}_œ`N]xRZU+kx*(ht# 0 ,(xn=`>^tQ&N;iAZpn=r6Q ҉VMVZ:[B;aZjuֵ7KP ZjuցZ' :P"@7r<>?0ZN 6MZ>=c9*m@UTRA!HҁZp*htXzztQ(NJbLTT: qDRuP*]ZբJ9P,Xpzzp{\c's-:[$/;s9pwp+Y f27 ]p}NPۃ#TU+ڠ&B1,`[i}JpGΝveLj Le~%э+Sd&>IT:T1zX- &w|tc޻@ Pڛ%(@u  (@$ A>kӽhf5m@ 멨 X44[qBWkQy;#ro^‚`AahqTdn!W 6DܛΕ2wmcu+pcULTT7ḣ' @FCk^#*]S$tk] 942TyhdjL4(B *Um%˓2Mbf-m+7 M:7܏p@nDss[s3A.~9s`A>y:7~x(@,(dTU+NV^'o5GÀJ €`@gi@VʎDA]ߵc:N8gBYoW|@E ;z> 1S<oYcDEeI tyˆھ;a=YFn/sJ"s^Kzqk~)))^_#1xg6s+6 Jl_|[/~rer7 nnnF ɖ<62FI;b,sv+MrZ٣x*+ϽXWM"G0(qԟ&K-X7H_Ry,eq*BM;8eęiӦ١Fu"FL[nlZcaO:( ACI70ٷZIh{wᑡ2U5S3EVh6U ff|dz#)˷&b1w,D4Nvhˏ4l'/W/1/\<CaH!P¡>-t= #)SÜBL Uxs2Yƻ~ th @34 PhB3 f(4C@hB3f(fhTFckxhpy!Xb/erVtT+j4GyL-DH oʾ"KKKjz\ vV`T <972hKDى4[l>&3ZZϝ3;7L¹smT;[Db+dm8\sMĹ: ΁8s qsOe_ݧe!inE{lZa7K}ɥ/[rW@z@@-,XV}ۛ(b]TM[z`=o=ԶŰWˁ[N}єu M#VƑw +r,T ƽw!gM6%Oۗ4#[)]9?FtBԮ!]1i1a\2s+DATֶݫBޓy}"!}wºyx/'%,LwHI(9O?.٬gp=gHrpwcyl߸+}DZJN"աdT~Nbejn5TParse-Dia-SQL-0.30/t/data/rt50906.dia0000644000175000017500000003571413035770500014606 0ustar affaff #A4# #tbl_main# ## ## #pk_main# #SERIAL# ## ## #tbl_detail# ## ## #pk_detail# #SERIAL# ## ## #fk_main# #INT4# ## ## #fk_detail_main# #pk_main# ## #fk_main# #ON DELETE CASCADE# Parse-Dia-SQL-0.30/t/data/index.option.dia0000644000175000017500000000277613035770500016175 0ustar affaff\s8_!mgNڙ{ό"'8~&2gz'#Xow]׀8RPRR׻擇Gg0'?-xdˡL'89 ch=p,&ײPX -5>qiU: $Kvq&fsBv}0EXt!VDcDlҒ9GkU\. _; YUւ2esMӔΰ1&o>i\\]s;L0Eҡ PQwB"CY=Xa!h+H9.ﳭm {7F{bm䮝@_0AUP\L2O'އ{FNZ͑ۃc0˯Ζ^\wcv u AL6 U#/P/̼W9-l8Ծyd+9'ꓑ[Vr8ELjC7J0'S}j"(]r;p1Rlڗ C7_Xkf0\{?j# MB7b0БBpjwm8޿wB޶3wW]4?Poyn`45) \5,UC4ϼdˮ~tڕY? }?\_&;Q&!?CU kCHF-XR hHy].I#4fnoeyA/x_%ۀhNꥌUPG"/H`:3Vo"R&8ʞϘ^&FKwr8 8p"zhdm_W,Ol h kHƾaKށLW"iH{E+^W"ihGE;*^*{iH.iyE+z^WJE7RV7=tdXbf=3}1Zְa9y?Ls]2nxPi*lXm ʜ5:q^$W5t",{XߍXCȀG!%1W`Lx [}/6(|Y%JqSoM+\qB ;IϳӀG֍G6dqs~+MkcnuZNParse-Dia-SQL-0.30/t/data/version.supported.dia0000644000175000017500000001372613035770500017265 0ustar affaff]is6_rݯ0Md<^TKRN 9EK*~(mHв|Ӓ q=MbEoO)1N5Y㷧|wNF{8g&ӫ|~~ssC⻂YN"??\4:?D_ d%eeGêZtȂu6\{|su \z&Dndu䟏ZQ:O,yfo~ު]Q|}OI˗?.0sٽav]T\NYT.w9̲t߿"`ceٿQTYGc`uZ8>J6Gם>z1̚@FQo!4Cj}J~[C[|9ʖ}|O$ޞ&YS(d#•%>dU|>w-_q}=$,\EL cCR0no_2 ؛Y};ilfc[YVwp{9_sv_o{`4b#2lެ:RyEiomi}a^<*YuoL]fG؊U_XhseXto\}M\}_4\Z1eqhaP6 uq``7YZvndx{xW% 5I5vL&1+\rSQT&h[ m"O|Ga;%N b)h3F9YwE&j3t&3 L@g:Йt&3 L<P@Ǟf4n?Gyo%x^VG+AqCHM"_(<M kڲ^+4R^ͶW)Uxu$ ۟V3r^[ Z8WYVQTS탘,[-+8༂ +8༂ +8༂ +h{jq^+C|z=d] 48A(x8UpTbVbVV1c`wGJ{WYM7θiVr.ӨMn Gc^^]7ːVl4jY&i3,V֘&{;gUegUBu7z*jT #9Oo'Bb& عx%U\F8 ĪǑy8cV.O&LΦ,&Gdi:ҌDbi8㡕Y-}T}ηξkw nnRµu*LSFRjk|BE4ZF`9@oyhAUpUZ!BhC+s>oh[t%#a2/=_|!:kLm{^dBBʼnG|R4@2iK,cKL`^lYŨ_os[nB9|ܷ?ej}aØwWmAbҤ[16J>3\ϑ6r^\ JhKTq4@K5tʡRij@CE yl'Θ&9acFa hj1uJc KU5jQo^a Bq]bB XUBYeSh"y^8MlvWj9&BM4)jZ"ue9 b^s^~g}כ74X2NZia_Q ̐Ǭ'My%:ԴWEp$̳VV< ɵӌ|qR< I}:7i[wlSx,?ѱ-uphwDXF+lᬚ"]IYaTĕks-G:lbC8B<[~>zYqX5~ؑ?ո7Nz[B\8@U8vokJ.:xyS\^hV߿: ݣ= ݣhG{G{G{R(kz j )oO)f4/H`0 qo{m|;}  ǕJX!.gʊȮbs1Mݱ h1&R>\FR..D_g0bh_<+γURXp*)qsYQ,fHV3Rkz8SĀg/jGu[ 1ή1nMVň E93(ԎAZjZKm`yʗGUk80ZNU>wPGtzBs#hhZ#Q}\/IJ>lYQޱϬg'xNw1x(H,KC;>m+/!:]#0G\JP(ţtR>$Co28yPhB3 f(4C PhB3Oʠ 7x*d MR JV-5 9H]Be%%%{)12zZZxxx؜;02γj<59;瘪ss#p b*9Bp#s/=wN( s ΁8s ΁8s =!q. A飼JMa7v#?LJ7cd\e?_"PaYhU)Q$'Aˁ`9et [l!Al.I(n_Rrh[-'erv.EbRn15_8@ux,L=H!SC-GB8_x%m!ē]iݘA8!mJRi3Fifo #"?溘8g ]ZiaˏkRD4)DlB{UW ]B0F*p{ VG1eHu r8gW .ZtzY6\QخJ&8#̊K#B@+x;5J" R3LNclP7'Ý_ӹcCYQ&@LR! )`l=e}5_/@zy5}{/o΢e|tn}{#5W^:I?<1R-·[D!0T -3A׋v:&Tذ e[-pq ޝCOdUCY ug=%̄%>lx4*A] 0SfL'[Z҅P&}v(#*jK8LUv.KM4}bGفk Qd6+ &8 DBQQȭޘb0"__EM蚑_hGVsrB |BHDEgݶXsj ipk@!YoW=K/Op4V"TYвkoe.6 B"_7Yg=g5ϟ c(ዋ?Qef˨/OǸǺ?u凈 5go_.kv PRq5r*lwhu:^&*i\I2'uR/w5`>la`7aAlwPFWm{bN5sd=M;2nr||C>Ԭ^q?O^qWܽw{+^q){Ev>.ҟp$ީNyND3oIʾk㗎tm$Q&N⛆+mdZW3KaQ)(j3cuuVTB&rkfz1: (gٲJ|0F7s2͎$8DVW h`"M~W(4:w t蛷yBþԣVzvw% ~6/A]F^xxX 0b'r_ 93Parse-Dia-SQL-0.30/t/data/table.col.comment.dia0000644000175000017500000000207013035770500017046 0ustar affaffXKHϯ@%2 NbGJ%9 褡Iwc<1 GvO}UUkD50iTg*qT|R?>zHo#1\e N'oMe=گD&B_cǴDZ|v|Pus?"{{¬.ӁVbzכr:\jA V *΁\Q㟯ʃ }!-oF7Mk$,{-$tAf=ߙ̜7mnW. i20i[EbX|X#@d4EifsY\BMfjF홍#kKnIԕ(Xmq}cbJ#EnԱ;Ei0ONEec%Qmϯ3]c4r*&܆dzk J鮐>+/ٲ@ 8 z} )L8`c!>&h,W1 1w:b]5G&RhLy\P.L ǿ-c4 )9_ %YDYbwFM.Rk*ɒb5Y.*Fd']o;:F']'`Ҧ|I«1/@qM0&Xd Njx{8jNsus,KhMyY#_!ޘo=\!M8+_A~ϔm%wW`Sj6hp=7( S6>//Qs1V^ΫNN{_Parse-Dia-SQL-0.30/t/data/non-latin1-chars.dia0000644000175000017500000000142113035770500016617 0ustar affaffWn0+KŶ;RҜ JL( Gv|7ȏڼ( `p8|3{#ӵhd>~50g!%7I ҧ9CrJb4cN9>3] Im J''1LO + X62ϧe9]ك='S3pz υWKN{)ģ= <ʍ[`0&2ʥòdt,;LWx]st:sϥj2%X`@xƊ2<* LؾmѧQJ:fƝz{#Iр!& }A Ϡ.zW_>o_c5dh-"-"Jh@}f}(ecJ {M du۪s1Htyɉ!|?+[ vc G/4JⵦeGѥ C=Yn]5h@4v B^)[SJ 9征k4a3Y kЎLA*GiG1AQ~OPzzQa3a. Uy 3OcIJ<">ꏍMEÀ4Xǝڍ))[ WpʟV4 *}zq7NqFZ:Zۈ;ՆHϱ4'q#Yjh,`o߶mParse-Dia-SQL-0.30/t/data/rt66031.dia0000644000175000017500000003566313035770500014605 0ustar affaff #A4# #tbl_main# ## ## #pk_main# #SERIAL# ## ## #tbl_detail# ## ## #pk_detail# #SERIAL# ## ## #fk_main# #INT4# ## ## #fk_detail_main# #pk_main# ## #fk_main# ## Parse-Dia-SQL-0.30/t/data/rt51433.dia0000644000175000017500000003571713035770500014605 0ustar affaff #A4# #tbl_main# ## ## #pk_main# #SERIAL# ## ## #tbl_detail# ## ## #pk_detail# #SERIAL# ## ## #fk_main# #INTEGER# ## ## #fk_detail_main# #pk_main# ## #fk_main# #ON DELETE CASCADE# Parse-Dia-SQL-0.30/t/data/typemap.dia0000644000175000017500000000403213035770500015221 0ustar affaff][6~_8/Ɍvڤfi3#Jb7C{fms[<$s#ዏH"@W(n?2?ݼqx-y8#`x-PHep/EFQ XzpN*P o+{D;ؕJ9<|;xN^qjfsv<Wk>c:4o C߆"vʤ(xw/~CbW^Ye+"댉j5m&3_[ !  ^\!vF>sCT׈srk% {ܵQvL +嗎kg}ۑ òڣf~ێI"ag"\Zк"f26i^ϗcvr@`45Ӂ/y?068"@-7K":'$45,bBXT{=j M=4t YAmJPQl>nhX U3rR&Ozϡ_%]DIv8p0L%Euj`۹*~"cuEH'4 VjT'€9Z/ͯ?@L+T:vyuMDJ&jq=g?MVҿ9fY\q+kZ]~>x_tqv6#bzG'f%ϟ߿k L~t5ℨ"Эr50ΏF|[ Oq\)]Y'c]2pKH=G>@\F?O~N&}St!B҅P)#ADRدI?z.~7I7n܈q?-ߥ>PHDPaP1q;v(HK +N@lIOX"}Q+}GW0<'Jxόψ"PJ8de;9g=}TiRH}VN;AXjjt)lڠN9vw;0xJxJxJxJxJxJxJxJɵ`.$]HxJ?~$5ҍ}꘾SEҋFM̏%8RRfT)3Q'Ru2UDjCRuu9oIkSEetS5SvҜlD(*~TăwjnJ"^)~?mzZV,_S4vKz*TV%To/\G#Z>( xSm/L!A0ޞQ6 pSy 'W÷n'ٓ3gs56Q.T}dF^`a4TEKδrEo~:.ヰqR(re*NO/Q5Vbk/f͔Wֈ('jS/\+8E5Vpe!k=F^P-nf1b.кi&F0Lu[ָI\WCgbsoϢ.{4!Kgȇ?|iHJ&SUN$i^eVD5yTIX6}82q.a3#/uHoyY"|hp`)Pt0palKB'@񂛖qb-e 8khiJLWԙlz ƳBsnM̯{?¤O{wvG=p=o .&V\kƨ܁9{c4ݽ}N~&w7exParse-Dia-SQL-0.30/t/950-rt51433.t0000644000175000017500000000173213035770500013703 0ustar affaff# $Id: 950-rt51433.t,v 1.1 2009/11/11 10:31:40 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use Test::Exception; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 7; use lib q{lib}; use_ok ('Parse::Dia::SQL'); use_ok ('Parse::Dia::SQL::Output'); use_ok ('Parse::Dia::SQL::Output::Postgres'); my $diasql = Parse::Dia::SQL->new(file => catfile(qw(t data rt51433.dia)), db => 'postgres'); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); can_ok($diasql, q{get_sql}); my $sql = $diasql->get_sql(); isa_ok( $diasql->get_output_instance(), q{Parse::Dia::SQL::Output::Postgres}, q{Expect Parse::Dia::SQL::Output::Postgres to be used as back-end} ); like($sql, qr/.* alter \s+ table \s+ tbl_detail \s+ add \s+ constraint \s+ fk_detail_main \s+ foreign \s+ key \s+ \( \s* fk_main \s* \) \s+ references \s+ tbl_main \s+ \( \s* pk_main \s* \) \s+ ON \s+ DELETE \s+ CASCADE \s* ; .*/six); __END__ Parse-Dia-SQL-0.30/t/903-perlcritic.t0000644000175000017500000000060213035770500015007 0ustar affaff# $Id: 903-perlcritic.t,v 1.1 2009/02/23 07:36:17 aff Exp $ use strict; use warnings; use Test::More; BEGIN { plan( skip_all => 'AUTHOR_TEST must be set for perlcritic test; skipping' ) if ( !$ENV { 'AUTHOR_TEST' } ); eval "use Test::Perl::Critic ( -severity => 4 )"; plan(skip_all => 'Test::Perl::Critic required to criticise code') if ($@); } all_critic_ok(); __END__ Parse-Dia-SQL-0.30/t/906-cover.t0000644000175000017500000000066413035770500014000 0ustar affaff # $Id: 906-cover.t,v 1.1 2009/02/23 07:36:17 aff Exp $ use strict; use warnings; use Test::More; use File::Spec::Functions; use lib catdir qw ( blib lib ); BEGIN { plan( skip_all => 'AUTHOR_TEST must be set for coverage test; skipping' ) if ( !$ENV { 'AUTHOR_TEST' } ); eval "use Test::Strict"; plan( skip_all => 'Test::Strict not installed; skipping' ) if $@; } all_cover_ok( 80 ); # at least 80% coverage __END__ Parse-Dia-SQL-0.30/t/902-pod.t0000644000175000017500000000062213035770500013432 0ustar affaff# $Id: 902-pod.t,v 1.1 2009/02/23 07:36:17 aff Exp $ use strict; use warnings; use Test::More; BEGIN { plan( skip_all => 'AUTHOR_TEST must be set for pod test; skipping' ) if ( !$ENV { 'AUTHOR_TEST' } ); } # Ensure a recent version of Test::Pod my $min_tp = 1.22; eval "use Test::Pod $min_tp"; plan skip_all => "Test::Pod $min_tp required for testing POD" if $@; all_pod_files_ok(); __END__ Parse-Dia-SQL-0.30/t/953-rt53783-postgres.t0000644000175000017500000000526313035770500015567 0ustar affaff# $Id: 953-rt53783-postgres.t,v 1.2 2010/02/05 19:30:13 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use Test::Exception; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 8; use lib q{lib}; use_ok ('Parse::Dia::SQL'); use_ok ('Parse::Dia::SQL::Output'); use_ok ('Parse::Dia::SQL::Output::Postgres'); my $diasql = Parse::Dia::SQL->new(file => catfile(qw(t data typemap.dia)), db => 'postgres'); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); can_ok($diasql, q{get_sql}); my $sql = $diasql->get_sql(); isa_ok( $diasql->get_output_instance(), q{Parse::Dia::SQL::Output::Postgres}, q{Expect Parse::Dia::SQL::Output::Postgres to be used as back-end} ); # diag $sql; like($sql, qr/.* create \s* table \s* Item \s* \( \s* \s* id \s* uuid \s* not \s* null, \s* -- \s* Primary \s* key \s* timeModified \s* timestamp \s* \( \s* 3 \s* \) \s* , \s* timeCreated \s* timestamp \s* \( \s* 3 \s* \) \s* , \s* personModified \s* varchar \s* \( \s* 128 \s* \) \s* , .*/six); like($sql, qr/.* create \s* table \s* Item \s* \( \s* \s* id \s* uuid \s* not \s* null, \s* -- \s* Primary \s* key \s* timeModified \s* timestamp \s* \( \s* 3 \s* \) \s* , \s* timeCreated \s* timestamp \s* \( \s* 3 \s* \) \s* , \s* personModified \s* varchar \s* \( \s* 128 \s* \) \s* , \s* personCreated \s* varchar \s* \( \s* 128 \s* \) \s* , \s* stateID \s* uuid \s* , \s* -- \s* - \s* In \s* active \s* storage \s* - \s* Disposed\/destroyed \s* - \s* Handovered \s* back \s* to \s* owner \s* organization \s* projectID \s* uuid \s* , \s* descriptionID \s* uuid \s* , \s* constraint \s* pk_Item \s* primary \s* key \s* \( \s* id \s* \) \s* \s* \) \s* ; .*/six); __END__ =pod =head1 SAMPLE DATASTRUCTURE FOR TYPEMAP { 'postgresql' => { 'string' => 'varchar', 'UUID' => 'uuid', 'TIMESTAMP' => 'timestamp(3)' }, 'sqlite3' => { 'string' => 'text', 'UUID' => 'text(36)', 'TIMESTAMP' => 'text(14)' } }; =head1 SAMPLE DIA FILE Add a SmallPackage with stereotype I. Then one each line add entries on the form C, e.g. UUID: uuid; string: varchar; TIMESTAMP: timestamp; =head2 Replacement options Handle mappings that allow the SQL side to replace only the type name, leaving the size unchanged, or to add a size if it's not specified by the user. So, with integer: number(10); string: varchar2; a integer, # allowed -> number(10) b integer(10) # allowed -> number(10) c integer(5) # not allowed d string(80) # allowed -> varchar2(80) e string # allowed -> varchar2 See also I in the C directory. =cut Parse-Dia-SQL-0.30/t/645-output-ingres-get-drop-index-sql.t0000644000175000017500000000422613035770477021143 0ustar affaff# $Id: 645-output-ingres-get-drop-index-sql.t,v 1.1 2009/02/23 07:36:17 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use Test::Exception; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 23; use lib q{lib}; use_ok ('Parse::Dia::SQL'); use_ok ('Parse::Dia::SQL::Output'); use_ok ('Parse::Dia::SQL::Output::Ingres'); my $diasql = Parse::Dia::SQL->new( file => catfile(qw(t data TestERD.dia)), db => 'ingres' ); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); is($diasql->convert(), 1, q{Expect convert() to return 1}); my $output = undef; isa_ok($diasql, 'Parse::Dia::SQL'); # suppress warning Using object_name_max_length 30 ok(Parse::Dia::SQL::Logger::log_off()); lives_ok(sub { $output = $diasql->get_output_instance(); }, q{get_output_instance (ingres) should not die}); ok(Parse::Dia::SQL::Logger::log_on()); isa_ok($output, 'Parse::Dia::SQL::Output'); isa_ok($output, 'Parse::Dia::SQL::Output::Ingres'); can_ok($output, 'get_constraints_drop'); my $drop_constraints = $output->get_constraints_drop(); #diag($drop_constraints); # indices like($drop_constraints, qr/.* drop \s+ index \s+ idx_iimd5 \s+ for \s+ ingres \s+ \\g .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ idx_iiid \s+ for \s+ ingres \s* \\g .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ idx_siiid \s+ for \s+ ingres \s* \\g .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ idx_siips \s+ for \s+ ingres \s* \\g .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ idx_iclidnm \s+ for \s+ ingres \s* \\g .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ idx_uinm \s+ for \s+ ingres \s* \\g .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ idx_uiid \s+ for \s+ ingres \s* \\g .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ idx_uauiid \s+ for \s+ ingres \s* \\g .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ idx_uiruid \s+ for \s+ ingres \s* \\g .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ idx_acid \s+ for \s+ ingres \s* \\g .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ idx_usmd5 \s+ for \s+ ingres \s* \\g .*/six); __END__ Parse-Dia-SQL-0.30/t/703-utils-get-base-name.t0000644000175000017500000000154213035770500016414 0ustar affaff# $Id: 703-utils-get-base-name.t,v 1.1 2009/11/17 11:15:46 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 9; use lib q{lib}; use_ok ('Parse::Dia::SQL::Utils'); # Need to specify database for make_name to pass my $utils = Parse::Dia::SQL::Utils->new( db => 'postgres' ); isa_ok($utils, 'Parse::Dia::SQL::Utils'); # make_name is($utils->get_base_type('int2', 'postgres'), 'smallint'); is($utils->get_base_type('smallserial', 'postgres'), 'smallint'); is($utils->get_base_type('int4', 'postgres'), 'integer'); is($utils->get_base_type('serial', 'postgres'), 'integer'); is($utils->get_base_type('int8', 'postgres'), 'bigint'); is($utils->get_base_type('bigserial', 'postgres'), 'bigint'); is($utils->get_base_type('int2', 'mysql-myisam'), 'int2'); __END__ Parse-Dia-SQL-0.30/t/205-parse-classes-pk.t0000644000175000017500000000500113035770477016032 0ustar affaff# $Id: 205-parse-classes-pk.t,v 1.3 2009/03/30 10:57:44 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 47; use_ok ('Parse::Dia::SQL'); my $diasql = Parse::Dia::SQL->new( file => catfile(qw(t data TestERD.dia)), db => 'db2' ); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); # TODO: Add test on return value - call wrapper $diasql->convert(); my $classes = $diasql->get_classes_ref(); # Expect an array ref with 14 elements isa_ok($classes, 'ARRAY'); cmp_ok(scalar(@$classes), q{==}, 14, q{Expect 14 classes}); # Hash with class/view names as keys and primary key as (hashref) elements my %pk = ( imageInfo => [ [ 'id', 'numeric (18)', '', '2', '' ] ], subImageInfo => [ [ 'imageInfo_id', 'numeric (18)', '', '2', '' ], [ 'pixSize', 'integer', '', '2', '' ] ], imageCategoryList => [ [ 'imageInfo_id', 'numeric (18)', '', '2', '' ], [ 'name', 'varchar (32)', '', '2', '' ] ], categoryNames => [ [ 'name', 'varchar (32)', '', '2', '' ] ], imageAttribute => [ [ 'imageInfo_id', 'numeric (18)', '', '2', '' ], [ 'attributeCategory_id', 'numeric (18)', '', '2', '' ] ], userInfo => [ [ 'id', 'numeric (18)', '', '2', '' ] ], userAttribute => [ [ 'userInfo_id', 'numeric (18)', '', '2', '' ], [ 'attributeCategory_id', 'numeric (18)', '', '2', '' ] ], userImageRating => [ [ 'userInfo_id', 'numeric (18)', '', '2', '' ], [ 'imageInfo_id', 'numeric (15)', '', '2', '' ] ], attributeCategory => [ [ 'id', 'numeric (18)', '', '2', '' ] ], userSession => [ [ 'userInfo_id', 'numeric (18)', '', '2', '' ], [ 'md5sum', 'char (32)', '', '2', '' ] ], extremes => [ [ 'name', 'varchar (32)', '', '2', '' ] ], ratings_view => [], whorated_view => [], users_view => [], ); # Check that each class has of the expected pk attributes foreach my $class (@$classes) { isa_ok($class, 'HASH'); ok(exists($pk{$class->{name}})) or diag(q{Unexpected class name: }. $class->{name}); #diag($class->{name} . ' pk :' . Dumper($class->{pk})); # check contents is_deeply( $class->{pk}, $pk{ $class->{name} }, q{pk for } . $class->{name} ); # remove class from hash delete $pk{$class->{name}}; } # Expect no classes left now cmp_ok(scalar(keys %pk), q{==}, 0, q{Expect 0 classes left}); __END__ Parse-Dia-SQL-0.30/t/642-output-get-drop-associations-sql.t0000644000175000017500000001002713035770477021237 0ustar affaff# $Id: 642-output-get-drop-associations-sql.t,v 1.2 2009/03/16 07:27:17 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use Test::Exception; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 37; use lib q{lib}; use_ok ('Parse::Dia::SQL'); use_ok ('Parse::Dia::SQL::Output'); my $diasql = Parse::Dia::SQL->new( file => catfile(qw(t data TestERD.dia)), db => 'db2' ); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); is($diasql->convert(), 1, q{Expect convert() to return 1}); # 2. output my $output = undef; isa_ok($diasql, 'Parse::Dia::SQL'); lives_ok(sub { $output = $diasql->get_output_instance(); }, q{get_output_instance (db2) should not die}); isa_ok($output, 'Parse::Dia::SQL::Output') or diag(Dumper($output)); isa_ok($output, 'Parse::Dia::SQL::Output::DB2') or diag(Dumper($output)); can_ok($output, 'get_constraints_drop'); my $drop_constraints = $output->get_constraints_drop(); #diag($drop_constraints); # indices like($drop_constraints, qr/.* drop \s+ index \s+ idx_iimd5(;)? .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ idx_iiid(;)? .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ idx_siiid(;)? .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ idx_siips(;)? .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ idx_iclidnm(;)? .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ idx_uinm(;)? .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ idx_uiid(;)? .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ idx_uauiid(;)? .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ idx_uiruid(;)? .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ idx_acid(;)? .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ idx_usmd5(;)? .*/six); # foreign keys like($drop_constraints, qr/.* alter \s+ table \s+ subImageInfo \s+ drop \s+ constraint \s+ fk_iisii \s* (;)? .*/six); like($drop_constraints, qr/.* alter \s+ table \s+ imageCategoryList \s+ drop \s+ constraint \s+ fk_iiicl \s* (;)? .*/six); like($drop_constraints, qr/.* alter \s+ table \s+ imageAttribute \s+ drop \s+ constraint \s+ fk_iiia \s* (;)? .*/six); like($drop_constraints, qr/.* alter \s+ table \s+ userImageRating \s+ drop \s+ constraint \s+ fk_uiuir \s* (;)? .*/six); like($drop_constraints, qr/.* alter \s+ table \s+ userAttribute \s+ drop \s+ constraint \s+ fk_uiua \s* (;)? .*/six); like($drop_constraints, qr/.* alter \s+ table \s+ userSession \s+ drop \s+ constraint \s+ fk_uius \s* (;)? .*/six); like($drop_constraints, qr/.* alter \s+ table \s+ imageAttribute \s+ drop \s+ constraint \s+ fk_iaac \s* (;)? .*/six); like($drop_constraints, qr/.* alter \s+ table \s+ userAttribute \s+ drop \s+ constraint \s+ fk_acua \s* (;)? .*/six); ################################################################## my $OBJECT_NAME_MAX_LENGTH_DB2 = 18; my $diasql2 = Parse::Dia::SQL->new( file => catfile(qw(t data long_fk_name.dia)), db => 'db2' ); isa_ok($diasql2, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); is($diasql2->convert(), 1, q{Expect convert() to return 1}); # 2. output my $output2 = undef; isa_ok($diasql2, 'Parse::Dia::SQL'); lives_ok(sub { $output2 = $diasql2->get_output_instance(); }, q{get_output_instance (db2) should not die}); isa_ok($output2, 'Parse::Dia::SQL::Output') or diag(Dumper($output2)); isa_ok($output2, 'Parse::Dia::SQL::Output::DB2') or diag(Dumper($output2)); can_ok($output2, 'get_constraints_drop'); my $drop_constraints2 = $output2->get_constraints_drop(); # diag($drop_constraints2); $drop_constraints2 =~ m/alter \s+ table \s+ \w+ \s+ drop \s+ constraint \s+ (\w+) \s+ .* $/six; my $constraint_name2 = $1; # diag($constraint_name2); ok(defined($constraint_name2), q{Expect a defined name}) or diag($constraint_name2); cmp_ok(length($constraint_name2), q{<=}, $OBJECT_NAME_MAX_LENGTH_DB2, qq{$constraint_name2 Expect length below or equal to $OBJECT_NAME_MAX_LENGTH_DB2}) or diag($constraint_name2); __END__ =pod =head1 SEE ALSO 689-output-db2-create-constraint-name.t =cut Parse-Dia-SQL-0.30/t/001-new.t0000644000175000017500000000052413035770477013445 0ustar affaff# $Id: 001-new.t,v 1.2 2009/02/26 13:46:10 aff Exp $ use warnings; use strict; use Test::More; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 2; use_ok ('Parse::Dia::SQL'); my $diasql = Parse::Dia::SQL->new( db => q{db2} ); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); __END__ Parse-Dia-SQL-0.30/t/660-output-get-create-permissions-sql.t0000644000175000017500000000467113035770477021422 0ustar affaff# $Id: 660-output-get-create-permissions-sql.t,v 1.1 2009/02/23 07:36:17 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use Test::Exception; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 23; use lib q{lib}; use_ok ('Parse::Dia::SQL'); use_ok ('Parse::Dia::SQL::Output'); my $diasql = Parse::Dia::SQL->new( file => catfile(qw(t data TestERD.dia)), db => 'db2' ); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); is($diasql->convert(), 1, q{Expect convert() to return 1}); # 2. output my $output = undef; isa_ok($diasql, 'Parse::Dia::SQL'); lives_ok(sub { $output = $diasql->get_output_instance(); }, q{get_output_instance (db2) should not die}); isa_ok($output, 'Parse::Dia::SQL::Output') or diag(Dumper($output)); isa_ok($output, 'Parse::Dia::SQL::Output::DB2') or diag(Dumper($output)); can_ok($output, 'get_permissions_create'); my $permissions_create = $output->get_permissions_create(); like($permissions_create, qr/.* grant \s+ all \s+ on \s+ imageInfo \s+ to \s+ fmorg \s* (;)? .*/six); like($permissions_create, qr/.* grant \s+ select \s+ on \s+ imageInfo \s+ to \s+ public \s* (;)? .*/six); like($permissions_create, qr/.* grant \s+ all \s+ on \s+ subImageInfo \s+ to \s+ fmorg \s* (;)? .*/six); like($permissions_create, qr/.* grant \s+ all \s+ on \s+ imageCategoryList \s+ to \s+ fmorg \s* (;)? .*/six); like($permissions_create, qr/.* grant \s+ select \s+ on \s+ categoryNames \s+ to \s+ public \s* (;)? .*/six); like($permissions_create, qr/.* grant \s+ all \s+ on \s+ categoryNames \s+ to \s+ fmorg \s* (;)? .*/six); like($permissions_create, qr/.* grant \s+ all \s+ on \s+ imageAttribute \s+ to \s+ fmorg \s* (;)? .*/six); like($permissions_create, qr/.* grant \s+ all \s+ on \s+ userInfo \s+ to \s+ fmorg \s* (;)? .*/six); like($permissions_create, qr/.* grant \s+ all \s+ on \s+ userAttribute \s+ to \s+ fmorg \s* (;)? .*/six); like($permissions_create, qr/.* grant \s+ all \s+ on \s+ userImageRating \s+ to \s+ fmorg \s* (;)? .*/six); like($permissions_create, qr/.* grant \s+ all \s+ on \s+ attributeCategory \s+ to \s+ fmorg \s* (;)? .*/six); like($permissions_create, qr/.* grant \s+ all \s+ on \s+ userSession \s+ to \s+ fmorg \s* (;)? .*/six); like($permissions_create, qr/.* grant \s+ select \s+ on \s+ extremes \s+ to \s+ public \s* (;)? .*/six); like($permissions_create, qr/.* grant \s+ all \s+ on \s+ extremes \s+ to \s+ fmorg \s* (;)? .*/six); __END__ Parse-Dia-SQL-0.30/t/206-parse-classes-uindxc.t0000644000175000017500000000336013035770477016721 0ustar affaff# $Id: 206-parse-classes-uindxc.t,v 1.2 2009/02/26 13:49:07 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 47; use_ok ('Parse::Dia::SQL'); my $diasql = Parse::Dia::SQL->new( file => catfile(qw(t data TestERD.dia)), db => 'db2' ); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); # TODO: Add test on return value - call wrapper $diasql->convert(); my $classes = $diasql->get_classes_ref(); # Expect an array ref with 14 elements isa_ok($classes, 'ARRAY'); cmp_ok(scalar(@$classes), q{==}, 14, q{Expect 14 classes}); # Hash with class/view names as keys and unique index (if any) as # (hashref) elements my %uindxc = ( attributeCategory => {}, categoryNames => {}, extremes => {}, imageAttribute => {}, imageCategoryList => {}, imageInfo => { '' => [ [ 'md5sum', 'char (32)' ] ] }, ratings_view => {}, subImageInfo => {}, userAttribute => {}, userImageRating => {}, userInfo => { '' => [ [ 'name', 'varchar (32)' ], [ 'md5sum', 'char (32)' ] ] }, userSession => {}, users_view => {}, whorated_view => {}, ); # Check that each class has of the expected uindxc attributes foreach my $class (@$classes) { isa_ok($class, 'HASH'); ok(exists($uindxc{$class->{name}})) or diag($class->{name} . ' uindxc :' . Dumper($class->{uindxc})); # check contents is_deeply( $class->{uindxc}, $uindxc{ $class->{name} }, q{uindxc for } . $class->{name} ); # remove class from hash delete $uindxc{$class->{name}}; } # Expect no classes left now cmp_ok(scalar(keys %uindxc), q{==}, 0, q{Expect 0 classes left}); __END__ Parse-Dia-SQL-0.30/t/900-boilerplate.t0000644000175000017500000000252513035770500015154 0ustar affaff # $Id: 900-boilerplate.t,v 1.3 2009/04/14 12:09:17 aff Exp $ use strict; use warnings; use Test::More; BEGIN { plan( skip_all => 'AUTHOR_TEST must be set for boilerplate test; skipping' ) if ( !$ENV{'AUTHOR_TEST'} ); } plan tests => 3; sub not_in_file_ok { my ( $filename, %regex ) = @_; open( my $fh, '<', $filename ) or die "couldn't open $filename for reading: $!"; my %violated; while ( my $line = <$fh> ) { while ( my ( $desc, $regex ) = each %regex ) { if ( $line =~ $regex ) { push @{ $violated{$desc} ||= [] }, $.; } } } if ( scalar( keys %violated ) ) { fail( "$filename contains boilerplate text" ); diag "$_ appears on lines @{$violated{$_}}" for keys %violated; } else { pass( "$filename contains no boilerplate text" ); } } sub module_boilerplate_ok { my ( $module ) = @_; not_in_file_ok( $module => 'the great new $MODULENAME' => qr/ - The great new /, 'boilerplate description' => qr/Quick summary of what the module/, 'stub function definition' => qr/function[12]/, ); } not_in_file_ok( README => "The README is used..." => qr/The README is used/, "'version information here'" => qr/to provide version information/, ); not_in_file_ok( Changes => "placeholder date/time" => qr(Date/time) ); module_boilerplate_ok( 'lib/Parse/Dia/SQL.pm' ); __END__ Parse-Dia-SQL-0.30/t/220-parse-classes-database.t0000644000175000017500000000260213035770477017165 0ustar affaff# $Id: 220-parse-classes-database.t,v 1.1 2010/04/10 12:59:11 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 11; use_ok('Parse::Dia::SQL'); my $diasql = Parse::Dia::SQL->new(file => catfile(qw(t data rt56357.dia)), db => 'db2'); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); # parse and convert is($diasql->convert(), 1, q{Expect convert() to return 1}); my $docs = $diasql->_get_docs(); foreach my $doc (@{$docs}) { isa_ok($doc, q{XML::DOM::Document}); } # check that nodelists returns array of XML::DOM::NodeList my $nodelists = $diasql->_get_nodelists(); foreach my $nodelist (@{$nodelists}) { isa_ok($nodelist, q{XML::DOM::NodeList}); } my $classes = $diasql->get_classes_ref(); #diag(Dumper($classes)); # Expect an array ref with 1 elements isa_ok($classes, 'ARRAY'); cmp_ok(scalar(@$classes), q{==}, 1, q{Expect 1 classes}); # List of classes in the dia file my %classname = map { $_ => 1 } qw ( bar ); foreach my $class (@$classes) { isa_ok($class, 'HASH'); if (exists($classname{ $class->{name} })) { delete $classname{ $class->{name} }; ok(q{Found class } . $class->{name}); } else { fail(q{Unknown class: } . $class->{name}); } } # Expect no classes left now cmp_ok(scalar(keys %classname), q{==}, 0, q{Expect 0 classes}); __END__ Parse-Dia-SQL-0.30/t/670-output-get-pre-sql.t0000644000175000017500000000500713035770477016367 0ustar affaff# $Id: 670-output-get-pre-sql.t,v 1.5 2009/02/27 08:59:42 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use Test::Exception; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 19; use lib q{lib}; use_ok ('Parse::Dia::SQL'); use_ok ('Parse::Dia::SQL::Output'); use_ok ('Parse::Dia::SQL::Output::DB2'); my $diasql = Parse::Dia::SQL->new( files => [catfile(qw(t data TestERD.dia))], db => 'db2' ); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); # Parse and convert cmp_ok($diasql->convert(), q{==}, 1,q{Expect convert to return 1}); my $output = undef; isa_ok($diasql, 'Parse::Dia::SQL'); lives_ok(sub { $output = $diasql->get_output_instance(); }, q{get_output_instance (db2) should not die}); isa_ok($output, 'Parse::Dia::SQL::Output') or diag(Dumper($output)); isa_ok($output, 'Parse::Dia::SQL::Output::DB2') or diag(Dumper($output)); can_ok($output, 'get_smallpackage_pre_sql'); my $presql = $output->get_smallpackage_pre_sql(); is($presql,q[-- statements to do BEFORE creating -- the tables (schema) drop sequence imageInfo_id; create sequence imageInfo_id;]); # ------------------------------------------------------------------ # Check that Output doesn't put comma between multiple smallpackage statements my $diasql2 = Parse::Dia::SQL->new( files => [catfile(qw(t data db2.pre.dupe.dia))], db => 'db2' ); isa_ok($diasql2, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); # Parse and convert cmp_ok($diasql2->convert(), q{==}, 1,q{Expect convert to return 1}); my $output2 = undef; isa_ok($diasql2, 'Parse::Dia::SQL'); lives_ok(sub { $output2 = $diasql2->get_output_instance(); }, q{get_output_instance (db2) should not die}); isa_ok($output2, 'Parse::Dia::SQL::Output') or diag(Dumper($output2)); isa_ok($output2, 'Parse::Dia::SQL::Output::DB2') or diag(Dumper($output2)); can_ok($output2, 'get_smallpackage_pre_sql'); my $presql2 = $output2->get_smallpackage_pre_sql(); # make sure each statement starts on a separate line like($presql2,qr/ \s* ^ drop \s+ sequence \s+ foo_id_seq; \s* ^ create \s+ sequence \s+ foo_id_seq \s+ as \s+ bigint \s+ start \s+ with \s+ 1 \s+ increment \s+ by \s+ 1 \s+ no \s+ maxvalue \s+ no \s+ cycle \s+ cache \s+ 20; \s* ^drop \s+ sequence \s+ bar_id_seq; \s* ^create \s+ sequence \s+ bar_id_seq \s+ as \s+ bigint \s+ start \s+ with \s+ 1 \s+ increment \s+ by \s+ 1 \s+ no \s+ maxvalue \s+ no \s+ cycle \s+ cache \s+ 20; \s*/mix, q{Check that there is no comma between statements}); #diag($presql2); __END__ Parse-Dia-SQL-0.30/t/502-get-associations_version_2.t0000644000175000017500000000214713035770477020127 0ustar affaff# $Id: 502-get-associations_version_2.t,v 1.1 2009/06/21 13:24:37 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 59; use_ok ('Parse::Dia::SQL'); use_ok ('Parse::Dia::SQL::Const'); # Get list of supported databases my $const = Parse::Dia::SQL::Const->new(); isa_ok($const, q{Parse::Dia::SQL::Const}); my @rdbms = $const->get_rdbms(); undef $const; foreach my $db (@rdbms) { my $diasql = Parse::Dia::SQL->new( file => catfile(qw(t data association_dia_0_97.dia)), db => $db ); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); is($diasql->convert(), 1, q{Expect convert to return 1}); my $association_arrayref = $diasql->get_associations_ref(); #diag(Dumper($association_arrayref)); my $expected = [ [ 'dog', 'fk_dog_owner', 'owner_id', 'owner', 'id', '' ] ]; cmp_ok(scalar(@$association_arrayref), q{==}, scalar(@$expected), qq{Check number of foreign keys (db=$db)}); is_deeply($association_arrayref, $expected, qq{get_associations_ref for db=$db}); undef $diasql; } __END__ Parse-Dia-SQL-0.30/t/300-parse-classes-many-to-many.t0000644000175000017500000000643013035770477017751 0ustar affaff# $Id: 300-parse-classes-many-to-many.t,v 1.3 2011/02/15 20:15:54 aff Exp $ # NOTE: This files has all the tests crammed together as opposed to # the others that are using TestERD.dia - consider doing it more # consistently.. use warnings; use strict; use Data::Dumper; use Test::More; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 34; use_ok ('Parse::Dia::SQL'); my $diasql = Parse::Dia::SQL->new( file => catfile(qw(t data many_to_many.dia)), db => 'db2' ); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); # parse and convert document is($diasql->convert(), 1, q{Expect convert() to return 1}); my $docs = $diasql->_get_docs(); foreach my $doc (@{$docs}){ isa_ok($doc, q{XML::DOM::Document}); } # check that nodelists returns array of XML::DOM::NodeList my $nodelists = $diasql->_get_nodelists(); foreach my $nodelist (@{$nodelists}){ isa_ok($nodelist, q{XML::DOM::NodeList}); } my $classes = $diasql->get_classes_ref(); # no parsing # Expect an array ref with 3 elements isa_ok($classes, 'ARRAY'); cmp_ok(scalar(@$classes), q{==}, 3, q{Expect 3 classes}); # List of classes in the dia file my %classname = map { $_ => 1 } qw ( student course student_course ); foreach my $class(@$classes) { isa_ok($class, 'HASH'); if (exists($classname{$class->{name}})) { delete $classname{$class->{name}}; ok(1); #diag(q{Found class }. $class->{name}) } else { fail(); diag(q{Unknown class: }. $class->{name}); } } # Expect no classes left now cmp_ok(scalar(keys %classname), q{==}, 0, q{Expect 0 classes}); $classes = $diasql->get_classes_ref(); # no parsing # List of objects and types %classname = map { $_ => 'table' } qw ( student course student_course ); # Check that each class is of the expected type (table or view) foreach my $class (@$classes) { isa_ok($class, 'HASH'); ok(exists($classname{$class->{name}})); is($class->{type}, $classname{$class->{name}}, $class->{name} . q{ is of type } . $class->{type} . q{ expected } . $classname{ $class->{name}}); delete $classname{$class->{name}}; } # Expect no classes left now cmp_ok(scalar(keys %classname), q{==}, 0, q{Expect 0 classes}); # Hash with class/view names as keys and attribute list as (hashref) elements my %attList = ( student => [ [ 'ssn', 'int', '', '2', '' ], [ 'name', 'varchar(256)', 'not null', '0', '' ] ], course => [ [ 'course_id', 'int', '', '2', '' ], [ 'desc', 'varchar(64)', 'not null', '0', '' ], [ 'day_of_week', 'int', 'not null', '0', '' ], [ 'starttime', 'timestamp', 'not null', '0', '' ], [ 'endtime', 'timestamp', '', '0', '' ] ], student_course => [ [ 'ssn', 'int', '', 2, '' ], [ 'course_id', 'int', '', 2, '' ] ], ); $classes = $diasql->get_classes_ref(); # no parsing # Check that each class has of the expected attList attributes foreach my $class (@$classes) { isa_ok($class, 'HASH'); ok(exists($attList{$class->{name}})); #diag($class->{name} . ": " . Dumper($class->{attList})); # check contents is_deeply( $class->{attList}, $attList{ $class->{name} }, q{attList for } . $class->{name} ); # remove key-value pair from hash delete $attList{$class->{name}}; } __END__ Parse-Dia-SQL-0.30/t/660-output-get-create-permissions-sql-innodb-backticks.t0000644000175000017500000000500313035770477024613 0ustar affaff# $Id: 660-output-get-create-permissions-sql.t,v 1.1 2009/02/23 07:36:17 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use Test::Exception; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 23; use lib q{lib}; use_ok ('Parse::Dia::SQL'); use_ok ('Parse::Dia::SQL::Output'); my $diasql = Parse::Dia::SQL->new( file => catfile(qw(t data TestERD.dia)), db => 'mysql-innodb', backticks => 1 ); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); is($diasql->convert(), 1, q{Expect convert() to return 1}); # 2. output my $output = undef; isa_ok($diasql, 'Parse::Dia::SQL'); lives_ok(sub { $output = $diasql->get_output_instance(); }, q{get_output_instance (mysql-innodb) should not die}); isa_ok($output, 'Parse::Dia::SQL::Output') or diag(Dumper($output)); isa_ok($output, 'Parse::Dia::SQL::Output::MySQL::InnoDB') or diag(Dumper($output)); can_ok($output, 'get_permissions_create'); my $permissions_create = $output->get_permissions_create(); like($permissions_create, qr/.* grant \s+ all \s+ on \s+ `imageInfo` \s+ to \s+ fmorg \s* (;)? .*/six); like($permissions_create, qr/.* grant \s+ select \s+ on \s+ `imageInfo` \s+ to \s+ public \s* (;)? .*/six); like($permissions_create, qr/.* grant \s+ all \s+ on \s+ `subImageInfo` \s+ to \s+ fmorg \s* (;)? .*/six); like($permissions_create, qr/.* grant \s+ all \s+ on \s+ `imageCategoryList` \s+ to \s+ fmorg \s* (;)? .*/six); like($permissions_create, qr/.* grant \s+ select \s+ on \s+ `categoryNames` \s+ to \s+ public \s* (;)? .*/six); like($permissions_create, qr/.* grant \s+ all \s+ on \s+ `categoryNames` \s+ to \s+ fmorg \s* (;)? .*/six); like($permissions_create, qr/.* grant \s+ all \s+ on \s+ `imageAttribute` \s+ to \s+ fmorg \s* (;)? .*/six); like($permissions_create, qr/.* grant \s+ all \s+ on \s+ `userInfo` \s+ to \s+ fmorg \s* (;)? .*/six); like($permissions_create, qr/.* grant \s+ all \s+ on \s+ `userAttribute` \s+ to \s+ fmorg \s* (;)? .*/six); like($permissions_create, qr/.* grant \s+ all \s+ on \s+ `userImageRating` \s+ to \s+ fmorg \s* (;)? .*/six); like($permissions_create, qr/.* grant \s+ all \s+ on \s+ `attributeCategory` \s+ to \s+ fmorg \s* (;)? .*/six); like($permissions_create, qr/.* grant \s+ all \s+ on \s+ `userSession` \s+ to \s+ fmorg \s* (;)? .*/six); like($permissions_create, qr/.* grant \s+ select \s+ on \s+ `extremes` \s+ to \s+ public \s* (;)? .*/six); like($permissions_create, qr/.* grant \s+ all \s+ on \s+ `extremes` \s+ to \s+ fmorg \s* (;)? .*/six); __END__ Parse-Dia-SQL-0.30/t/702-utils-make-name.t0000644000175000017500000000167513035770477015665 0ustar affaff# $Id: 702-utils-make-name.t,v 1.1 2009/02/23 07:36:17 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 9; use lib q{lib}; use_ok ('Parse::Dia::SQL::Utils'); # Need to specify database for make_name to pass my $utils = Parse::Dia::SQL::Utils->new( db => 'db2' ); isa_ok($utils, 'Parse::Dia::SQL::Utils'); # make_name is($utils->make_name(0, qw(One two three)), q{OneTwoThree}); is($utils->make_name(1, qw(one two three)), q{oneTwoThree}); is($utils->make_name(1, qw(student_course _fk_ course course_id)), q{lTeT8iBKfXObJYiSrq}); is($utils->make_name(0, qw(student_course _fk_ course course_id)), q{lTeT8iBKfXObJYiSrq}); is($utils->make_name(0, qw(course course_id)), q{courseCourse_id}); is($utils->make_name(0, qw(course course_id foo)), q{courseCourse_idFoo}); is($utils->make_name(0, qw(course course_id foo bar tze)), q{crsCrs_dFooBarTze}); __END__ Parse-Dia-SQL-0.30/t/688-output-mysql-myisam-get-sql.t0000644000175000017500000000170113035770477020251 0ustar affaff# $Id: 688-output-mysql-myisam-get-sql.t,v 1.4 2009/03/16 20:38:08 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use Test::Exception; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 8; use lib q{lib}; use_ok ('Parse::Dia::SQL'); use_ok ('Parse::Dia::SQL::Output'); use_ok ('Parse::Dia::SQL::Output::MySQL'); use_ok ('Parse::Dia::SQL::Output::MySQL::MyISAM'); my $diasql = Parse::Dia::SQL->new(file => catfile(qw(t data TestERD.dia)), db => 'mysql-myisam'); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); can_ok($diasql, q{get_sql}); my $sql = $diasql->get_sql(); isa_ok( $diasql->get_output_instance(), q{Parse::Dia::SQL::Output::MySQL::MyISAM}, q{Expect Parse::Dia::SQL::Output::MySQL::MyISAM to be used as back-end} ); #diag($sql); like( $sql, qr/ENGINE=MyISAM DEFAULT CHARSET=latin1/, q{Expect sql to contain ENGINE=MyISAM DEFAULT CHARSET=latin1} ); __END__ Parse-Dia-SQL-0.30/t/904-kwalitee.t0000644000175000017500000000056313035770500014463 0ustar affaff # $Id: 904-kwalitee.t,v 1.2 2009/03/16 07:41:54 aff Exp $ use strict; use warnings; use Test::More; BEGIN { eval { require Test::Kwalitee; }; plan( skip_all => 'AUTHOR_TEST must be set for kwalitee test; skipping' ) if ( !$ENV { 'AUTHOR_TEST' } ); plan( skip_all => 'Test::Kwalitee not installed; skipping' ) if $@; } Test::Kwalitee->import(); __END__ Parse-Dia-SQL-0.30/t/961-rt57182-charset.t0000644000175000017500000000227713035770500015350 0ustar affaff # $Id: 961-rt57182-charset.t,v 1.2 2011/02/15 20:15:54 aff Exp $ use warnings; use strict; use locale; use Data::Dumper; use Test::More; use Test::Exception; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 6; use lib q{lib}; use_ok ('Parse::Dia::SQL'); my $diasql = Parse::Dia::SQL->new(file => catfile(qw(t data non-latin1-chars.dia)), db => 'postgres'); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); can_ok($diasql, q{get_sql}); my $sql = undef; lives_ok( sub { $sql = $diasql->get_sql() }, q{get_sql should live on supported model type 'Database - Table'} ); my $components = $diasql->get_components_ref(); # diag(Dumper($components)); my $expected = [ { 'text' => "'fjallg\x{f6}nguma\x{f0}ur'", 'name' => 'words' } ]; is_deeply($components, $expected, q{Expect arrayref with text/name hash pairs}); my $outputter = $diasql->get_output_instance(); my $inserts = $outputter->get_inserts(); like($inserts, qr/.* fjallg\x{f6}nguma\x{f0}ur .*/x, q{Icelandic word for mountaineer}); #diag $inserts; #print $inserts; __END__ =pod =head1 DESCRIPTION https://rt.cpan.org/Public/Bug/Display.html?id=57182 =cut Parse-Dia-SQL-0.30/t/643-output-get-drop-permissions-sql-innodb-backticks.t0000644000175000017500000000500613035770477024320 0ustar affaff# $Id: 643-output-get-drop-permissions-sql.t,v 1.1 2009/02/23 07:36:17 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use Test::Exception; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 23; use lib q{lib}; use_ok ('Parse::Dia::SQL'); use_ok ('Parse::Dia::SQL::Output'); my $diasql = Parse::Dia::SQL->new( file => catfile(qw(t data TestERD.dia)), db => 'mysql-innodb', backticks => 1 ); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); is($diasql->convert(), 1, q{Expect convert() to return 1}); # 2. output my $output = undef; isa_ok($diasql, 'Parse::Dia::SQL'); lives_ok(sub { $output = $diasql->get_output_instance(); }, q{get_output_instance (mysql-innodb) should not die}); isa_ok($output, 'Parse::Dia::SQL::Output') or diag(Dumper($output)); isa_ok($output, 'Parse::Dia::SQL::Output::MySQL::InnoDB') or diag(Dumper($output)); can_ok($output, 'get_permissions_drop'); my $permissions_drop = $output->get_permissions_drop(); like($permissions_drop, qr/.* revoke \s+ all \s+ on \s+ `imageInfo` \s+ from \s+ fmorg \s* (;)? .*/six); like($permissions_drop, qr/.* revoke \s+ select \s+ on \s+ `imageInfo` \s+ from \s+ public \s* (;)? .*/six); like($permissions_drop, qr/.* revoke \s+ all \s+ on \s+ `subImageInfo` \s+ from \s+ fmorg \s* (;)? .*/six); like($permissions_drop, qr/.* revoke \s+ all \s+ on \s+ `imageCategoryList` \s+ from \s+ fmorg \s* (;)? .*/six); like($permissions_drop, qr/.* revoke \s+ select \s+ on \s+ `categoryNames` \s+ from \s+ public \s* (;)? .*/six); like($permissions_drop, qr/.* revoke \s+ all \s+ on \s+ `categoryNames` \s+ from \s+ fmorg \s* (;)? .*/six); like($permissions_drop, qr/.* revoke \s+ all \s+ on \s+ `imageAttribute` \s+ from \s+ fmorg \s* (;)? .*/six); like($permissions_drop, qr/.* revoke \s+ all \s+ on \s+ `userInfo` \s+ from \s+ fmorg \s* (;)? .*/six); like($permissions_drop, qr/.* revoke \s+ all \s+ on \s+ `userAttribute` \s+ from \s+ fmorg \s* (;)? .*/six); like($permissions_drop, qr/.* revoke \s+ all \s+ on \s+ `userImageRating` \s+ from \s+ fmorg \s* (;)? .*/six); like($permissions_drop, qr/.* revoke \s+ all \s+ on \s+ `attributeCategory` \s+ from \s+ fmorg \s* (;)? .*/six); like($permissions_drop, qr/.* revoke \s+ all \s+ on \s+ `userSession` \s+ from \s+ fmorg \s* (;)? .*/six); like($permissions_drop, qr/.* revoke \s+ select \s+ on \s+ `extremes` \s+ from \s+ public \s* (;)? .*/six); like($permissions_drop, qr/.* revoke \s+ all \s+ on \s+ `extremes` \s+ from \s+ fmorg \s* (;)? .*/six); __END__ Parse-Dia-SQL-0.30/t/620-output-get-schema-create-col-comment.t0000644000175000017500000000267313035770477021721 0ustar affaff# $Id: 620-output-get-schema-create-col-comment.t,v 1.2 2009/02/27 08:59:15 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use Test::Exception; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 10; use lib q{lib}; use_ok ('Parse::Dia::SQL'); use_ok ('Parse::Dia::SQL::Output'); use_ok ('Parse::Dia::SQL::Output::DB2'); # Check that table column comments are prefixed by comment character my $db = 'db2'; my $diasql = Parse::Dia::SQL->new( file => catfile(qw(t data table.col.comment.dia)), db => $db ); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); is($diasql->convert(), 1, q{Expect convert to return 1}); my $subclass = undef; lives_ok(sub { $subclass = $diasql->get_output_instance(); }, q{get_output_instance (db2) should not die}); isa_ok($subclass, 'Parse::Dia::SQL::Output') or diag(Dumper($subclass)); isa_ok($subclass, 'Parse::Dia::SQL::Output::DB2') or diag(Dumper($subclass)); can_ok($subclass, 'get_schema_create'); # 3. create sql my $create_table = $subclass->get_schema_create(); like($create_table, qr| \s* create \s+ table \s+ table_col_comment \s* \( \s* id \s+ integer \s+ not \s+ null \s* , \s* type \s+ varchar \s* \(32\) \s* , \s* -- \s+ This \s+ should \s+ be \s+ prefixed \s+ by \s+ comment \s+ character. \s* \s* constraint \s+ \w+ \s+ primary \s+ key \s+ \(id\) \s* \) \s* ; .s* |six, q{Check syntax for sql create table imageInfo}); __END__ Parse-Dia-SQL-0.30/t/640-output-get-schema-drop-sql.t0000644000175000017500000000343413035770477020002 0ustar affaff# $Id: 640-output-get-schema-drop-sql.t,v 1.1 2009/02/23 07:36:17 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use Test::Exception; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 20; use_ok ('Parse::Dia::SQL'); my $diasql = Parse::Dia::SQL->new( file => catfile(qw(t data TestERD.dia)), db => 'db2' ); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); is($diasql->convert(), 1, q{Expect convert() to return 1}); my $classes = $diasql->get_classes_ref(); ok(defined($classes) && ref($classes) eq q{ARRAY} && scalar(@$classes), q{Non-empty array ref}); # 2. output my $output = undef; isa_ok($diasql, 'Parse::Dia::SQL'); lives_ok(sub { $output = $diasql->get_output_instance(); }, q{get_output_instance (db2) should not die}); isa_ok($output, 'Parse::Dia::SQL::Output') or diag(Dumper($output)); isa_ok($output, 'Parse::Dia::SQL::Output::DB2') or diag(Dumper($output)); can_ok($output, 'get_schema_drop'); my $drop_table = $output->get_schema_drop(); #diag($drop_table); like($drop_table, qr/.*drop \s+ table \s+ imageInfo \s* ;/six); like($drop_table, qr/.*drop \s+ table \s+ subImageInfo \s* ;/six); like($drop_table, qr/.*drop \s+ table \s+ imageCategoryList \s* ;/six); like($drop_table, qr/.*drop \s+ table \s+ categoryNames \s* ;/six); like($drop_table, qr/.*drop \s+ table \s+ imageAttribute \s* ;/six); like($drop_table, qr/.*drop \s+ table \s+ userInfo \s* ;/six); like($drop_table, qr/.*drop \s+ table \s+ userAttribute \s* ;/six); like($drop_table, qr/.*drop \s+ table \s+ userImageRating \s* ;/six); like($drop_table, qr/.*drop \s+ table \s+ attributeCategory \s* ;/six); like($drop_table, qr/.*drop \s+ table \s+ userSession \s* ;/six); like($drop_table, qr/.*drop \s+ table \s+ extremes \s* ;/six); __END__ Parse-Dia-SQL-0.30/t/901-pod-coverage.t0000644000175000017500000000146513035770500015230 0ustar affaff# $Id: 901-pod-coverage.t,v 1.1 2009/02/23 07:36:17 aff Exp $ use strict; use warnings; use Test::More; use File::Spec::Functions qw(catdir); use lib catdir qw ( blib lib ); BEGIN { plan( skip_all => 'AUTHOR_TEST must be set for pod coverage test; skipping' ) if ( !$ENV { 'AUTHOR_TEST' } ); } # Ensure a recent version of Test::Pod::Coverage my $min_tpc = 1.08; eval "use Test::Pod::Coverage $min_tpc"; plan skip_all => "Test::Pod::Coverage $min_tpc required for testing POD coverage" if $@; # Test::Pod::Coverage doesn't require a minimum Pod::Coverage version, # but older versions don't recognize some common documentation styles my $min_pc = 0.18; eval "use Pod::Coverage $min_pc"; plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage" if $@; all_pod_coverage_ok(); __END__ Parse-Dia-SQL-0.30/t/960-rt56357-database-model.t0000644000175000017500000000171713035770500016561 0ustar affaff# $Id: 960-rt56357-database-model.t,v 1.2 2010/04/10 12:58:16 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use Test::Exception; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 5; use lib q{lib}; use_ok('Parse::Dia::SQL'); my $diasql = Parse::Dia::SQL->new( file => catfile(qw(t data rt56357.dia)), db => 'postgres' ); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); can_ok($diasql, q{get_sql}); my $sql = undef; lives_ok(sub { $sql = $diasql->get_sql() }, q{get_sql should live on supported model type 'Database - Table'}); diag($sql); like($sql, qr/.* create \s* table \s* bar \s* \( \s* \s* foo \s+ int \s+ not \s+ null \s*, \s* \s* seconds \s+ int \s+ not \s+ null \s*, \s* \s* constraint \s+ pk_bar \s+ primary \s+ key \s+ \( \s* foo \s* \) \s* \) .*/six); __END__ =pod =head1 DESCRIPTION The I model type was added to dia in recent versions. =cut Parse-Dia-SQL-0.30/t/689-output-mysql-innodb-get-sql-comment.t0000644000175000017500000000172513035770477021672 0ustar affaff# $Id: $ use warnings; use strict; use Data::Dumper; use Test::More; use Test::Exception; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 8; use lib q{lib}; use_ok ('Parse::Dia::SQL'); use_ok ('Parse::Dia::SQL::Output'); use_ok ('Parse::Dia::SQL::Output::MySQL'); use_ok ('Parse::Dia::SQL::Output::MySQL::InnoDB'); my $diasql = Parse::Dia::SQL->new(file => catfile(qw(t data table_output_options.dia)), db => 'mysql-innodb'); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); can_ok($diasql, q{get_sql}); my $sql = $diasql->get_sql(); isa_ok( $diasql->get_output_instance(), q{Parse::Dia::SQL::Output::MySQL::InnoDB}, q{Expect Parse::Dia::SQL::Output::MySQL::InnoDB to be used as back-end} ); #diag($sql); like( $sql, qr/ENGINE=InnoDB, DEFAULT CHARSET=latin1, PARTITION BY range \('blah','foo'\)/, q{Expect sql to contain ENGINE=InnoDB, DEFAULT CHARSET=latin1, PARTITION BY range ('blah','foo')} ); __END__ Parse-Dia-SQL-0.30/t/651-output-get-create-associations-sybase.t0000644000175000017500000001227413035770477022233 0ustar affaff# $Id: 651-output-get-create-associations-sybase.t,v 1.1 2009/02/23 07:36:17 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use Test::Exception; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan skip_all => 'Sybase support is experimental'; __END__ plan tests => 29; use_ok ('Parse::Dia::SQL'); use_ok ('Parse::Dia::SQL::Output'); use_ok ('Parse::Dia::SQL::Output::Sybase'); my $diasql = Parse::Dia::SQL->new( file => catfile(qw(t data TestERD.dia)), db => 'sybase' ); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); # TODO: Add test on return value - call wrapper $diasql->convert(); # Output my $output = undef; isa_ok($diasql, 'Parse::Dia::SQL'); lives_ok(sub { $output = $diasql->get_output_instance(); }, q{get_output_instance (sybase) should not die}); isa_ok($output, 'Parse::Dia::SQL::Output') or diag(Dumper($output)); isa_ok($output, 'Parse::Dia::SQL::Output::Sybase') or diag(Dumper($output)); can_ok($output, 'get_associations_create'); __END__ # associations = foreign keys + indices my $association_str = $output->get_associations_create(); # unique index like($association_str, qr|.* create \s+ unique \s+ index \s+ idx_iimd5 \s+ on \s+ imageInfo \s* \( \s* md5sum \s* \) \s* (;)? .* |six, q{Expect unique index on imageInfo}); like($association_str, qr|.* create \s+ unique \s+ index \s+ idx_uinm \s+ on \s+ userInfo \s* \(name,md5sum\) \s* (;)? |six, q{Expect unique index}); like($association_str, qr|.* create \s+ unique \s+ index \s+ idx_iimd5 \s+ on \s+ imageInfo \s* \(md5sum\) \s* (;)? |six, q{Expect unique index}); # index like($association_str, qr|.* create \s+ index \s+ idx_iiid \s+ on \s+ imageInfo \s* \(id\) \s* (;)? |six, q{Expect index}); like($association_str, qr|.* create \s+ index \s+ idx_siiid \s+ on \s+ subImageInfo \s* \(imageInfo_id\) \s* (;)? |six, q{Expect index}); like($association_str, qr|.* create \s+ index \s+ idx_siips \s+ on \s+ subImageInfo \s* \(pixSize\) \s* (;)? |six, q{Expect index}); like($association_str, qr|.* create \s+ index \s+ idx_iclidnm \s+ on \s+ imageCategoryList \s* \(imageInfo_id,name\) \s* (;)? |six, q{Expect index}); like($association_str, qr|.* create \s+ index \s+ idx_uiid \s+ on \s+ userInfo \s* \(id\) \s* (;)? |six, q{Expect index}); like($association_str, qr|.* create \s+ index \s+ idx_uauiid \s+ on \s+ userAttribute \s* \(userInfo_id\) \s* (;)? |six, q{Expect index}); like($association_str, qr|.* create \s+ index \s+ idx_uiruid \s+ on \s+ userImageRating \s* \(userInfo_id\) \s* (;)? |six, q{Expect index}); like($association_str, qr|.* create \s+ index \s+ idx_acid \s+ on \s+ attributeCategory \s* \(id\) \s* (;)? |six, q{Expect index}); like($association_str, qr|.* create \s+ index \s+ idx_usmd5 \s+ on \s+ userSession \s* \(md5sum\) \s* (;)? |six, q{Expect index}); # foreign keys like($association_str, qr|.* alter \s+ table \s+ subImageInfo \s+ add \s+ constraint \s+ fk_iisii \s+ foreign \s+ key \s* \( \s* imageInfo_id \s* \) \s* \s+ references \s+ imageInfo \s* \( \s* id \s* \) \s* (;)? .* |six, q{Expect foreign key fk_iisii on subImageInfo}); diag(q{TODO: add all foreign keys}); __END__ undef $diasql; # ------- many-to-many relations ------- my $diasql_m2m = Parse::Dia::SQL->new( file => catfile(qw(t data many_to_many.dia)), db => 'sybase' ); isa_ok($diasql_m2m, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); # TODO: Add test on return value - call wrapper $diasql_m2m->convert(); my $association_m2m_arrayref = $diasql_m2m->get_associations_ref(); #diag("association_m2m_arrayref: ".Dumper($association_m2m_arrayref)); my $expected_m2m = [ [ 'student_course', 'stdn_crs_fk_StntSn', 'course_id', 'student', 'ssn', 'on delete cascade' ], [ 'student_course', 'lTeT8iBKfXObJYiSrq', 'ssn', 'course', 'course_id', 'on delete cascade' ] ]; is_deeply( $association_m2m_arrayref, $expected_m2m ); # or diag( q{association_m2m_arrayref: } # . Dumper($association_m2m_arrayref) # . q{ expected } # . Dumper($expected_m2m) ); my $output_m2m = undef; isa_ok($diasql_m2m, 'Parse::Dia::SQL'); lives_ok(sub { $output_m2m = $diasql_m2m->get_output_instance(); }, q{get_output_instance (sybase) should not die}); isa_ok($output_m2m, 'Parse::Dia::SQL::Output') or diag(Dumper($output_m2m)); isa_ok($output_m2m, 'Parse::Dia::SQL::Output::Sybase') or diag(Dumper($output_m2m)); can_ok($output_m2m, 'get_associations_create'); # associations = foreign keys + indices my $association_str_m2m = $output_m2m->get_associations_create(); # check 2 foreign keys like($association_str_m2m, qr/.* alter \s+ table \s+ student_course \s+ add \s+ constraint \s+ stdn_crs_fk_StntSn \s+ foreign \s+ key \s* \( \s* course_id \s* \) \s+ references \s+ student \s* \( \s* ssn \s* \) \s* on \s+ delete \s+ cascade .*/six); like($association_str_m2m, qr/.* alter \s+ table \s+ student_course \s+ add \s+ constraint \s+ lTeT8iBKfXObJYiSrq \s+ foreign \s+ key \s* \( \s* ssn \s* \) \s* references \s+ course \s+ \s* \( \s* course_id \) \s* on \s+ delete \s+ cascade .*/six); __END__ Parse-Dia-SQL-0.30/t/644-output-mysql-get-drop-index-sql.t0000644000175000017500000000772513035770477021027 0ustar affaff# $Id: 644-output-mysql-get-drop-index-sql.t,v 1.1 2009/02/23 07:36:17 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use Test::Exception; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 41; use lib q{lib}; use_ok ('Parse::Dia::SQL'); use_ok ('Parse::Dia::SQL::Output'); use_ok ('Parse::Dia::SQL::Output::MySQL'); my $diasql = Parse::Dia::SQL->new( file => catfile(qw(t data TestERD.dia)), db => 'mysql-myisam' ); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); is($diasql->convert(), 1, q{Expect convert() to return 1}); my $output = undef; isa_ok($diasql, 'Parse::Dia::SQL'); lives_ok(sub { $output = $diasql->get_output_instance(); }, q{get_output_instance (mysql-myisam) should not die}); isa_ok($output, 'Parse::Dia::SQL::Output'); isa_ok($output, 'Parse::Dia::SQL::Output::MySQL'); isa_ok($output, 'Parse::Dia::SQL::Output::MySQL::MyISAM'); can_ok($output, 'get_constraints_drop'); my $drop_constraints = $output->get_constraints_drop(); #diag($drop_constraints); # indices like($drop_constraints, qr/.* drop \s+ index \s+ idx_iimd5 \s+ on \s+ imageInfo \s* (;)? .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ idx_iiid \s+ on \s+ imageInfo \s* (;)? .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ idx_siiid \s+ on \s+ subImageInfo \s* (;)? .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ idx_siips \s+ on \s+ subImageInfo \s* (;)? .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ idx_iclidnm \s+ on \s+ imageCategoryList \s* (;)? .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ idx_uinm \s+ on \s+ userInfo \s* (;)? .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ idx_uiid \s+ on \s+ userInfo \s* (;)? .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ idx_uauiid \s+ on \s+ userAttribute \s* (;)? .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ idx_uiruid \s+ on \s+ userImageRating \s* (;)? .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ idx_acid \s+ on \s+ attributeCategory \s* (;)? .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ idx_usmd5 \s+ on \s+ userSession \s* (;)? .*/six); # do it all again this time for InnoDB $diasql = Parse::Dia::SQL->new( file => catfile(qw(t data TestERD.dia)), db => 'mysql-innodb' ); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); is($diasql->convert(), 1, q{Expect convert() to return 1}); $output = undef; isa_ok($diasql, 'Parse::Dia::SQL'); lives_ok(sub { $output = $diasql->get_output_instance(); }, q{get_output_instance (mysql-innodb) should not die}); isa_ok($output, 'Parse::Dia::SQL::Output'); isa_ok($output, 'Parse::Dia::SQL::Output::MySQL'); isa_ok($output, 'Parse::Dia::SQL::Output::MySQL::InnoDB'); can_ok($output, 'get_constraints_drop'); $drop_constraints = $output->get_constraints_drop(); #diag($drop_constraints); # indices like($drop_constraints, qr/.* drop \s+ index \s+ idx_iimd5 \s+ on \s+ imageInfo \s* (;)? .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ idx_iiid \s+ on \s+ imageInfo \s* (;)? .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ idx_siiid \s+ on \s+ subImageInfo \s* (;)? .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ idx_siips \s+ on \s+ subImageInfo \s* (;)? .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ idx_iclidnm \s+ on \s+ imageCategoryList \s* (;)? .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ idx_uinm \s+ on \s+ userInfo \s* (;)? .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ idx_uiid \s+ on \s+ userInfo \s* (;)? .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ idx_uauiid \s+ on \s+ userAttribute \s* (;)? .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ idx_uiruid \s+ on \s+ userImageRating \s* (;)? .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ idx_acid \s+ on \s+ attributeCategory \s* (;)? .*/six); like($drop_constraints, qr/.* drop \s+ index \s+ idx_usmd5 \s+ on \s+ userSession \s* (;)? .*/six); __END__ Parse-Dia-SQL-0.30/t/600-output-load.t0000644000175000017500000000041013035770477015130 0ustar affaff# $Id: 600-output-load.t,v 1.1 2009/02/23 07:36:17 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 1; use lib q{lib}; use_ok ('Parse::Dia::SQL::Output'); __END__ Parse-Dia-SQL-0.30/t/704-utils-split-type.t0000644000175000017500000000141013035770477016131 0ustar affaff# $Id: 704-utils-split-type.t,v 1.1 2010/01/22 21:33:15 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 7; use lib q{lib}; use_ok ('Parse::Dia::SQL::Utils'); # Need to specify database for make_name to pass my $utils = Parse::Dia::SQL::Utils->new( db => 'db2' ); isa_ok($utils, 'Parse::Dia::SQL::Utils'); # make_name my @arr = $utils->split_type("integer(4)"); is_deeply(\@arr, ["integer", "(4)"], "integer(4)"); @arr = $utils->split_type("string(80)"); is_deeply(\@arr, ["string", "(80)"], "string(80)"); @arr = $utils->split_type("string"); is_deeply(\@arr, ["string"], "string"); ok (! $utils->split_type(""), "empty"); ok (! $utils->split_type(), "undef"); __END__ Parse-Dia-SQL-0.30/t/620-output-get-schema-create-many-to-many.t0000644000175000017500000000346613035770477022033 0ustar affaff# $Id: 620-output-get-schema-create-many-to-many.t,v 1.4 2009/11/12 09:56:50 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use Test::Exception; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 14; use lib q{lib}; use_ok ('Parse::Dia::SQL'); use_ok ('Parse::Dia::SQL::Output'); use_ok ('Parse::Dia::SQL::Output::DB2'); # 1. parse input my $diasql = Parse::Dia::SQL->new( file => catfile(qw(t data many_to_many.dia)), db => 'db2' ); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); is($diasql->convert(), 1, q{Expect convert to return 1}); my $classes = $diasql->get_classes_ref(); my $associations = $diasql->get_associations_ref(); my $smallpackages = $diasql->get_smallpackages_ref(); # check parsed content ok(defined($classes) && ref($classes) eq q{ARRAY} && scalar(@$classes), q{Non-empty array ref}); ok(defined($associations) && ref($associations) eq q{ARRAY} && scalar(@$associations), q{Non-empty array ref}); # 2. get output instance my $subclass = undef; lives_ok(sub { $subclass = $diasql->get_output_instance(); }, q{get_output_instance (db2) should not die}); isa_ok($subclass, 'Parse::Dia::SQL::Output') or diag(Dumper($subclass)); isa_ok($subclass, 'Parse::Dia::SQL::Output::DB2') or diag(Dumper($subclass)); can_ok($subclass, 'get_schema_create'); # 3. schema my $schema = $subclass->get_schema_create(); like($schema, qr|.* create \s+ table \s+ student \s* .*|six, q{Check syntax for sql create table student}); like($schema, qr|.* create \s+ table \s+ course \s* .*|six, q{Check syntax for sql create table course}); like($schema, qr|.* create \s+ table \s+ student_course \s* .*|six, q{Check syntax for sql create table student_course}); # Note: Associations are tested in 650-output-get-create-associations.t __END__ Parse-Dia-SQL-0.30/t/682-output-sybase-get-sql.t0000644000175000017500000000150113035770477017065 0ustar affaff# $Id: 682-output-sybase-get-sql.t,v 1.3 2009/02/28 06:54:57 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use Test::Exception; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 7; diag 'Sybase support is experimental'; use lib q{lib}; use_ok ('Parse::Dia::SQL'); use_ok ('Parse::Dia::SQL::Output'); use_ok ('Parse::Dia::SQL::Output::Sybase'); my $diasql = Parse::Dia::SQL->new(file => catfile(qw(t data TestERD.dia)), db => 'sybase'); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); is($diasql->convert(), 1, q{Expect convert() == 1}); can_ok($diasql, q{get_output_instance}); my $subclass = $diasql->get_output_instance(); isa_ok( $subclass, q{Parse::Dia::SQL::Output::Sybase}, q{Expect a Parse::Dia::SQL::Output::Sybase object} ); __END__ Parse-Dia-SQL-0.30/t/683-output-oracle-get-sql.t0000644000175000017500000000150113035770477017045 0ustar affaff# $Id: 683-output-oracle-get-sql.t,v 1.3 2009/02/28 06:54:57 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use Test::Exception; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 7; diag 'Oracle support is experimental'; use lib q{lib}; use_ok ('Parse::Dia::SQL'); use_ok ('Parse::Dia::SQL::Output'); use_ok ('Parse::Dia::SQL::Output::Oracle'); my $diasql = Parse::Dia::SQL->new(file => catfile(qw(t data TestERD.dia)), db => 'oracle'); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); is($diasql->convert(), 1, q{Expect convert() == 1}); can_ok($diasql, q{get_output_instance}); my $subclass = $diasql->get_output_instance(); isa_ok( $subclass, q{Parse::Dia::SQL::Output::Oracle}, q{Expect a Parse::Dia::SQL::Output::Oracle object} ); __END__ Parse-Dia-SQL-0.30/t/686-output-sas-get-sql.t0000644000175000017500000000145713035770477016403 0ustar affaff# $Id: 686-output-sas-get-sql.t,v 1.3 2009/02/28 06:54:57 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use Test::Exception; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 7; diag 'Sas support is experimental'; use lib q{lib}; use_ok ('Parse::Dia::SQL'); use_ok ('Parse::Dia::SQL::Output'); use_ok ('Parse::Dia::SQL::Output::Sas'); my $diasql = Parse::Dia::SQL->new(file => catfile(qw(t data TestERD.dia)), db => 'sas'); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); is($diasql->convert(), 1, q{Expect convert() == 1}); can_ok($diasql, q{get_output_instance}); my $subclass = $diasql->get_output_instance(); isa_ok( $subclass, q{Parse::Dia::SQL::Output::Sas}, q{Expect a Parse::Dia::SQL::Output::Sas object} ); __END__ Parse-Dia-SQL-0.30/t/951-rt50906.t0000644000175000017500000000173213035770500013710 0ustar affaff# $Id: 951-rt50906.t,v 1.3 2009/11/17 11:00:02 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use Test::Exception; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 7; use lib q{lib}; use_ok ('Parse::Dia::SQL'); use_ok ('Parse::Dia::SQL::Output'); use_ok ('Parse::Dia::SQL::Output::Postgres'); my $diasql = Parse::Dia::SQL->new(file => catfile(qw(t data rt50906.dia)), db => 'postgres'); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); can_ok($diasql, q{get_sql}); my $sql = $diasql->get_sql(); isa_ok( $diasql->get_output_instance(), q{Parse::Dia::SQL::Output::Postgres}, q{Expect Parse::Dia::SQL::Output::Postgres to be used as back-end} ); like($sql, qr/.* alter \s+ table \s+ tbl_detail \s+ add \s+ constraint \s+ fk_detail_main \s+ foreign \s+ key \s+ \( \s* fk_main \s* \) \s+ references \s+ tbl_main \s+ \( \s* pk_main \s* \) \s+ ON \s+ DELETE \s+ CASCADE \s* ; .*/six); __END__ Parse-Dia-SQL-0.30/t/952-rt52755.t0000644000175000017500000000245713035770500013722 0ustar affaff# $Id: 952-rt52755.t,v 1.1 2009/12/18 07:02:56 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use Test::Exception; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 8; use lib q{lib}; use_ok ('Parse::Dia::SQL'); use_ok ('Parse::Dia::SQL::Output'); use_ok ('Parse::Dia::SQL::Output::Postgres'); my $diasql = Parse::Dia::SQL->new(file => catfile(qw(t data rt52755.dia)), db => 'postgres'); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); can_ok($diasql, q{get_sql}); my $sql = $diasql->get_sql(); isa_ok( $diasql->get_output_instance(), q{Parse::Dia::SQL::Output::Postgres}, q{Expect Parse::Dia::SQL::Output::Postgres to be used as back-end} ); # diag $sql; like($sql, qr/.* create \s+ table \s+ users \s* \( \s* id \s+ serial \s* , \s* first \s+ TEXT \s+ not \s+ null \s*, \s+ last \s+ TEXT \s* , \s+ UNIQUE \s* \( \s* first \s*, \s* last \s* \) \s* , \s+ UNIQUE \s* \( \s* first \s* \) \s* \) \s* ; .*/six); like($sql, qr/.* create \s+ table \s+ testimonies \s+ \( \s+ id \s+ serial \s* , \s+ from \s+ integer \s+ not \s+ null \s* , \s+ to \s+ integer \s+ not \s+ null \s* , \s+ subject \s+ text \s* , \s+ comment \s+ text \s+ not \s+ null \s* , \s+ UNIQUE \s+ \( \s* id \s* , \s* from \s* \) \s* \) \s* ; .*/six); __END__ Parse-Dia-SQL-0.30/t/204-parse-classes-atts.t0000644000175000017500000001375313035770477016407 0ustar affaff# $Id: 204-parse-classes-atts.t,v 1.4 2009/04/01 08:10:43 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 47; use_ok ('Parse::Dia::SQL'); my $diasql = Parse::Dia::SQL->new( file => catfile(qw(t data TestERD.dia)), db => 'db2' ); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); # TODO: Add test on return value - call wrapper $diasql->convert(); my $classes = $diasql->get_classes_ref(); # Expect an array ref with 14 elements isa_ok($classes, 'ARRAY'); cmp_ok(scalar(@$classes), q{==}, 14, q{Expect 14 classes}); # Hash with class/view names as keys and attribute list as (hashref) elements my %atts = ( imageInfo => { 'binarytype' => [ 'binaryType', 'varchar (16)', '\'jpg\' null', '0', '' ], 'name' => [ 'name', 'varchar (64)', 'not null', '0', '' ], 'description' => [ 'description', 'varchar (128)', 'null', '0', '' ], 'md5sum' => [ 'md5sum', 'char (32)', 'not null', '0', '' ], 'fmorg' => [], 'locationlist' => [ 'locationList', 'varchar (128)', '\'//imgserver.org\'', '0', '' ], 'public' => [], 'id' => [ 'id', 'numeric (18)', '', '2', '' ], 'insertiondate' => [ 'insertionDate', 'timestamp', 'not null', '0', '' ] }, subImageInfo => { 'fmorg' => [], 'pixsize' => [ 'pixSize', 'integer', '', '2', '' ], 'imageinfo_id' => [ 'imageInfo_id', 'numeric (18)', '', '2', '' ] }, imageCategoryList => { 'fmorg' => [], 'imageinfo_id' => [ 'imageInfo_id', 'numeric (18)', '', '2', '' ], 'name' => [ 'name', 'varchar (32)', '', '2', '' ] }, categoryNames => { 'fmorg' => [], 'public' => [], 'name' => [ 'name', 'varchar (32)', '', '2', '' ] }, imageAttribute => { 'numvalue' => [ 'numValue', 'numeric (8)', '', '0', '' ], 'fmorg' => [], 'attributecategory_id' => [ 'attributeCategory_id', 'numeric (18)', '', '2', '' ], 'imageinfo_id' => [ 'imageInfo_id', 'numeric (18)', '', '2', '' ], 'category' => [ 'category', 'numeric (4)', '', '0', '' ] }, userInfo => { 'currentcategory' => [ 'currentCategory', 'varchar (32)', '', '0', '' ], 'birthdate' => [ 'birthDate', 'timestamp', '', '0', '' ], 'active' => [ 'active', 'integer', '', '0', '' ], 'name' => [ 'name', 'varchar (32)', '', '0', '' ], 'md5sum' => [ 'md5sum', 'char (32)', '', '0', '' ], 'email' => [ 'email', 'varchar (96)', '', '0', '' ], 'fmorg' => [], 'lastdebitdate' => [ 'lastDebitDate', 'timestamp', '', '0', '' ], 'acctbalance' => [ 'acctBalance', 'numeric (10,2)', '', '0', '' ], 'id' => [ 'id', 'numeric (18)', '', '2', '' ], 'insertiondate' => [ 'insertionDate', 'timestamp', '', '0', '' ], 'gender' => [ 'gender', 'char (1)', '', '0', '' ] }, userAttribute => { 'numvalue' => [ 'numValue', 'numeric (5,4)', '', '0', '' ], 'fmorg' => [], 'attributecategory_id' => [ 'attributeCategory_id', 'numeric (18)', '', '2', '' ], 'userinfo_id' => [ 'userInfo_id', 'numeric (18)', '', '2', '' ] }, userImageRating => { 'fmorg' => [], 'imageinfo_id' => [ 'imageInfo_id', 'numeric (15)', '', '2', '' ], 'userinfo_id' => [ 'userInfo_id', 'numeric (18)', '', '2', '' ], 'rating' => [ 'rating', 'integer', '', '0', '' ] }, attributeCategory => { 'attributedesc' => [ 'attributeDesc', 'varchar (128)', '', '0', '' ], 'fmorg' => [], 'id' => [ 'id', 'numeric (18)', '', '2', '' ] }, userSession => { 'fmorg' => [], 'userinfo_id' => [ 'userInfo_id', 'numeric (18)', '', '2', '' ], 'expiredate' => [ 'expireDate', 'timestamp', '', '0', '' ], 'ipaddress' => [ 'ipAddress', 'varchar (24)', '', '0', '' ], 'md5sum' => [ 'md5sum', 'char (32)', '', '2', '' ], 'insertiondate' => [ 'insertionDate', 'timestamp', '', '0', '' ] }, extremes => { 'maxval' => [ 'maxVal', 'numeric (15)', '', '0', '' ], 'fmorg' => [], 'minval' => [ 'minVal', 'numeric (15)', '', '0', '' ], 'public' => [], 'name' => [ 'name', 'varchar (32)', '', '2', '' ], 'colname' => [ 'colName', 'varchar (64)', '', '0', '' ] }, ratings_view => { 'c.md5sum' => [ 'c.md5sum', '', '', '0', '' ], 'a.rating' => [ 'a.rating', '', '', '0', '' ], 'b.name' => [ 'b.name', '', '', '0', '' ] }, whorated_view => { 'count (*) as numratings' => [ 'count (*) as numRatings', '', '', '0', '' ], 'a.name' => [ 'a.name', '', '', '0', '' ] }, users_view => { 'name ||\'<\'|| email ||\'>\' as whoisthis' => [ 'name ||\'<\'|| email ||\'>\' as whoIsThis', '', '', '0', '' ], 'acctbalance' => [ 'acctBalance', '', '', '0', '' ], 'currentcategory' => [ 'currentCategory', '', '', '0', '' ], 'birthdate' => [ 'birthDate', '', '', '0', '' ], 'active' => [ 'active', '', '', '0', '' ], 'id' => [ 'id', '', '', '0', '' ] }, ); # Check that each class has of the expected atts attributes foreach my $class (@$classes) { isa_ok($class, 'HASH'); ok(exists($atts{$class->{name}})) or diag(q{Unexpected class name: }. $class->{name}); # check contents is_deeply( $class->{atts}, $atts{ $class->{name} }, q{atts for } . $class->{name} ); # remove class from hash delete $atts{$class->{name}}; } # Expect no classes left now cmp_ok(scalar(keys %atts), q{==}, 0, q{Expect 0 classes}); __END__ Parse-Dia-SQL-0.30/t/681-output-db2-get-sql.t0000644000175000017500000000272713035770477016260 0ustar affaff# $Id: 681-output-db2-get-sql.t,v 1.2 2009/02/26 19:58:37 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use Test::Exception; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 5; use lib q{lib}; use_ok ('Parse::Dia::SQL'); use_ok ('Parse::Dia::SQL::Output'); use_ok ('Parse::Dia::SQL::Output::DB2'); my $diasql = Parse::Dia::SQL->new( file => catfile(qw(t data TestERD.dia)), db => 'db2'); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); my $sql = $diasql->get_sql; # ------ check statement sequence ------- diag("TODO: Get monk help with this regex.."); like($sql, qr/.* (alter \s+ table \s+ \w+ \s+ drop \s+ constraint \s+ \w+ \s* ; \s*) +? \s* .*? (drop \s+ index \s+ \w+ \s* ; \s*) +? \s* .*? (revoke \s+ \w+ \s+ on \s+ \w+ \s+ from \s+ \w+ \s* ; \s*) +? \s* .*? (drop \s+ sequence \s+ \w+ \s* ; \s*) *? \s* .*? (create \s+ sequence \s+ \w+ \s* ; \s*) *? \s* .*? (drop \s+ view \s+ \w+ \s* ; \s*) *? \s* .*? (--drop \s+ trigger .* ) *? \s* (--create \s+ trigger .* ) *? \s* .*? (grant \s+ \w+ \s+ on \s+ \w+ \s+ to \s+ \w+ \s* ; \s*) *? \s* .*? (insert \s+ into \s+ \w+ \s+ values \s+ \w+ \s* ; \s*) *? \s* .*? (create \s+ (unique)? \s+ index \s+ \w+ \s+ on \s+ \w+ \s* ; \s*) *? \s* .*? (alter \s+ table \s+ \w+ \s+ add \s+ constraint \s+ \w+ \s+ foreign \s+ key \s+ \w+ \s+ vreferences \s+ \w+ \s* ; \s*) *? \s* .*/six, q{check sequence of statements}); __END__ Parse-Dia-SQL-0.30/t/907-test-explicit-plan.t0000644000175000017500000000217713035770500016412 0ustar affaff # $Id: 907-test-explicit-plan.t,v 1.1 2009/02/23 07:36:17 aff Exp $ use strict; use warnings; use Data::Dumper; use Test::More; use File::Find; use Fatal qw (open close); BEGIN { if ( !$ENV { 'AUTHOR_TEST' } ) { plan( skip_all => 'AUTHOR_TEST must be set for explicit plan test; skipping' ); } else { plan tests => 1; # Obey the rule :) } } my @violations = (); find( sub { return unless -f && -r; return unless m/\.t$/; return if m/test-explicit-plan/; # Do not test this file my $file = $_; my $FH = undef; open ($FH, "<", $file); #diag(qq{Checking $file for missing plan}); while (<$FH>) { push @violations, $file if m/plan.*no_plan/; } close $FH; }, q{t} ); # Report violations if any cmp_ok( scalar(@violations), q{==}, 0, q{Expect 0 violations of 'no_plan' rule} ) or diag( Dumper(@violations) ); __END__ =pod Ensure all tests have an explicit plan (i.e. disallow "plan 'no_plan'"). Search the test directory for test files (t/*.t) and report fail if any file contains the 'no_plan' keyword on a line that is not a comment. TODO: Get rid of false positives that are commented out. =cut Parse-Dia-SQL-0.30/t/612-output-get-comment.t0000644000175000017500000000173213035770477016443 0ustar affaff# $Id: 612-output-get-comment.t,v 1.6 2009/04/01 07:53:33 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use Test::Exception; # test code that dies use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 6; use lib q{lib}; use_ok ('Parse::Dia::SQL'); use_ok ('Parse::Dia::SQL::Output'); my $diasql = Parse::Dia::SQL->new(db => 'db2'); $diasql->{converted} = 1; # Fool Parse::Dia::SQL into thinking convert() was called $diasql->{files} = ['foo.dia','bar.dia','tze.dia']; my $subclass = undef; lives_ok( sub { $subclass = $diasql->get_output_instance(); }, q{get_output_instance (db2) should not die}); isa_ok($subclass, 'Parse::Dia::SQL::Output::DB2'); my $comment = undef; lives_ok( sub { $comment = $subclass->_get_comment(); }, q{_get_comment should not die}); # check that comments start with "--" cmp_ok(scalar(grep(!/^--/, split("\n", $subclass->_get_comment()))), q{==}, 0, q{Expect 0 lines to not begin with --}); __END__ Parse-Dia-SQL-0.30/t/225-parse-classes-pk.t0000644000175000017500000000250513035770477016042 0ustar affaff# $Id: 225-parse-classes-pk.t,v 1.1 2010/04/10 12:59:11 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 8; use_ok ('Parse::Dia::SQL'); my $diasql = Parse::Dia::SQL->new( file => catfile(qw(t data rt56357.dia)), db => 'db2' ); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); # TODO: Add test on return value - call wrapper $diasql->convert(); my $classes = $diasql->get_classes_ref(); # Expect an array ref with 1 elements isa_ok($classes, 'ARRAY'); cmp_ok(scalar(@$classes), q{==}, 1, q{Expect 1 class}); # Hash with class/view names as keys and primary key as (hashref) elements my %pk = ( bar => [ [ 'foo', 'int', '', '2', '', 'false' ] ], ); # Check that each class has of the expected pk attributes foreach my $class (@$classes) { isa_ok($class, 'HASH', q{Expect HASH ref}); ok(exists($pk{$class->{name}})) or diag(q{Unexpected class name: }. $class->{name}); # diag($class->{name} . ' pk :' . Dumper($class->{pk})); # check contents is_deeply( $class->{pk}, $pk{ $class->{name} }, q{pk for } . $class->{name} ); # remove class from hash delete $pk{$class->{name}}; } # Expect no classes left now cmp_ok(scalar(keys %pk), q{==}, 0, q{Expect 0 classes left}); __END__ Parse-Dia-SQL-0.30/t/623-output-get-view-create.t0000644000175000017500000000510013035770477017207 0ustar affaff# $Id: 623-output-get-view-create.t,v 1.1 2009/02/23 07:36:17 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use Test::Exception; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 14; use lib q{lib}; use_ok ('Parse::Dia::SQL'); use_ok ('Parse::Dia::SQL::Output'); use_ok ('Parse::Dia::SQL::Output::DB2'); # 1. parse input my $db = 'db2'; my $diasql = Parse::Dia::SQL->new(file => catfile(qw(t data TestERD.dia)), db => $db); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); is($diasql->convert(), 1, q{Expect convert to return 1}); # 2. Check parsed content my $classes = $diasql->get_classes_ref(); ok(defined($classes) && ref($classes) eq q{ARRAY} && scalar(@$classes), q{Non-empty array ref}); # 3. output my $output = undef; isa_ok($diasql, 'Parse::Dia::SQL'); lives_ok( sub { $output = $diasql->get_output_instance(); }, q{get_output_instance (db2) should not die} ); isa_ok($output, 'Parse::Dia::SQL::Output') or diag(Dumper($output)); isa_ok($output, 'Parse::Dia::SQL::Output::DB2') or diag(Dumper($output)); can_ok($output, 'get_view_create'); # 4. check view sql my $create_view = $output->get_view_create(); # -- ratings_view like($create_view, qr| .* create \s+ view \s+ ratings_view \s+ as \s+ select \s+ b.name \s* , \s* c.md5sum \s* , \s*a.rating \s+ from \s+ userImageRating \s+ a \s* , \s* userImageRating \s+ z \s* , \s* userInfo \s+ b \s* , \s* imageInfo \s+ c \s+ where \s+ \(\(\(a.userInfo_id \s* = \s* b.id\) \s+ and \s+ \(a.imageInfo_id \s* = \s* c.id\) \s+ and \s+ \(a.userInfo_id \s* = \s* z.userInfo_id\)\) \s+ and \s+ \(a.userInfo_id \s* <> \s* z.userInfo_id\)\) \s+ order \s+ by \s+ c.md5sum \s* , \s* b.name \s* , \s* a.rating \s* (;)? .* |six, q{Check syntax for sql create view ratings_view}); # -- whorated_view like($create_view, qr| .* create \s+ view \s+ whorated_view \s+ as \s+ select \s+ a.name \s* , \s* count \s* \( \s* \* \s* \) \s+ as \s+ numRatings \s+ from \s+ userInfo \s+ a, \s* userImageRating \s+ b \s+ where \s* \( \s* a.id \s* = \s* b.userInfo_id \s* \) \s+ group \s+ by \s+ a.name \s* (;)? .* |six, q{Check syntax for sql create view whorated_view}); # -- users_view like($create_view, qr| .* create \s+ view \s+ users_view \s+ as \s+ select \s+ id \s* , \s* birthDate \s* , \s* name \s+ \|\|'\<'\|\| \s+ email \s+ \|\|'\>' \s+ as \s+ whoIsThis \s* , \s* currentCategory \s* , \s* acctBalance \s* , \s* active \s+ from \s+ userInfo \s+ order \s+ by \s+ userInfo.name \s* (;)? .* |six, q{Check syntax for sql create view users_view}); __END__ Parse-Dia-SQL-0.30/t/687-output-mysql-innodb-get-sql-alter-table-backticks.t0000644000175000017500000000217613035770477024357 0ustar affaff# $Id: 687-output-mysql-innodb-get-sql.t,v 1.5 2009/09/28 19:12:06 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use Test::Exception; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 8; use lib q{lib}; use_ok ('Parse::Dia::SQL'); use_ok ('Parse::Dia::SQL::Output'); use_ok ('Parse::Dia::SQL::Output::MySQL'); use_ok ('Parse::Dia::SQL::Output::MySQL::InnoDB'); my $diasql = Parse::Dia::SQL->new(file => catfile(qw(t data TestERD.dia)), db => 'mysql-innodb', backticks => 1); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); can_ok($diasql, q{get_sql}), # object should have method get_sql() my $sql = $diasql->get_sql(); isa_ok( $diasql->get_output_instance(), q{Parse::Dia::SQL::Output::MySQL::InnoDB}, q{Expect Parse::Dia::SQL::Output::MySQL::InnoDB to be used as back-end} ); #diag($sql); # Check for backticks: like($sql, qr/.* alter \s+ table \s+ `userAttribute` \s+ add \s+ constraint \s+ fk_acua \s+ foreign \s+ key \s+ \( \s* attributeCategory_id \s* \) \s+ references \s+ `attributeCategory` \s+ \( \s* id \s* \) \s* ; .*/six); __END__ Parse-Dia-SQL-0.30/t/620-output-get-schema-create.t0000644000175000017500000001464313035770477017506 0ustar affaff# $Id: 620-output-get-schema-create.t,v 1.2 2009/04/01 08:10:43 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use Test::Exception; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 23; use lib q{lib}; use_ok ('Parse::Dia::SQL'); use_ok ('Parse::Dia::SQL::Output'); use_ok ('Parse::Dia::SQL::Output::DB2'); # 1. parse input my $db = 'db2'; my $diasql = Parse::Dia::SQL->new( file => catfile(qw(t data TestERD.dia)), db => $db ); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); is($diasql->convert(), 1, q{Expect convert to return 1}); my $classes = $diasql->get_classes_ref(); my $associations = $diasql->get_associations_ref(); my $smallpackages = $diasql->get_smallpackages_ref(); # check parsed content ok(defined($classes) && ref($classes) eq q{ARRAY} && scalar(@$classes), q{Non-empty array ref}); ok(defined($associations) && ref($associations) eq q{ARRAY} && scalar(@$associations), q{Non-empty array ref}); ok( defined($smallpackages) && ref($smallpackages) eq q{ARRAY} && scalar(@$smallpackages), q{Non-empty array ref} ); # 2. get output instance my $subclass = undef; lives_ok(sub { $subclass = $diasql->get_output_instance(); }, q{get_output_instance (db2) should not die}); isa_ok($subclass, 'Parse::Dia::SQL::Output') or diag(Dumper($subclass)); isa_ok($subclass, 'Parse::Dia::SQL::Output::DB2') or diag(Dumper($subclass)); can_ok($subclass, 'get_schema_create'); # 3. create sql my $create_table = $subclass->get_schema_create(); # TODO: Notice that the primary key name can be any key starting with # 'pk_'. This has to be changed for the DB2 support (18 char limit) like($create_table, qr|.* create \s+ table \s+ imageInfo \s* \( \s* id \s+ numeric \s* \(18\) \s+ not \s+ null \s* , \s* insertionDate \s+ timestamp \s+ not \s+ null \s* , \s* md5sum \s+ char \s* \(32\) \s+ not \s+ null \s* , \s* binaryType \s+ varchar \s* \(16\) \s+ default \s+ 'jpg' \s+ null \s* , \s* name \s+ varchar \s* \(64\) \s+ not \s+ null \s* , \s* locationList \s+ varchar \s* \(128\) \s+ default \s+ '//imgserver.org' \s* , \s* description \s+ varchar \s* \(128\) \s+ null \s* , \s* constraint \s+ pk_\w+ \s+ primary \s+ key \s* \(id\) \s* \) \s* (;)? .*|six, q{Check syntax for sql create table imageInfo}); like($create_table, qr|.* create \s+ table \s+ subImageInfo \s* \( \s* imageInfo_id \s+ numeric \s* \(18\) \s+ not \s+ null \s* , \s* pixSize \s+ integer \s+ not \s+ null \s* , \s* constraint \s+ pk_\w+ \s+ primary \s+ key \s* \(imageInfo_id \s* , \s* pixSize\) \s* \) \s* (;)? .*|six, q{Check syntax for sql create table SubimageInfo}); like($create_table, qr|.* create \s+ table \s+ imageCategoryList \s* \( \s* imageInfo_id \s+ numeric \s* \(18\) \s+ not \s+ null \s* , \s* name \s+ varchar \s* \(32\) \s+ not \s+ null \s* , \s* constraint \s+ \w+ \s+ primary \s+ key \s* \(imageInfo_id \s* , \s* name\) \s* \) \s* (;)? .*|six, q{Check syntax for sql create table imageCategoryList}); like($create_table, qr|.* create \s+ table \s+ categoryNames \s* \( \s* name \s+ varchar \s* \(32\) \s+ not \s+ null \s* , \s* constraint \s+ pk_\w+ \s+ primary \s+ key \s* \(name\) \s* \) \s* (;)? .*|six, q{Check syntax for sql create table categoryNames}); like($create_table, qr|.* create \s+ table \s+ imageAttribute \s* \( \s* imageInfo_id \s+ numeric \s* \(18\) \s+ not \s+ null \s* , \s* attributeCategory_id \s+ numeric \s* \(18\) \s+ not \s+ null \s* , \s* numValue \s+ numeric \s* \(8\) \s* , \s* category \s+ numeric \s* \(4\) \s* , \s* constraint \s+ pk_\w+ \s+ primary \s+ key \s* \(imageInfo_id,attributeCategory_id\) \s* \) \s* (;)? .*|six, q{Check syntax for sql create table imageAttribute}); like($create_table, qr|.* create \s+ table \s+ userInfo \s* \( \s* id \s+ numeric \s* \(18\) \s+ not \s+ null \s* , \s* insertionDate \s+ timestamp \s* , \s* md5sum \s+ char \s* \(32\) \s* , \s* birthDate \s+ timestamp \s* , \s* gender \s+ char \s* \(1\) \s* , \s* name \s+ varchar \s* \(32\) \s* , \s* email \s+ varchar \s* \(96\) \s* , \s* currentCategory \s+ varchar \s* \(32\) \s* , \s* lastDebitDate \s+ timestamp \s* , \s* acctBalance \s+ numeric \s* \(10,2\) \s* , \s* active \s+ integer \s* , \s* constraint \s+ pk_\w+ \s+ primary \s+ key \s* \(id\) \s* \) \s* (;)? .*|six, q{Check syntax for sql create table userInfo}); like($create_table, qr|.* create \s+ table \s+ userAttribute \s* \( \s* userInfo_id \s+ numeric \s* \(18\) \s+ not \s+ null \s* , \s* attributeCategory_id \s+ numeric \s* \(18\) \s+ not \s+ null \s* , \s* numValue \s+ numeric \s* \(5,4\) \s* , \s* constraint \s+ pk_\w+ \s+ primary \s+ key \s* \(userInfo_id,attributeCategory_id\) \s* \) \s* (;)? .*|six, q{Check syntax for sql create table userAttribute}); like($create_table, qr|.* create \s+ table \s+ userImageRating \s* \( \s* userInfo_id \s+ numeric \s* \(18\) \s+ not \s+ null \s* , \s* imageInfo_id \s+ numeric \s* \(15\) \s+ not \s+ null \s* , \s* rating \s+ integer \s* , \s* constraint \s+ pk_\w+ \s+ primary \s+ key \s* \(userInfo_id,imageInfo_id\) \s* \) \s* (;)? .*|six, q{Check syntax for sql create table userAttribute}); like($create_table, qr|.* create \s+ table \s+ attributeCategory \s* \( \s* id \s+ numeric \s* \(18\) \s+ not \s+ null \s* , \s* attributeDesc \s+ varchar \s* \(128\) \s* , \s* constraint \s+ pk_\w+ \s+ primary \s+ key \s* \(id\) \s* \) \s* (;)? .*|six, q{Check syntax for sql create table userAttribute}); like($create_table, qr|.* create \s+ table \s+ userSession \s* \( \s* userInfo_id \s+ numeric \s* \(18\) \s+ not \s+ null \s* , \s* md5sum \s+ char \s* \(32\) \s+ not \s+ null \s* , \s* insertionDate \s+ timestamp \s* , \s* expireDate \s+ timestamp \s* , \s* ipAddress \s+ varchar \s* \(24\) \s* , \s* constraint \s+ pk_\w+ \s+ primary \s+ key \s* \(userInfo_id,md5sum\) \s* \) \s* (;)? .*|six, q{Check syntax for sql create table userAttribute}); like($create_table, qr|.* create \s+ table \s+ extremes \s* \( \s+ name \s+ varchar \s* \(32\) \s+ not \s+ null \s* , \s+ colName \s+ varchar \s* \(64\) \s* , \s+ minVal \s+ numeric \s* \(15\) \s* , \s+ maxVal \s+ numeric \s* \(15\) \s* , \s+ constraint \s+ pk_\w+ \s+ primary \s+ key \s* \(name\) \s* \) \s* (;)? .*|six, q{Check syntax for sql create table extremes}); __END__ Parse-Dia-SQL-0.30/t/501-get-associations-implicit.t0000644000175000017500000000126213035770477017745 0ustar affaff# $Id: 501-get-associations-implicit.t,v 1.1 2009/03/30 05:39:58 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 4; use_ok ('Parse::Dia::SQL'); my $diasql = Parse::Dia::SQL->new( file => catfile(qw(t data implicit_role.dia)), db => 'db2' ); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); ok $diasql->convert(); my $association_arrayref = $diasql->get_associations_ref(); my $expected = [ [ 'emp', 'emp_fk_Dept_id', 'dept_id', 'dept', 'id','' ] ]; is_deeply($association_arrayref, $expected) or diag Dumper ($association_arrayref); undef $diasql; __END__ Parse-Dia-SQL-0.30/t/500-get-associations.t0000644000175000017500000000612613035770477016140 0ustar affaff# $Id: 500-get-associations.t,v 1.4 2011/02/15 20:15:54 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 61; use_ok ('Parse::Dia::SQL'); use_ok ('Parse::Dia::SQL::Const'); # Get list of supported databases my $const = Parse::Dia::SQL::Const->new(); isa_ok($const, q{Parse::Dia::SQL::Const}); my @rdbms = $const->get_rdbms(); undef $const; foreach my $db (@rdbms) { my $diasql = Parse::Dia::SQL->new( file => catfile(qw(t data TestERD.dia)), db => $db ); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); is($diasql->convert(), 1, q{Expect convert to return 1}); my $association_arrayref = $diasql->get_associations_ref(); #diag(Dumper($association_arrayref)); my $expected = [ [ 'subImageInfo', 'fk_iisii', 'imageInfo_id', 'imageInfo', 'id', '' ], [ 'imageCategoryList', 'fk_iiicl', 'imageInfo_id', 'imageInfo', 'id', '' ], [ 'imageAttribute', 'fk_iiia', 'imageInfo_id', 'imageInfo', 'id', '' ], [ 'userImageRating', 'fk_uiuir', 'userInfo_id', 'userInfo', 'id', 'on delete cascade' ], [ 'userAttribute', 'fk_uiua', 'userInfo_id', 'userInfo', 'id', 'on delete cascade' ], [ 'userSession', 'fk_uius', 'userInfo_id', 'userInfo', 'id', 'on delete cascade' ], [ 'imageAttribute', 'fk_iaac', 'attributeCategory_id', 'attributeCategory', 'id', '' ], [ 'userAttribute', 'fk_acua', 'attributeCategory_id', 'attributeCategory', 'id', '' ] ]; cmp_ok(scalar(@$association_arrayref), q{==}, scalar(@$expected), qq{Check number of foreign keys (db=$db)}); is_deeply($association_arrayref, $expected, qq{get_associations_ref for db=$db}); undef $diasql; } # ------- many-to-many relations ------- my $diasql_many_to_many = Parse::Dia::SQL->new( file => catfile(qw(t data many_to_many.dia)), db => 'db2' ); isa_ok($diasql_many_to_many, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); # TODO: Add test on return value - call wrapper $diasql_many_to_many->convert(); my $association_many_to_many_arrayref = $diasql_many_to_many->get_associations_ref(); #diag("association_many_to_many_arrayref: ".Dumper($association_many_to_many_arrayref)); my $expected_many_to_many = [ [ 'student_course', 'stdn_crs_fk_StntSn', 'ssn', 'student', 'ssn', 'on delete cascade' ], [ 'student_course', 'lTeT8iBKfXObJYiSrq', 'course_id', 'course', 'course_id', 'on delete cascade' ] ]; is_deeply( $association_many_to_many_arrayref, $expected_many_to_many, 'expected_many_to_many' ); # or diag( q{association_many_to_many_arrayref: } # . Dumper($association_many_to_many_arrayref) # . q{ expected } # . Dumper($expected_many_to_many) ); __END__ Parse-Dia-SQL-0.30/t/650-output-get-create-associations-many-to-many.t0000644000175000017500000000632413035770477023271 0ustar affaff# $Id: 650-output-get-create-associations-many-to-many.t,v 1.2 2011/02/15 20:15:54 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use Test::Exception; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 19; use_ok ('Parse::Dia::SQL'); # ------- many-to-many relations ------- my $diasql_m2m = Parse::Dia::SQL->new( file => catfile(qw(t data many_to_many.dia)), db => 'db2' ); isa_ok($diasql_m2m, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); ok $diasql_m2m->convert(); my $association_m2m_arrayref = $diasql_m2m->get_associations_ref(); #diag("association_m2m_arrayref: ".Dumper($association_m2m_arrayref)); my $expected_m2m = [ [ 'student_course', 'stdn_crs_fk_StntSn', 'ssn', 'student', 'ssn', 'on delete cascade' ], [ 'student_course', 'lTeT8iBKfXObJYiSrq', 'course_id', 'course', 'course_id', 'on delete cascade' ] ]; is_deeply( $association_m2m_arrayref, $expected_m2m ); # or diag( q{association_m2m_arrayref: } # . Dumper($association_m2m_arrayref) # . q{ expected } # . Dumper($expected_m2m) ); my $output_m2m = undef; isa_ok($diasql_m2m, 'Parse::Dia::SQL'); lives_ok(sub { $output_m2m = $diasql_m2m->get_output_instance(); }, q{get_output_instance (db2) should not die}); isa_ok($output_m2m, 'Parse::Dia::SQL::Output') or diag(Dumper($output_m2m)); isa_ok($output_m2m, 'Parse::Dia::SQL::Output::DB2') or diag(Dumper($output_m2m)); can_ok($output_m2m, 'get_associations_create'); # associations = foreign keys + indices my $association_str_m2m = $output_m2m->get_associations_create(); # check 2 foreign keys like($association_str_m2m, qr/.* alter \s+ table \s+ student_course \s+ add \s+ constraint \s+ stdn_crs_fk_StntSn \s+ foreign \s+ key \s* \( \s* ssn \s* \) \s+ references \s+ student \s* \( \s* ssn \s* \) \s* on \s+ delete \s+ cascade .*/six); like($association_str_m2m, qr/.* alter \s+ table \s+ student_course \s+ add \s+ constraint \s+ lTeT8iBKfXObJYiSrq \s+ foreign \s+ key \s* \( \s* course_id \s* \) \s* references \s+ course \s+ \s* \( \s* course_id \) \s* on \s+ delete \s+ cascade .*/six); # ------ implicit role ------ my $diasql_ir = Parse::Dia::SQL->new( file => catfile(qw(t data implicit_role.dia)), db => 'db2' ); isa_ok($diasql_ir, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); ok $diasql_ir->convert(); my $output_ir = undef; isa_ok($diasql_ir, 'Parse::Dia::SQL'); lives_ok(sub { $output_ir = $diasql_ir->get_output_instance(); }, q{get_output_instance (db2) should not die}); isa_ok($output_ir, 'Parse::Dia::SQL::Output') or diag(Dumper($output_ir)); isa_ok($output_ir, 'Parse::Dia::SQL::Output::DB2') or diag(Dumper($output_ir)); can_ok($output_ir, 'get_associations_create'); # associations = foreign keys + indices my $association_str_ir = $output_ir->get_associations_create(); #diag $association_str_ir; like($association_str_ir, qr/.* alter \s+ table \s+ emp \s+ add \s+ constraint \s+ emp_fk_Dept_id \s+ foreign \s+ key \s+ \( \s* dept_id \s* \) \s+ references \s+ dept \s+ \( \s* id \s* \) \s+ ; .*/six); __END__ Parse-Dia-SQL-0.30/t/641-output-get-drop-view-sql.t0000644000175000017500000000245313035770477017515 0ustar affaff# $Id: 641-output-get-drop-view-sql.t,v 1.1 2009/02/23 07:36:17 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use Test::Exception; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 13; use lib q{lib}; use_ok ('Parse::Dia::SQL'); use_ok ('Parse::Dia::SQL::Output'); my $diasql = Parse::Dia::SQL->new( file => catfile(qw(t data TestERD.dia)), db => 'db2' ); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); is($diasql->convert(), 1, q{Expect convert() to return 1}); my $classes = $diasql->get_classes_ref(); ok(defined($classes) && ref($classes) eq q{ARRAY} && scalar(@$classes), q{Non-empty array ref}); # 2. output my $output = undef; isa_ok($diasql, 'Parse::Dia::SQL'); lives_ok(sub { $output = $diasql->get_output_instance(); }, q{get_output_instance (db2) should not die}); isa_ok($output, 'Parse::Dia::SQL::Output') or diag(Dumper($output)); isa_ok($output, 'Parse::Dia::SQL::Output::DB2') or diag(Dumper($output)); can_ok($output, 'get_schema_drop'); my $drop_table = $output->get_view_drop(); #diag($drop_table); like($drop_table, qr/.*drop \s+ view \s+ ratings_view \s* ;/six); like($drop_table, qr/.*drop \s+ view \s+ whorated_view \s* ;/six); like($drop_table, qr/.*drop \s+ view \s+ users_view \s* ;/six); __END__ Parse-Dia-SQL-0.30/t/201-parse-classes.t0000644000175000017500000000307513035770477015427 0ustar affaff# $Id: 201-parse-classes.t,v 1.2 2009/02/26 13:49:07 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 37; use_ok ('Parse::Dia::SQL'); my $diasql = Parse::Dia::SQL->new( file => catfile(qw(t data TestERD.dia)), db => 'db2' ); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); # parse and convert is($diasql->convert(), 1, q{Expect convert() to return 1}); my $docs = $diasql->_get_docs(); foreach my $doc (@{$docs}){ isa_ok($doc, q{XML::DOM::Document}); } # check that nodelists returns array of XML::DOM::NodeList my $nodelists = $diasql->_get_nodelists(); foreach my $nodelist (@{$nodelists}){ isa_ok($nodelist, q{XML::DOM::NodeList}); } my $classes = $diasql->get_classes_ref(); #diag(Dumper($classes)); # Expect an array ref with 14 elements isa_ok($classes, 'ARRAY'); cmp_ok(scalar(@$classes), q{==}, 14, q{Expect 14 classes}); # List of classes in the dia file my %classname = map { $_ => 1 } qw ( imageInfo subImageInfo imageCategoryList categoryNames imageAttribute userInfo userAttribute userImageRating attributeCategory userSession extremes ratings_view whorated_view users_view ); foreach my $class(@$classes) { isa_ok($class, 'HASH'); if (exists($classname{$class->{name}})) { delete $classname{$class->{name}}; ok(q{Found class }. $class->{name}) } else { fail (q{Unknown class: }. $class->{name}); } } # Expect no classes left now cmp_ok(scalar(keys %classname), q{==}, 0, q{Expect 0 classes}); __END__ Parse-Dia-SQL-0.30/t/621-output-get-schema-create-mysql-innodb-backticks.t0000644000175000017500000001352513035770477024053 0ustar affaff# $Id: 620-output-get-schema-create.t,v 1.2 2009/04/01 08:10:43 aff Exp $ use warnings; use strict; use Data::Dumper; #use Test::More; use Test::More qw/no_plan/; use Test::Exception; use File::Spec::Functions; use lib catdir qw ( blib lib ); #plan tests => 23; use lib q{lib}; use_ok ('Parse::Dia::SQL'); use_ok ('Parse::Dia::SQL::Output'); use_ok ('Parse::Dia::SQL::Output::DB2'); # 1. parse input my $db = 'mysql-innodb'; my $diasql = Parse::Dia::SQL->new( file => catfile(qw(t data TestERD.dia)), db => $db, backticks => 1 ); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); is($diasql->convert(), 1, q{Expect convert to return 1}); # 2. get output instance my $subclass = undef; lives_ok(sub { $subclass = $diasql->get_output_instance(); }, q{get_output_instance (db2) should not die}); isa_ok($subclass, 'Parse::Dia::SQL::Output'); isa_ok($subclass, 'Parse::Dia::SQL::Output::MySQL::InnoDB'); can_ok($subclass, 'get_schema_create'); # 3. create sql my $create_table = $subclass->get_schema_create(); # 4. Check for backticks presence like($create_table, qr|.* create \s+ table \s+ `imageInfo` \s* \( \s* `id` \s+ numeric \s* \(18\) \s+ not \s+ null \s* , \s* `insertionDate` \s+ timestamp \s+ not \s+ null \s* , \s* `md5sum` \s+ char \s* \(32\) \s+ not \s+ null \s* , \s* `binaryType` \s+ varchar \s* \(16\) \s+ default \s+ 'jpg' \s+ null \s* , \s* `name` \s+ varchar \s* \(64\) \s+ not \s+ null \s* , \s* `locationList` \s+ varchar \s* \(128\) \s+ default \s+ '//imgserver.org' \s* , \s* `description` \s+ varchar \s* \(128\) \s+ null \s* , \s* constraint \s+ pk_\w+ \s+ primary \s+ key \s* \(id\) \s* \) .*|six, q{Check syntax for sql create table imageInfo}); __END__ like($create_table, qr|.* create \s+ table \s+ subImageInfo \s* \( \s* imageInfo_id \s+ numeric \s* \(18\) \s+ not \s+ null \s* , \s* pixSize \s+ integer \s+ not \s+ null \s* , \s* constraint \s+ pk_\w+ \s+ primary \s+ key \s* \(imageInfo_id \s* , \s* pixSize\) \s* \) \s* (;)? .*|six, q{Check syntax for sql create table SubimageInfo}); like($create_table, qr|.* create \s+ table \s+ imageCategoryList \s* \( \s* imageInfo_id \s+ numeric \s* \(18\) \s+ not \s+ null \s* , \s* name \s+ varchar \s* \(32\) \s+ not \s+ null \s* , \s* constraint \s+ \w+ \s+ primary \s+ key \s* \(imageInfo_id \s* , \s* name\) \s* \) \s* (;)? .*|six, q{Check syntax for sql create table imageCategoryList}); like($create_table, qr|.* create \s+ table \s+ categoryNames \s* \( \s* name \s+ varchar \s* \(32\) \s+ not \s+ null \s* , \s* constraint \s+ pk_\w+ \s+ primary \s+ key \s* \(name\) \s* \) \s* (;)? .*|six, q{Check syntax for sql create table categoryNames}); like($create_table, qr|.* create \s+ table \s+ imageAttribute \s* \( \s* imageInfo_id \s+ numeric \s* \(18\) \s+ not \s+ null \s* , \s* attributeCategory_id \s+ numeric \s* \(18\) \s+ not \s+ null \s* , \s* numValue \s+ numeric \s* \(8\) \s* , \s* category \s+ numeric \s* \(4\) \s* , \s* constraint \s+ pk_\w+ \s+ primary \s+ key \s* \(imageInfo_id,attributeCategory_id\) \s* \) \s* (;)? .*|six, q{Check syntax for sql create table imageAttribute}); like($create_table, qr|.* create \s+ table \s+ userInfo \s* \( \s* id \s+ numeric \s* \(18\) \s+ not \s+ null \s* , \s* insertionDate \s+ timestamp \s* , \s* md5sum \s+ char \s* \(32\) \s* , \s* birthDate \s+ timestamp \s* , \s* gender \s+ char \s* \(1\) \s* , \s* name \s+ varchar \s* \(32\) \s* , \s* email \s+ varchar \s* \(96\) \s* , \s* currentCategory \s+ varchar \s* \(32\) \s* , \s* lastDebitDate \s+ timestamp \s* , \s* acctBalance \s+ numeric \s* \(10,2\) \s* , \s* active \s+ integer \s* , \s* constraint \s+ pk_\w+ \s+ primary \s+ key \s* \(id\) \s* \) \s* (;)? .*|six, q{Check syntax for sql create table userInfo}); like($create_table, qr|.* create \s+ table \s+ userAttribute \s* \( \s* userInfo_id \s+ numeric \s* \(18\) \s+ not \s+ null \s* , \s* attributeCategory_id \s+ numeric \s* \(18\) \s+ not \s+ null \s* , \s* numValue \s+ numeric \s* \(5,4\) \s* , \s* constraint \s+ pk_\w+ \s+ primary \s+ key \s* \(userInfo_id,attributeCategory_id\) \s* \) \s* (;)? .*|six, q{Check syntax for sql create table userAttribute}); like($create_table, qr|.* create \s+ table \s+ userImageRating \s* \( \s* userInfo_id \s+ numeric \s* \(18\) \s+ not \s+ null \s* , \s* imageInfo_id \s+ numeric \s* \(15\) \s+ not \s+ null \s* , \s* rating \s+ integer \s* , \s* constraint \s+ pk_\w+ \s+ primary \s+ key \s* \(userInfo_id,imageInfo_id\) \s* \) \s* (;)? .*|six, q{Check syntax for sql create table userAttribute}); like($create_table, qr|.* create \s+ table \s+ attributeCategory \s* \( \s* id \s+ numeric \s* \(18\) \s+ not \s+ null \s* , \s* attributeDesc \s+ varchar \s* \(128\) \s* , \s* constraint \s+ pk_\w+ \s+ primary \s+ key \s* \(id\) \s* \) \s* (;)? .*|six, q{Check syntax for sql create table userAttribute}); like($create_table, qr|.* create \s+ table \s+ userSession \s* \( \s* userInfo_id \s+ numeric \s* \(18\) \s+ not \s+ null \s* , \s* md5sum \s+ char \s* \(32\) \s+ not \s+ null \s* , \s* insertionDate \s+ timestamp \s* , \s* expireDate \s+ timestamp \s* , \s* ipAddress \s+ varchar \s* \(24\) \s* , \s* constraint \s+ pk_\w+ \s+ primary \s+ key \s* \(userInfo_id,md5sum\) \s* \) \s* (;)? .*|six, q{Check syntax for sql create table userAttribute}); like($create_table, qr|.* create \s+ table \s+ extremes \s* \( \s+ name \s+ varchar \s* \(32\) \s+ not \s+ null \s* , \s+ colName \s+ varchar \s* \(64\) \s* , \s+ minVal \s+ numeric \s* \(15\) \s* , \s+ maxVal \s+ numeric \s* \(15\) \s* , \s+ constraint \s+ pk_\w+ \s+ primary \s+ key \s* \(name\) \s* \) \s* (;)? .*|six, q{Check syntax for sql create table extremes}); __END__ Parse-Dia-SQL-0.30/t/685-output-postgres-get-sql.t0000644000175000017500000000151613035770477017456 0ustar affaff# $Id: 685-output-postgres-get-sql.t,v 1.3 2009/02/28 06:54:57 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use Test::Exception; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 7; diag 'Postgres support is experimental'; use lib q{lib}; use_ok ('Parse::Dia::SQL'); use_ok ('Parse::Dia::SQL::Output'); use_ok ('Parse::Dia::SQL::Output::Postgres'); my $diasql = Parse::Dia::SQL->new(file => catfile(qw(t data TestERD.dia)), db => 'postgres'); isa_ok($diasql, q{Parse::Dia::SQL}, q{Expect a Parse::Dia::SQL object}); is($diasql->convert(), 1, q{Expect convert() == 1}); can_ok($diasql, q{get_output_instance}); my $subclass = $diasql->get_output_instance(); isa_ok( $subclass, q{Parse::Dia::SQL::Output::Postgres}, q{Expect a Parse::Dia::SQL::Output::Postgres object} ); __END__ Parse-Dia-SQL-0.30/t/710-const-load.t0000644000175000017500000000040613035770477014725 0ustar affaff# $Id: 710-const-load.t,v 1.1 2009/02/23 07:36:17 aff Exp $ use warnings; use strict; use Data::Dumper; use Test::More; use File::Spec::Functions; use lib catdir qw ( blib lib ); plan tests => 1; use lib q{lib}; use_ok ('Parse::Dia::SQL::Const'); __END__ Parse-Dia-SQL-0.30/lib/0000755000175000017500000000000013105115727012460 5ustar affaffParse-Dia-SQL-0.30/lib/Parse/0000755000175000017500000000000013105115727013532 5ustar affaffParse-Dia-SQL-0.30/lib/Parse/Dia/0000755000175000017500000000000013105115727014227 5ustar affaffParse-Dia-SQL-0.30/lib/Parse/Dia/SQL/0000755000175000017500000000000013105115727014666 5ustar affaffParse-Dia-SQL-0.30/lib/Parse/Dia/SQL/Logger.pm0000644000175000017500000000731313035770476016461 0ustar affaffpackage Parse::Dia::SQL::Logger; # $Id: Logger.pm,v 1.9 2011/02/16 10:23:11 aff Exp $ =pod =head1 NAME Parse::Dia::SQL::Logger - Wrapper for Log::Log4perl =head1 SYNOPSIS use Parse::Dia::SQL::Logger; my $logger = Parse::Dia::SQL::Logger::->new(loglevel => 'INFO'); my $log = $logger->get_logger(__PACKAGE__); $log->error('error'); $log->info('info'); =head1 DESCRIPTION This module is a wrapper around Log::Log4perl. =cut use warnings; use strict; use Log::Log4perl; use constant APPENDER_THRESHOLDS_ADJUST_LOGOFF => 7; use constant APPENDER_THRESHOLDS_ADJUST_LOGON => -7; =head2 new The constructor. =cut sub new { my ( $class, %param ) = @_; my $self = { log => undef, loglevel => $param{loglevel} || undef, }; bless( $self, $class ); $self->_init_log(); return $self; } # Initialize the logger. The commented lines are deliberately left to # serve as exmples. sub _init_log { my $self = shift; # Init logging my $conf = undef; if ($self->{loglevel}) { $conf = qq( # Loglevel set by user log4perl.category.Parse::Dia::SQL = $self->{loglevel}, screen-main log4perl.appender.screen-main = Log::Log4perl::Appender::Screen log4perl.appender.screen-main.stderr = 1 log4perl.appender.screen-main.layout = PatternLayout log4perl.appender.screen-main.layout.ConversionPattern=[%p] %m%n ); } else { # Default logging $conf = q( # Main logger for Parse::Dia::SQL log4perl.category.Parse::Dia::SQL = INFO, screen-main log4perl.appender.screen-main = Log::Log4perl::Appender::Screen log4perl.appender.screen-main.stderr = 1 log4perl.appender.screen-main.layout = PatternLayout log4perl.appender.screen-main.layout.ConversionPattern=[%p] %m%n # Separate logger for Output::* log4perl.category.Parse::Dia::SQL::Output = INFO, screen-output log4perl.appender.screen-output = Log::Log4perl::Appender::Screen log4perl.appender.screen-output.stderr = 1 log4perl.appender.screen-output.layout = PatternLayout log4perl.appender.screen-output.layout.ConversionPattern=[%p] %m%n log4perl.additivity.Parse::Dia::SQL::Output = 0 # Separate logger for Utils.pm log4perl.category.Parse::Dia::SQL::Utils = INFO, screen-utils log4perl.appender.screen-utils = Log::Log4perl::Appender::Screen log4perl.appender.screen-utils.stderr = 1 log4perl.appender.screen-utils.layout = PatternLayout log4perl.appender.screen-utils.layout.ConversionPattern=[%p] %m%n log4perl.additivity.Parse::Dia::SQL::Utils = 0 ); } Log::Log4perl::init( \$conf ); # Adjust call stack for caller class, see man Log::Log4perl $Log::Log4perl::caller_depth = 1; return 1; } =head2 get_logger Return logger singleton object. =cut sub get_logger { my ($self, $name) = @_; #return $self->{logger}; return Log::Log4perl::->get_logger($name); } =head2 log_off Decrease log level on all appenders. 1 =cut sub log_off { my $self = shift; # Make sure it works also in case this is # called as function before object is blessed. _init_log() if ( !Log::Log4perl->initialized() ); Log::Log4perl->appender_thresholds_adjust(APPENDER_THRESHOLDS_ADJUST_LOGOFF); return 1; } =head2 log_on Increase log level on all appenders. =cut sub log_on { my $self = shift; # Make sure it works also in case this is # called as function before object is blessed. _init_log() if ( !Log::Log4perl->initialized() ); Log::Log4perl->appender_thresholds_adjust(APPENDER_THRESHOLDS_ADJUST_LOGON); return 1; } 1; __END__ # End of Parse::Dia::SQL::Logger Parse-Dia-SQL-0.30/lib/Parse/Dia/SQL/Output/0000755000175000017500000000000013105115727016166 5ustar affaffParse-Dia-SQL-0.30/lib/Parse/Dia/SQL/Output/Sybase.pm0000644000175000017500000000230213035770477017762 0ustar affaffpackage Parse::Dia::SQL::Output::Sybase; # $Id: Sybase.pm,v 1.2 2009/03/02 13:41:39 aff Exp $ =pod =head1 NAME Parse::Dia::SQL::Output::Sybase - Create SQL for Sybase. =head1 SEE ALSO Parse::Dia::SQL::Output =cut use warnings; use strict; use Data::Dumper; use File::Spec::Functions qw(catfile); use lib q{lib}; use base q{Parse::Dia::SQL::Output}; # extends require Parse::Dia::SQL::Logger; require Parse::Dia::SQL::Const; =head2 new The constructor. Arguments: =cut sub new { my ( $class, %param ) = @_; my $self = {}; # Set defaults for sybase $param{db} = q{sybase}; $param{object_name_max_length} = $param{object_name_max_length} || 30; $param{end_of_statement} = $param{end_of_statement} || "\ngo"; $self = $class->SUPER::new(%param); bless( $self, $class ); $self->{log}->warn(qq{Using object_name_max_length }. $param{object_name_max_length}); return $self; } =head2 _get_drop_index_sql create drop index for index on table with given name. =cut sub _get_drop_index_sql { my ( $self, $tablename, $indexname ) = @_; return qq{drop index $tablename.$indexname} . $self->{end_of_statement} . $self->{newline}; } 1; __END__ Parse-Dia-SQL-0.30/lib/Parse/Dia/SQL/Output/Oracle.pm0000644000175000017500000000203213035770477017741 0ustar affaffpackage Parse::Dia::SQL::Output::Oracle; # $Id: Oracle.pm,v 1.2 2009/03/02 13:41:39 aff Exp $ =pod =head1 NAME Parse::Dia::SQL::Output::Oracle - Create SQL for Oracle. =head1 SEE ALSO Parse::Dia::SQL::Output =cut use warnings; use strict; use Data::Dumper; use File::Spec::Functions qw(catfile); use lib q{lib}; use base q{Parse::Dia::SQL::Output}; # extends require Parse::Dia::SQL::Logger; require Parse::Dia::SQL::Const; =head2 new The constructor. Arguments: =cut sub new { my ( $class, %param ) = @_; my $self = {}; # Set defaults for oracle $param{db} = q{oracle}; $param{object_name_max_length} = $param{object_name_max_length} || 30; $self = $class->SUPER::new(%param); bless( $self, $class ); return $self; } =head2 _get_drop_index_sql Create drop index sql for given index. Discard tablename. =cut sub _get_drop_index_sql { my ( $self, $tablename, $indexname ) = @_; return qq{drop index $indexname cascade constraints} . $self->{end_of_statement} . $self->{newline}; } 1; __END__ Parse-Dia-SQL-0.30/lib/Parse/Dia/SQL/Output/SQLite3.pm0000644000175000017500000003356413036704643017767 0ustar affaffpackage Parse::Dia::SQL::Output::SQLite3; # $Id: SQLite3.pm,v 1.5 2009/05/14 09:42:47 aff Exp $ =pod =head1 NAME Parse::Dia::SQL::Output::SQLite3 - Create SQL for SQLite version 3. =head1 SYNOPSIS use Parse::Dia::SQL; my $dia = Parse::Dia::SQL->new(file => 'foo.dia', db => 'sqlite3'); print $dia->get_sql(); =head1 DESCRIPTION This sub-class creates SQL for the SQLite database version 3. =cut use warnings; use strict; use Data::Dumper; use File::Spec::Functions qw(catfile); use lib q{lib}; use base q{Parse::Dia::SQL::Output}; # extends require Parse::Dia::SQL::Logger; require Parse::Dia::SQL::Const; =head2 new The constructor. Object names in SQLite have no inherent limit. 60 has been arbitrarily chosen. =cut sub new { my ( $class, %param ) = @_; my $self = {}; # Set defaults for sqlite $param{db} = q{sqlite3}; $param{object_name_max_length} = $param{object_name_max_length} || 60; $self = $class->SUPER::new( %param ); bless( $self, $class ); return $self; } =head2 _get_create_table_sql Generate create table statement for a single table using SQLite syntax: Includes class comments before the table definition. Includes autoupdate triggers based on the class comment. =head3 autoupdate triggers If the class comment includes a line like: /> Then an 'after update' trigger is generated for this table which executes the statement I for the updated row. Examples of use include tracking record modification dates (C<>) or deriving a value from another field (C<>) =cut sub _get_create_table_sql { my ( $self, $table ) = @_; my $sqlstr = ''; my $temp; my $comment; my $tablename; my $trigger = ''; my $update; my $primary_keys = ''; # include the comments before the table creation $comment = $table->{comment}; if ( !defined( $comment ) ) { $comment = ''; } $tablename = $table->{name}; $sqlstr .= $self->{newline}; if ( $comment ne "" ) { $temp = "-- $comment"; $temp =~ s/\n/\n-- /g; $temp =~ s/^-- $//mgi; if ( $temp ne "" ) { if ( $temp !~ /\n$/m ) { $temp .= $self->{newline}; } $sqlstr .= $temp; } } # Call the base class to generate the main create table statements $sqlstr .= $self->SUPER::_get_create_table_sql( $table ); # Generate update triggers if required if ( $comment =~ //mi ) { $update = $3; # what we will set it to $trigger = $2; # the trigger suffix to use (optional) $trigger = $tablename . "_autoupdate" . $trigger; # Check that the column exists foreach $temp ( @{ $table->{attList} } ) { # build the two primary key elements if ( $$temp[3] == 2 ) { if ( $primary_keys ) { $primary_keys .= " and "; } $primary_keys .= $$temp[0] . "=OLD." . $$temp[0]; } } $sqlstr .= "drop trigger if exists $trigger" . $self->{end_of_statement} . $self->{newline}; $sqlstr .= "create trigger $trigger after update on $tablename begin update $tablename set $update where $primary_keys;end" . $self->{end_of_statement} . $self->{newline}; $sqlstr .= $self->{newline}; } return $sqlstr; } =head2 get_schema_drop Generate drop table statements for all tables using SQLite syntax: drop table {foo} if exists =cut sub get_schema_drop { my $self = shift; my $sqlstr = ''; return unless $self->_check_classes(); CLASS: foreach my $object ( @{ $self->{classes} } ) { next CLASS if ( $object->{type} ne q{table} ); # Sanity checks on internal state if (!defined( $object ) || ref( $object ) ne q{HASH} || !exists( $object->{name} ) ) { $self->{log} ->error( q{Error in table input - cannot create drop table sql!} ); next; } $sqlstr .= qq{drop table if exists } . $object->{name} . $self->{end_of_statement} . $self->{newline}; } return $sqlstr; } =head2 get_view_drop Generate drop view statements for all tables using SQLite syntax: drop view {foo} if exists =cut # Create drop view for all views sub get_view_drop { my $self = shift; my $sqlstr = ''; return unless $self->_check_classes(); CLASS: foreach my $object ( @{ $self->{classes} } ) { next CLASS if ( $object->{type} ne q{view} ); # Sanity checks on internal state if (!defined( $object ) || ref( $object ) ne q{HASH} || !exists( $object->{name} ) ) { $self->{log} ->error( q{Error in table input - cannot create drop table sql!} ); next; } $sqlstr .= qq{drop view if exists } . $object->{name} . $self->{end_of_statement} . $self->{newline}; } return $sqlstr; } =head2 _get_fk_drop Drop foreign key enforcement triggers using SQLite syntax: drop trigger {foo} if exists The automatically generated foreign key enforcement triggers are: See L<"_get_create_association_sql"> for more details. =over =item I_bi_tr =item I_bu_tr =item I_buparent_tr =item I_bdparent_tr =back =cut # Drop all foreign keys sub _get_fk_drop { my $self = shift; my $sqlstr = ''; my $temp; return unless $self->_check_associations(); # drop fk foreach my $association ( @{ $self->{associations} } ) { my ( $table_name, $constraint_name, undef, undef, undef, undef ) = @{$association}; $temp = $constraint_name . "_bi_tr"; $sqlstr .= qq{drop trigger if exists $temp} . $self->{end_of_statement} . $self->{newline}; $temp = $constraint_name . "_bu_tr"; $sqlstr .= qq{drop trigger if exists $temp} . $self->{end_of_statement} . $self->{newline}; $temp = $constraint_name . "_buparent_tr"; $sqlstr .= qq{drop trigger if exists $temp} . $self->{end_of_statement} . $self->{newline}; $temp = $constraint_name . "_bdparent_tr"; $sqlstr .= qq{drop trigger if exists $temp} . $self->{end_of_statement} . $self->{newline}; $sqlstr .= $self->{newline}; } return $sqlstr; } =head2 _get_drop_index_sql drop index statement using SQLite syntax: drop index {foo} if exists =cut sub _get_drop_index_sql { my ( $self, $tablename, $indexname ) = @_; return qq{drop index if exists $indexname} . $self->{end_of_statement} . $self->{newline}; } =head2 get_permissions_create SQLite doesn't support permissions, so suppress this output. =cut sub get_permissions_create { return ''; } =head2 get_permissions_drop SQLite doesn't support permissions, so suppress this output. =cut sub get_permissions_drop { return ''; } =head2 _get_create_association_sql Create the foreign key enforcement triggers using SQLite syntax: create trigger {fkname}[_bi_tr|_bu_tr|_bdparent_tr|_buparent_tr] Because SQLite doesn't natively enforce foreign key constraints (see L), we use triggers to emulate this behaviour. The trigger names are the default contraint name (something like I_fk_I) with suffixes described below. =over =item I<{constraint_name}> is the name of the association, either specified or generated. =item I<{child_table}> is the name of the dependent or child table. =item I<{child_fkcolumn}> is the field in the dependent table that hold the foreign key. =item I<{parent_table}> is the name of the parent table. =item I<{parent_key}> is the key field of the parent table. =back =head3 Before insert - Dependent Table I_bi_tr Before insert on the child table require that the parent key exists. create trigger {constraint_name}_bi_tr before insert on {child_table} for each row begin select raise(abort, 'insert on table {child_table} violates foreign key constraint {constraint_name}') where new.{child_fkcolumn} is not null and (select {parent_key} from {parent_table} where {parent_key}=new.{child_fkcolumn}) is null; end; =head3 Before update - Dependent Table I_bu_tr Before update on the child table require that the parent key exists. create trigger {constraint_name}_bu_tr before update on {table_name} for each row begin select raise(abort, 'update on table {child_table} violates foreign key constraint {constraint_name}') where new.{child_fkcolumn} is not null and (select {parent_key} from {parent_table} where {parent_key}=new.{child_fkcolumn}) is null; end; =head3 Before update - Parent Table I_buparent_tr Before update on the primary key of the parent table ensure that there are no dependent child records. Note that cascading updates B. create trigger {constraint_name}_buparent_tr before update on {parent_table} for each row when new.{parent_key} <> old.{parent_key} begin select raise(abort, 'update on table {parent_table} violates foreign key constraint {constraint_name} on {child_table}') where (select {child_fkcolumn} from {child_table} where {child_fkcolumn}=old.{parent_key}) is not null; end; =head3 Before delete - Parent Table I_bdparent_tr The default behaviour can be modified through the contraint (in the multiplicity field) of the association. =head4 Default (On Delete Restrict) Before delete on the parent table ensure that there are no dependent child records. create trigger {constraint_name}_bdparent_tr before delete on {parent_table} for each row begin select raise(abort, 'delete on table {parent_table} violates foreign key constraint {constraint_name} on {child_table}') where (select {child_fkcolumn} from {child_table} where {child_fkcolumn}=old.{parent_key}) is not null; end; =head4 On Delete Cascade Before delete on the parent table delete all dependent child records. create trigger {constraint_name}_bdparent_tr before delete on {parent_table} for each row begin delete from {child_table} where {child_table}.{child_fkcolumn}=old.{parent_key}; end; =head4 On Delete Set Null Before delete on the parent table set the foreign key field(s) in all dependent child records to NULL. create trigger {constraint_name}_bdparent_tr before delete on {parent_table} for each row begin update {child_table} set {child_table}.{child_fkcolumn}=null where {child_table}.{child_fkcolumn}=old.{parent_key}; end; =cut # Create sql for given association. sub _get_create_association_sql { my ( $self, $association ) = @_; my $sqlstr = ''; my $temp; # Sanity checks on input if ( ref( $association ) ne 'ARRAY' ) { $self->{log} ->error( q{Error in association input - cannot create association sql!} ); return; } # FK constraints are implemented as triggers in SQLite my ( $table_name, $constraint_name, $key_column, $ref_table, $ref_column, $constraint_action ) = @{$association}; # Shorten constraint name, if necessary (DB2 only) $constraint_name = $self->_create_constraint_name( $constraint_name ); $temp = $constraint_name . "_bi_tr"; $sqlstr .= qq{create trigger $temp before insert on $table_name for each row begin select raise(abort, 'insert on table $table_name violates foreign key constraint $constraint_name') where new.$key_column is not null and (select $ref_column from $ref_table where $ref_column=new.$key_column) is null;end} . $self->{end_of_statement} . $self->{newline}; $temp = $constraint_name . "_bu_tr"; $sqlstr .= qq{create trigger $temp before update on $table_name for each row begin select raise(abort, 'update on table $table_name violates foreign key constraint $constraint_name') where new.$key_column is not null and (select $ref_column from $ref_table where $ref_column=new.$key_column) is null;end} . $self->{end_of_statement} . $self->{newline}; # note that the before delete triggers are on the parent ($ref_table) $temp = $constraint_name . "_bdparent_tr"; if ( $constraint_action =~ /on delete cascade/i ) { $sqlstr .= qq{create trigger $temp before delete on $ref_table for each row begin delete from $table_name where $table_name.$key_column=old.$ref_column;end} . $self->{end_of_statement} . $self->{newline}; } elsif ( $constraint_action =~ /on delete set null/i ) { $sqlstr .= qq{create trigger $temp before delete on $ref_table for each row begin update $table_name set $key_column=null where $table_name.$key_column=old.$ref_column;end} . $self->{end_of_statement} . $self->{newline}; } else # default on delete restrict { $sqlstr .= qq{create trigger $temp before delete on $ref_table for each row begin select raise(abort, 'delete on table $ref_table violates foreign key constraint $constraint_name on $table_name') where (select $key_column from $table_name where $key_column=old.$ref_column) is not null;end} . $self->{end_of_statement} . $self->{newline}; } # Cascade updates doesn't work, so we always restrict $temp = $constraint_name . "_buparent_tr"; $sqlstr .= qq{create trigger $temp before update on $ref_table for each row when new.$ref_column <> old.$ref_column begin select raise(abort, 'update on table $ref_table violates foreign key constraint $constraint_name on $table_name') where (select $key_column from $table_name where $key_column=old.$ref_column) is not null;end} . $self->{end_of_statement} . $self->{newline}; $sqlstr .= $self->{newline}; return $sqlstr; } 1; =head1 TODO Things that might get added in future versions: =head3 Mandatory constraints The current foreign key triggers allow NULL in the child table. This might use a keyword in the multiplicity field (perhaps 'required') or could check the 'not null' state of the child fkcolumn. =head3 Views Views haven't been tested. They might already work, but who knows... =head3 Other stuff Bugs etc =cut __END__ Parse-Dia-SQL-0.30/lib/Parse/Dia/SQL/Output/HTML.pm0000644000175000017500000007110513035770477017307 0ustar affaffpackage Parse::Dia::SQL::Output::HTML; # $Id: $ =pod =head1 NAME Parse::Dia::SQL::Output::HTML - Create HTML documentation. =head1 SYNOPSIS use Parse::Dia::SQL; my $dia = Parse::Dia::SQL->new( file => 'foo.dia', db => 'html' [ , htmlformat => {formatfile} ] ); print $dia->get_sql(); =head1 DESCRIPTION This sub-class creates HTML formatted database documentation. HTML formatting is controlled by templates selected with the optional I parameter which supplies a format file. See L for more. The generated HTML is intended to be useful rather than beautiful. This sub-class follows the same structure as the rdbms output sub-classes with the intent of maintaining consistency, even though this give less than optimum efficiency. =cut use warnings; use strict; use Text::Table; use Data::Dumper; use File::Spec::Functions qw(catfile); use lib q{lib}; use base q{Parse::Dia::SQL::Output}; # extends use Config; require Parse::Dia::SQL::Logger; require Parse::Dia::SQL::Const; =head2 new The constructor. Object names in HTML have no inherent limit. 64 has been arbitrarily chosen. =cut sub new { my ( $class, %param ) = @_; my $self = {}; # Set defaults for sqlite $param{db} = q{html}; $param{object_name_max_length} = $param{object_name_max_length} || 64; $param{htmlformat} = $param{htmlformat} || ''; $self = $class->SUPER::new( %param ); bless( $self, $class ); $self->{dbdata} = {}; # table data, keyed by tablename $self->{htmltemplate} = {}; # html template elements $self->set_html_template($param{htmlformat}); # find the template elements based on the selected format return $self; } =head2 get_sql Return all sql documentation. First build the data structures: schema create view create permissions create inserts associations create (indices first, then foreign keys) Then generate the output: html start html comments body start generate main html body end html end =cut sub get_sql { my $self = shift; ## no critic (NoWarnings) no warnings q{uninitialized}; $self->get_schema_create(); $self->get_view_create(); $self->get_permissions_create(); $self->get_inserts(); $self->get_associations_create(); my $html = '' . $self->_get_preamble() . $self->_get_comment() . $self->get_smallpackage_pre_sql() . $self->generate_html() . $self->get_smallpackage_post_sql() . $self->_get_postscript() ; return $html; } =head2 _get_preamble HTML Header =cut sub _get_preamble { my $self = shift; my $files_word = (scalar(@{ $self->{files} }) > 1) ? q{Input files} : q{Input file}; my $data = $self->{htmltemplate}{htmlpreamble}; # File name my $value = $self->{files}[0]; $data =~ s/{filename}/$value/mgi; # todo: meta tags? return $data } =head2 _get_comment Comment for HTML Header =cut sub _get_comment { my $self = shift; my $files_word = (scalar(@{ $self->{files} }) > 1) ? q{Input files} : q{Input file}; $self->{gentime} = scalar localtime(); my @arr = ( [ q{Parse::SQL::Dia}, qq{version $Parse::Dia::SQL::VERSION} ], [ q{Documentation}, q{http://search.cpan.org/dist/Parse-Dia-SQL/} ], [ q{Environment}, qq{Perl $], $^X} ], [ q{Architecture}, qq{$Config{archname}} ], [ q{Target Database}, $self->{db} ], [ $files_word, join(q{, }, @{ $self->{files} }) ], [ q{Generated at}, $self->{gentime} ], ); $self->{filename} = join(q{, }, @{ $self->{files} }); my $value = ''; my $data = $self->{htmltemplate}{htmlcomment}; my $tb = Text::Table->new(); $tb->load(@arr); $value = scalar $tb->table(); $data =~ s/{htmlcomment}/$value/mgi; return $data; } =head2 get_smallpackage_pre_sql HTML Body start =cut sub get_smallpackage_pre_sql { my $self = shift; my $data; $data = $self->{htmltemplate}{htmlstartbody}; return $data } =head2 get_smallpackage_post_sql HTML Body close =cut sub get_smallpackage_post_sql { my $self = shift; my $data; $data = $self->{htmltemplate}{htmlendbody}; $data =~ s/{gentime}/$self->{gentime}/mgi; return $data } =head2 _get_postscript HTML close =cut sub _get_postscript { my $self = shift; my $data = ''; $data = $self->{htmltemplate}{htmlend}; return $data } =head2 _get_create_table_sql Extracts the documentation details for a single table. =cut sub _get_create_table_sql { my ( $self, $table ) = @_; #my $sqlstr = ''; my $temp; my $comment; my $tablename; my $update; my $primary_keys = ''; my $order = 0; my $tabletemplate = ''; my $tablerowemplate = ''; my $tabledata = ''; my $tablerowdata = ''; # Table name $tablename = $table->{name}; $self->{'dbdata'}{$tablename} = {}; # Comments 1 - strip the autoupdate bits $comment = $table->{comment}; if ( !defined( $comment ) ) { $comment = ''; } if ( $comment ne '' ) { $comment =~ s/\n//g; $comment =~ s///mgi; } # Comments 2 - just the autoupdate bits $update = $table->{comment}; if ( !defined( $update ) ) { $update = ''; } if ( $update =~ //mi ) { $update = $3; # update code } # Set up build the table documentation $self->{'dbdata'}{$tablename}{'name'} = $tablename; $self->{'dbdata'}{$tablename}{'comment'} = $comment; $self->{'dbdata'}{$tablename}{'autoupdate'} = $update; $self->{'dbdata'}{$tablename}{'fields'} = {}; # field list, keyed by field name $self->{'dbdata'}{$tablename}{'keyfields'} = {}; # primary key fields $self->{'dbdata'}{$tablename}{'ref_by'} = {}; # tables that use this as a FK $self->{'dbdata'}{$tablename}{'ref_to'} = {}; # tables that this uses for FK $self->{'dbdata'}{$tablename}{'permissions'} = []; # permissions array $self->{'dbdata'}{$tablename}{'indices'} = {}; # indices keyed by index name # Fields # Check not null and primary key property for each column. Column # visibility is given in $columns[3]. A value of 2 in this field # signifies a primary key (which also must be defined as 'not null'. $tablerowdata = ''; foreach my $column (@{ $table->{attList} }) { if (ref($column) ne 'ARRAY') { $self->{log} ->error(q{Error in view attList input - expect an ARRAY ref!}); next COLUMN; } # Don't warn on uninitialized values here since there are lots # of them. ## no critic (ProhibitNoWarnings) no warnings q{uninitialized}; # Field sequence: my ($col_name, $col_type, $col_val, $col_vis, $col_com) = @{$column}; $self->{'dbdata'}{$tablename}{'fields'}{$col_name} = { 'name' => $col_name, 'type' => $col_type, 'default' => $col_val, 'comment' => $col_com, 'order' => $order, }; $order ++; ## Add 'not null' if field is primary key if ($col_vis == 2) { $self->{'dbdata'}{$tablename}{'fields'}{$col_name}{'default'} = 'not null'; $self->{'dbdata'}{$tablename}{'keyfields'}{$col_name} = 1; } } return ''; } =head2 get_schema_drop Do nothing =cut sub get_schema_drop { return ''; } =head2 get_view_drop Do nothing =cut sub get_view_drop { return ''; } =head2 _get_fk_drop Do nothing =cut sub _get_fk_drop { return ''; } =head2 _get_drop_index_sql Do nothing =cut sub _get_drop_index_sql { return ''; } =head2 get_permissions_create Permissions are formatted as C<{type} {name} to {list of roles}> where: C is the operation C, C etc C is the permission name C