X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FSQL%2FTranslator%2FUtils.pm;h=ffcf6f38b1e6e9d8ba65ad92c60d1050729f36f1;hb=92638f3246feb6a2ce7f61b68086453755918b62;hp=98c0f9fd2bfe1666f462f9dddb709994b5218884;hpb=0c04c5a2210135419771878dc7e341a1cba52cca;p=dbsrgits%2FSQL-Translator.git diff --git a/lib/SQL/Translator/Utils.pm b/lib/SQL/Translator/Utils.pm index 98c0f9f..ffcf6f3 100644 --- a/lib/SQL/Translator/Utils.pm +++ b/lib/SQL/Translator/Utils.pm @@ -2,15 +2,21 @@ package SQL::Translator::Utils; use strict; use warnings; -use base qw(Exporter); -use Digest::SHA1 qw( sha1_hex ); -use Exporter; +use Digest::SHA qw( sha1_hex ); +use File::Spec; +use Scalar::Util qw(blessed); +use Try::Tiny; +use Carp qw(carp); our $VERSION = '1.59'; our $DEFAULT_COMMENT = '-- '; + +use base qw(Exporter); our @EXPORT_OK = qw( debug normalize_name header_comment parse_list_arg truncate_id_uniquely $DEFAULT_COMMENT parse_mysql_version parse_dbms_version + ddl_parser_instance + throw ex2err carp_ro ); use constant COLLISION_TAG_LENGTH => 8; @@ -191,6 +197,153 @@ sub parse_dbms_version { } } +#my ($parsers_libdir, $checkout_dir); +sub ddl_parser_instance { + + my $type = shift; + + # it may differ from our caller, even though currently this is not the case + eval "require SQL::Translator::Parser::$type" + or die "Unable to load grammar-spec container SQL::Translator::Parser::$type:\n$@"; + + # handle DB2 in a special way, since the grammar source was lost :( + if ($type eq 'DB2') { + require SQL::Translator::Parser::DB2::Grammar; + return SQL::Translator::Parser::DB2::Grammar->new; + } + + require Parse::RecDescent; + return Parse::RecDescent->new(do { + no strict 'refs'; + ${"SQL::Translator::Parser::${type}::GRAMMAR"} + || die "No \$SQL::Translator::Parser::${type}::GRAMMAR defined, unable to instantiate PRD parser\n" + }); + +# this is disabled until RT#74593 is resolved +=begin for general sadness + + unless ($parsers_libdir) { + + # are we in a checkout? + if ($checkout_dir = _find_co_root()) { + $parsers_libdir = File::Spec->catdir($checkout_dir, 'share', 'PrecompiledParsers'); + } + else { + require File::ShareDir; + $parsers_libdir = File::Spec->catdir( + File::ShareDir::dist_dir('SQL-Translator'), + 'PrecompiledParsers' + ); + } + + unshift @INC, $parsers_libdir; + } + + my $precompiled_mod = "Parse::RecDescent::DDL::SQLT::$type"; + + # FIXME FIXME FIXME + # Parse::RecDescent has horrible architecture where each precompiled parser + # instance shares global state with all its siblings + # What we do here is gross, but scarily efficient - the parser compilation + # is much much slower than an unload/reload cycle + require Class::Unload; + Class::Unload->unload($precompiled_mod); + + # There is also a sub-namespace that P::RD uses, but simply unsetting + # $^W to stop redefine warnings seems to be enough + #Class::Unload->unload("Parse::RecDescent::$precompiled_mod"); + + eval "local \$^W; require $precompiled_mod" or do { + if ($checkout_dir) { + die "Unable to find precompiled grammar for $type - run Makefile.PL to generate it\n"; + } + else { + die "Unable to load precompiled grammar for $type... this is not supposed to happen if you are not in a checkout, please file a bugreport:\n$@" + } + }; + + my $grammar_spec_fn = $INC{"SQL/Translator/Parser/$type.pm"}; + my $precompiled_fn = $INC{"Parse/RecDescent/DDL/SQLT/$type.pm"}; + + if ( + (stat($grammar_spec_fn))[9] + > + (stat($precompiled_fn))[9] + ) { + die ( + "Grammar spec '$grammar_spec_fn' is newer than precompiled parser '$precompiled_fn'" + . ($checkout_dir + ? " - run Makefile.PL to regenerate stale versions\n" + : "... this is not supposed to happen if you are not in a checkout, please file a bugreport\n" + ) + ); + } + + return $precompiled_mod->new; +=cut + +} + +# Try to determine the root of a checkout/untar if possible +# or return undef +sub _find_co_root { + + my @mod_parts = split /::/, (__PACKAGE__ . '.pm'); + my $rel_path = join ('/', @mod_parts); # %INC stores paths with / regardless of OS + + return undef unless ($INC{$rel_path}); + + # a bit convoluted, but what we do here essentially is: + # - get the file name of this particular module + # - do 'cd ..' as many times as necessary to get to lib/SQL/Translator/../../.. + + my $root = (File::Spec::Unix->splitpath($INC{$rel_path}))[1]; + for (1 .. @mod_parts) { + $root = File::Spec->catdir($root, File::Spec->updir); + } + + return ( -f File::Spec->catfile($root, 'Makefile.PL') ) + ? $root + : undef + ; +} + +{ + package SQL::Translator::Utils::Error; + + use overload + '""' => sub { ${$_[0]} }, + fallback => 1; + + sub new { + my ($class, $msg) = @_; + bless \$msg, $class; + } +} + +sub throw { + die SQL::Translator::Utils::Error->new($_[0]); +} + +sub ex2err { + my ($orig, $self, @args) = @_; + return try { + $self->$orig(@args); + } catch { + die $_ unless blessed($_) && $_->isa("SQL::Translator::Utils::Error"); + $self->error("$_"); + }; +} + +sub carp_ro { + my ($name) = @_; + return sub { + my ($orig, $self) = (shift, shift); + carp "'$name' is a read-only accessor" if @_; + return $self->$orig; + }; +} + 1; =pod @@ -339,6 +492,33 @@ Takes a version string (X.Y.Z) or perl style (XX.YYYZZZ) and a target ('perl' or 'native') transforms the string to the given target style. to +=head2 throw + +Throws the provided string as an object that will stringify back to the +original string. This stops it from being mangled by L's C +code. + +=head2 ex2err + +Wraps an attribute accessor to catch any exception raised using +L and store them in C<< $self->error() >>, finally returning +undef. A reference to this function can be passed directly to +L. + + around foo => \&ex2err; + + around bar => sub { + my ($orig, $self) = (shift, shift); + return ex2err($orig, $self, @_) if @_; + ... + }; + +=head2 carp_ro + +Takes a field name and returns a reference to a function can be used +L a read-only accessor to make it L +instead of die when passed an argument. + =head1 AUTHORS Darren Chamberlain Edarren@cpan.orgE,