File Coverage

blib/lib/DBIx/Simple/Class/Schema.pm

Criterion	Covered	Total	%
statement	144	146	98.6
branch	54	60	90.0
condition	36	47	76.6
subroutine	15	15	100.0
pod	2	2	100.0
total	251	270	92.9

line

stmt

bran

cond

sub

pod

time

code

1

package DBIx::Simple::Class::Schema;

2

1

46815

use strict;

1

1

1

27

3

1

4

use warnings;

1

1

1

20

4

1

14

use 5.010001;

1

3

1

19

5

1

3

use Carp;

1

1

1

42

6

1

3

use Data::Dumper;

1

1

1

28

7

1

335

use parent 'DBIx::Simple::Class';

1

201

1

3

8

9

our $VERSION = '0.006';

10

11

12

*_get_obj_args = \&DBIx::Simple::Class::_get_obj_args;

13

14

#struct to keep schemas while building

15

my $schemas = {};

16

17

#for accessing schema structures during tests

18

sub _schemas {

19

6

16

$_[2] && ($schemas->{$_[1]} = $_[2]);

20

6

43

return $_[1] && exists $schemas->{$_[1]} ? $schemas->{$_[1]} : $schemas;

21

}

22

23

sub _get_table_info {

24

4

7

my ($class, $args) = _get_obj_args(@_);

25

26

4

9

$args->{namespace} || Carp::croak('Please pass "namespace" argument');

27

28

#get tables from the current database

29

#see https://metacpan.org/module/DBI#table_info

30

4

10

return $schemas->{$args->{namespace}}{tables} = $class->dbh->table_info(

31

undef, undef,

32

$args->{table} || '%',

33

$args->{type} || "'TABLE','VIEW'"

34

)->fetchall_arrayref({});

35

36

}

37

38

sub _get_column_info {

39

4

7

my ($class, $tables) = @_;

40

4

9

my $dbh = $class->dbh;

41

4

15

foreach my $t (@$tables) {

42

8

405

$t->{column_info} =

43

$dbh->column_info(undef, undef, $t->{TABLE_NAME}, '%')->fetchall_arrayref({});

44

45

#TODO support multi_column primary keys.see DSC::find()

46

8

7573

$t->{PRIMARY_KEY} =

47

$dbh->primary_key_info(undef, undef, $t->{TABLE_NAME})->fetchall_arrayref({})

48

->[0]->{COLUMN_NAME} || '';

49

50

#as child table

51

8

5494

my $sth =

52

$dbh->foreign_key_info(undef, undef, undef, undef, undef, $t->{TABLE_NAME});

53

8

4649

$t->{FOREIGN_KEYS} = $sth->fetchall_arrayref({}) if $sth;

54

55

}

56

4

367

return $tables;

57

}

58

59

#generates COLUMNS and PRIMARY_KEY

60

sub _generate_COLUMNS_ALIASES_CHECKS {

61

4

7

my ($class, $tables) = @_;

62

63

4

7

foreach my $t (@$tables) {

64

8

12

$t->{COLUMNS} = [];

65

8

11

$t->{ALIASES} = {};

66

8

10

$t->{CHECKS} = {};

67

8

8

$t->{QUOTE_IDENTIFIERS} = 0;

68

8

35

foreach my $col (sort { $a->{ORDINAL_POSITION} <=> $b->{ORDINAL_POSITION} }

86

75

8

23

69

@{$t->{column_info}})

70

{

71

52

41

push @{$t->{COLUMNS}}, $col->{COLUMN_NAME};

52

63

72

73

#generate ALIASES

74

52

327

if ($col->{COLUMN_NAME} =~ /\W/) { #not A-z0-9_

75

2

8

$t->{QUOTE_IDENTIFIERS} ||= 1;

76

2

4

$t->{ALIASES}{$col->{COLUMN_NAME}} = $col->{COLUMN_NAME};

77

2

7

$t->{ALIASES}{$col->{COLUMN_NAME}} =~ s/\W/_/g; #foo-bar=>foo_bar

78

}

79

elsif ($class->SUPER::can($col->{COLUMN_NAME})) {

80

2

5

$t->{ALIASES}{$col->{COLUMN_NAME}} = 'column_' . $col->{COLUMN_NAME};

81

}

82

83

# generate CHECKS

84

52

73

if ($col->{IS_NULLABLE} eq 'NO') {

85

32

48

$t->{CHECKS}{$col->{COLUMN_NAME}}{required} = 1;

86

32

35

$t->{CHECKS}{$col->{COLUMN_NAME}}{defined} = 1;

87

}

88

52

111

if ($col->{COLUMN_DEF} && $col->{COLUMN_DEF} !~ /NULL/i) {

89

20

19

my $default = $col->{COLUMN_DEF};

90

20

38

$default =~ s|\'||g;

91

20

30

$t->{CHECKS}{$col->{COLUMN_NAME}}{default} = $default;

92

}

93

52

103

my $size = $col->{COLUMN_SIZE} // 0;

94

52

145

if ($size >= 65535 || $size == 0) {

95

18

14

$size = '';

96

}

97

52

187

if ($col->{TYPE_NAME} =~ /INT/i) {

98

16

238

$t->{CHECKS}{$col->{COLUMN_NAME}}{allow} = qr/^-?\d{1,$size}$/x;

99

}

elsif ($col->{TYPE_NAME} =~ /FLOAT|DOUBLE|DECIMAL/i) {

8

18

my $scale = $col->{DECIMAL_DIGITS} || 0;

8

9

my $precision = $size - $scale;

8

108

$t->{CHECKS}{$col->{COLUMN_NAME}}{allow} =

qr/^-?\d{1,$precision}(?:\.\d{0,$scale})?$/x;

}

elsif ($col->{TYPE_NAME} =~ /CHAR|TEXT|CLOB/i) {

$t->{CHECKS}{$col->{COLUMN_NAME}}{allow} =

5

968

sub { ($_[0] =~ /^.{1,$size}$/x) || ($_[0] eq '') }

24

79

}

} #end foreach @{$t->{column_info}

} #end foreach $tables

4

4

return $tables;

}

my $_MAKE_SCHEMA;

sub _MAKE_SCHEMA {

31

610

$_MAKE_SCHEMA = $_[1] if defined $_[1];

31

105

return $_MAKE_SCHEMA;

}

sub _generate_CODE {

4

6

my ($class, $args) = @_;

4

4

my $code = '';

4

5

my $namespace = $args->{namespace};

4

5

my $tables = $schemas->{$namespace}{tables};

4

10

$schemas->{$namespace}{code} = [];

4

7

if ($class->_MAKE_SCHEMA) {

2

2

push @{$schemas->{$namespace}{code}}, <<"BASE_CLASS";

2

15

package $namespace; #The schema/base class

use 5.010001;

use strict;

use warnings;

use utf8;

use parent qw(DBIx::Simple::Class);

our \$VERSION = '0.01';

sub is_base_class{return 1}

sub dbix {

# Singleton DBIx::Simple instance

state \$DBIx;

return (\$_[1] ? (\$DBIx = \$_[1]) : \$DBIx)

|| Carp::croak('DBIx::Simple is not instantiated. Please first do '

. \$_[0]

. '->dbix(DBIx::Simple->connect(\$DSN,\$u,\$p,{...})');

}

1;

$/$/=pod$/$/=encoding utf8$/$/=head1 NAME$/$/$namespace - the base schema class.

$/=head1 DESCRIPTION

This is the base class for using table records as plain Perl objects.

The subclassses are:$/$/=over

BASE_CLASS

}

4

7

foreach my $t (@$tables) {

10

24

my $package =

8

983

$namespace . '::' . (join '', map { ucfirst lc } split /_/, $t->{TABLE_NAME});

8

37

my $COLUMNS = Data::Dumper->Dump([$t->{COLUMNS}], ['$COLUMNS']);

8

393

my $ALIASES = Data::Dumper->Dump([$t->{ALIASES}], ['$ALIASES']);

8

209

my $CHECKS = Data::Dumper->Dump([$t->{CHECKS}], ['$CHECKS']);

8

718

my $TABLE = Data::Dumper->Dump([$t->{TABLE_NAME}], ['$TABLE_NAME']);

8

185

my $name_description =

"A class for $t->{TABLE_TYPE} $t->{TABLE_NAME} in schema $t->{TABLE_SCHEM}";

8

14

$schemas->{$namespace}{code}[0] .= qq|$/=item L<$package> - $name_description$/|

if $class->_MAKE_SCHEMA;

8

76

push @{$schemas->{$namespace}{code}}, qq|package $package; #A table/row class

52

184

use 5.010001;

use strict;

use warnings;

use utf8;

use parent qw($namespace);

| . qq|

sub is_base_class{return 0}

my $TABLE

sub TABLE {return \$TABLE_NAME}| . qq|

sub PRIMARY_KEY{return '$t->{PRIMARY_KEY}'}

my $COLUMNS

sub COLUMNS {return \$COLUMNS}

my $ALIASES

sub ALIASES {return \$ALIASES}

my $CHECKS

sub CHECKS {return \$CHECKS}

__PACKAGE__->QUOTE_IDENTIFIERS($t->{QUOTE_IDENTIFIERS});

#__PACKAGE__->BUILD;#build accessors during load

1;

| . qq|$/=pod$/$/=encoding utf8$/$/=head1 NAME$/$/$name_description

| . qq|=head1 SYNOPSIS$/$/=head1 DESCRIPTION$/$/=head1 COLUMNS$/

Each column from table C<$t->{TABLE_NAME}> has an accessor method in this class.

|

8

8

. (join '', map { $/ . '=head2 ' . $_ . $/ } @{$t->{COLUMNS}})

8

9

. qq|$/=head1 ALIASES$/$/=head1 GENERATOR$/$/L<$class>$/$/=head1 SEE ALSO$/|

. qq|L<$namespace>, L, L<$class>

$/=head1 AUTHOR$/$/$ENV{USER}$/$/=cut

|;

} # end foreach my $t (@$tables)

4

1258

$schemas->{$namespace}{code}[0] .= qq|$/=back$/$/=head1 GENERATOR$/$/L<$class>

$/$/=head1 SEE ALSO$/$/

L<$class>, L, L, L

$/=head1 AUTHOR$/$/$ENV{USER}$/$/=cut

| if $class->_MAKE_SCHEMA;

4

455

if (defined wantarray) {

3

8

if (wantarray) {

1

1

return @{$schemas->{$namespace}{code}};

1

7

}

else {

2

2

return join '', @{$schemas->{$namespace}{code}};

2

20

}

}

1

3

return;

}

sub load_schema {

4

16

my ($class, $args) = _get_obj_args(@_);

4

12

unless ($args->{namespace}) {

2

9

$args->{namespace} = $class->dbh->{Name};

2

28

if ($args->{namespace} =~ /(database|dbname|db)=([^;]+);?/x) {

2

4

$args->{namespace} = $2;

}

2

8

$args->{namespace} =~ s/\W//xg;

2

10

$args->{namespace} =

2

7

'DSCS::' . (join '', map { ucfirst lc } split /_/, $args->{namespace});

}

4

9

my $tables = $class->_get_table_info($args);

#get table columns, PRIMARY_KEY, foreign keys

4

1700

$class->_get_column_info($tables);

#generate COLUMNS, ALIASES, CHECKS

4

15

$class->_generate_COLUMNS_ALIASES_CHECKS($tables);

4

29

$class->_MAKE_SCHEMA(($args->{table} eq '%') or (not $args->{table}));

#generate code

4

6

if (wantarray) {

1

2

return ($class->_generate_CODE($args));

}

3

13

return $class->_generate_CODE($args);

}

sub dump_schema_at {

8

1602

my ($class, $args) = _get_obj_args(@_);

8

41

$args->{lib_root} ||= $INC[0];

8

7

my ($namespace, @namespace, @base_path, $schema_path);

#_generate_CODE() should be called by now

#we always have only one key

8

168

$namespace = (keys %$schemas)[0]

|| Carp::croak('Please first call ' . __PACKAGE__ . '->load_schema()!');

7

37

require File::Path;

7

42

require File::Spec;

7

1111

require IO::File;

7

6601

@namespace = split /::/, $namespace;

7

43

@base_path = File::Spec->splitdir($args->{lib_root});

7

46

$schema_path = File::Spec->catdir(@base_path, @namespace);

7

395

if (eval "require $namespace" && $class->_MAKE_SCHEMA) {

4

407

carp( "Module $namespace is already installed at "

. $INC{join('/', @namespace) . '.pm'}

. ". Please avoid namespace collisions...");

}

7

2140

say('Will dump classes at ' . $args->{lib_root});

#We should be able to continue safely now...

7

22

my $tables = $schemas->{$namespace}{tables};

7

7

my $code = $schemas->{$namespace}{code};

7

104

if (!-d $schema_path) {

2

2

eval { File::Path::make_path($schema_path); }

2

407

|| carp("Can not make path $schema_path.$/$!. Quitting...") && return;

}

7

63

if ($class->_MAKE_SCHEMA) {

5

17

carp("Overwriting $schema_path.pm...") if $args->{overwrite} && $class->DEBUG;

5

318

my $base_fh = IO::File->new("> $schema_path.pm")

|| Carp::croak("Could not open $schema_path.pm for writing" . $!);

5

520

print $base_fh $code->[0];

5

18

$base_fh->close;

}

7

169

foreach my $i (0 .. @$tables - 1) {

22

59

my $filename =

17

231

(join '', map { ucfirst lc } split /_/, $tables->[$i]{TABLE_NAME}) . '.pm';

17

372

next if (-f "$schema_path/$filename" && !$args->{overwrite});

10

47

carp("Overwriting $schema_path/$filename...")

if $args->{overwrite} && $class->DEBUG;

10

1142

my $fh = IO::File->new("> $schema_path/$filename");

10

805

if (defined $fh) {

10

46

print $fh $code->[$i + 1];

10

368

$fh->close;

}

else {

0

0

carp("$schema_path/$filename: $!. Quitting!");

0

0

return;

}

}

7

161

return 1;

}

1;

=encoding utf8

=head1 NAME

DBIx::Simple::Class::Schema - Create and use classes representing tables from a database

=head1 SYNOPSIS

#Somewhere in a utility script or startup() of your application.

DBIx::Simple::Class::Schema->dbix(DBIx::Simple->connect(...));

my $perl_code = DBIx::Simple::Class::Schema->load_schema(

namespace =>'My::Model',

table => '%', #all tables from the current database

type => "'TABLE','VIEW'", # make classes for tables and views

);

#Now eval() to use your classes.

eval $perl_code || Carp::croak($@);

#Or load and save it for more customisations and later usage.

DBIx::Simple::Class::Schema->load_schema(

namespace =>'My::Model',

table => '%', #all tables from the current database

type => "'TABLE','VIEW'", # make classes for tables and views

);

DBIx::Simple::Class::Schema->dump_schema_at(

lib_root => "$ENV{PERL_LOCAL_LIB_ROOT}/lib"

overwrite =>1 #overwrite existing files

) || Carp::croak 'Something went wrong! See above...';

=head1 DESCRIPTION

DBIx::Simple::Class::Schema automates the creation of classes from

database tables. You can use it when you want to prototype quickly

your application. It is also very convenient as an initial generator and dumper of

your classes representing your database tables.

=head1 METHODS

=head2 load_schema

Class method.

Params:

namespace - String. The class name for your base class,

default: 'DSCS::'.(join '', map { ucfirst lc } split /_/, $database)

table - SQL string for a LIKE clause,

default: '%'

type - SQL String for an IN clause.

default: "'TABLE','VIEW'"

Extracts tables' information from the current connection and generates

Perl classes representing those tables or/and views.

If called in list context returns an array with perl code for each package.

The first package is the base class. The base class is generated only the argument C is '%' or empty.

If called in scalar context returns all the generated code as a string.

The generated classes are saved internally and are available for use by

L.

This makes it very convenient for quickly prototyping applications

by just modifying tables in your database.

my $perl_code = DBIx::Simple::Class::Schema->load_schema();

#concatenaded code as one string

eval $perl_code || Carp::croak($@);

#...

my $user = Dbname::User->find(2345);

#or My::Schema, My::Schema::Table1, My::Schema::Table2,...

my @perl_code = DBIx::Simple::Class::Schema->load_schema();

#or just prepare code before dumping it to disk.

DBIx::Simple::Class::Schema->load_schema();

=head2 dump_schema_at

Class method.

Params:

lib_root: String - Where classes will be dumped.

default: $INC[0]

overwrite: boolean -1/0 Should it overwrite existing classes with the same name?

default: 0

Uses the generated code by L and saves each class on the disk.

Does several checks:

=over

=item *

Checks if a file with the name of your base class exists and exits

if the flag C is not set.

=item *

The base class is dumped to disk only if the argument C is '%' or empty.

409							It was not generated in L.
410							In other words base/schema class is generated when no specific table class is
411							required to be generated. This is convinient if you want to generate only specific table-classes and use them on-the-fly without dumping them to disk.
412
413							=item *
414
415							Checks if there is a module with the same name as your base class installed
416							and warns if there is such module. This is done to avoid namespace collisions.
417
418							=item *
419
420							Checks if the files can be written to disk and exit immediately if there is a problem.
421
422							=back
423
424							For every check above issues a warning so you, the developer, can decide what to do.
425							Returns true on success.
426
427							=head1 SUPPORTED DATABASE DRIVERS
428
429							DBIx::Simple::Class::Schema strives to be DBD agnostic and
430							uses only functionality specified by L.
431							This means that if a driver implements the methods specifyed in L it is supported.
432							However currently only tests for L and L are written.
433							Feel free to contribute with tests for your prefered driver.
434							The following methods are used to retreive information form the database:
435
436							=over
437
438							=item * L
439
440							=item * L
441
442							=item * L
443
444							=back
445
446							=head1 SUPPORTED SQL TYPES
447
448							Currently some minimal L are automatically generated for TYPE_NAMEs
449							matching C,C, C.
450							You are supposed to write your own business-specific checks.
451
452
453							=head1 SEE ALSO
454
455							L, L, L,
456							L
457
458							=head1 LICENSE AND COPYRIGHT
459
460							Copyright 2012-2013 Красимир Беров (Krasimir Berov).
461
462							This program is free software, you can redistribute it and/or modify it under
463							the terms of the Artistic License version 2.0.
464
465							See http://www.opensource.org/licenses/artistic-license-2.0 for more information.
466
467							=cut
468