From: Mark Addison <grommit@users.sourceforge.net>
Date: Wed, 14 Apr 2004 19:19:45 +0000 (+0000)
Subject: Initial crack at a base class for building TT based producers.
X-Git-Tag: v0.06~84
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=f5f03b784100c928aa1a1706deafbc27f2ec1730;p=dbsrgits%2FSQL-Translator.git

Initial crack at a base class for building TT based producers.
---

diff --git a/lib/SQL/Translator/Producer/TT/Base.pm b/lib/SQL/Translator/Producer/TT/Base.pm
new file mode 100644
index 0000000..19aa802
--- /dev/null
+++ b/lib/SQL/Translator/Producer/TT/Base.pm
@@ -0,0 +1,180 @@
+package SQL::Translator::Producer::TT::Base;
+
+# -------------------------------------------------------------------
+# $Id: Base.pm,v 1.1 2004-04-14 19:19:44 grommit Exp $
+# -------------------------------------------------------------------
+# Copyright (C) 2002-4 SQLFairy Authors
+#
+# 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; version 2.
+#
+# 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
+# -------------------------------------------------------------------
+
+=pod 
+
+=head1 NAME
+
+SQL::Translator::Producer::TT::Base - TT based Producer base class.
+
+=head1 SYNOPSIS
+
+ package SQL::Translator::Producer::Foo;
+ use base qw/SQL::Translator::Producer::TT::Base/;
+
+ # Convert produce call into an object of our new class
+ sub produce { return __PACKAGE__->new( translator => shift )->run; };
+
+ # Return file name or template source
+ sub tt_schema { local $/ = undef; return \<DATA>; }
+
+ # Extra vars to add to the template
+ sub tt_vars   { ( foo => "bar" ); }
+
+=head1 DESCRIPTION
+
+A base class producer designed to be sub-classed to create new TT base
+producers cheaply by simply giving the template to use and sprinkling in some 
+extra template variables.
+
+See the synopsis above for an example of creating a simple producer using
+a single template stored in the producers DATA section.
+
+WARNING: This is currently WORK IN PROGRESS and so subject to change, 
+but it does work ;-)
+
+=cut
+
+# -------------------------------------------------------------------
+
+use strict;
+
+use vars qw[ $VERSION @EXPORT_OK ];
+$VERSION = sprintf "%d.%02d", q$Revision: 1.1 $ =~ /(\d+)\.(\d+)/;
+
+use Template;
+use Data::Dumper;
+use Exporter;
+use base qw(Exporter);
+@EXPORT_OK = qw(produce);
+
+use SQL::Translator::Utils 'debug';
+
+# Hack to convert the produce call into an object. ALL sub-classes need todo
+# this so that the correct class gets created.
+sub produce {
+    return __PACKAGE__->new( translator => shift )->run;
+};
+
+sub new {
+    my $proto = shift;
+    my $class = ref $proto || $proto;
+    my %args  = @_;
+
+    my $me = bless {}, $class;
+    $me->{translator} = delete $args{translator} || die "Need a translator.";
+
+    return $me;
+}
+
+sub translator { shift->{translator}; }
+sub schema     { shift->{translator}->schema(@_); }
+
+# Until args access method.
+# No args - Return hashref (the actual hash in Translator) or hash of args.
+# 1 arg   - Return that named args value.
+# Args    - List of names. Return values of the given arg names in list context
+#           or return as hashref in scalar context. Any names given that don't
+#           exists in the args return undef.
+sub args {
+    my $me = shift;
+
+    # No args
+    unless (@_) {
+        return wantarray 
+            ? %{ $me->{translator}->producer_args }
+            : $me->{translator}->producer_args
+        ;
+    }
+
+    # 1 arg. Return the value whatever the context.
+    return $me->{translator}->producer_args->{$_[0]} if @_ == 1;
+
+    # More args so return values list or hash ref
+    my %args = %{ $me->{translator}->producer_args };
+    return wantarray ? @args{@_} : { map { ($_=>$args{$_}) } @_ };
+}
+
+# Run the produce and return the result.
+sub run {
+    my $me = shift;
+    my $scma = $me->schema;
+    my %args = %{$me->args};
+    my $tmpl = $me->tt_schema or die "No template!";
+
+    debug "Processing template $tmpl\n";
+    my $out;
+    my $tt       = Template->new(
+        #DEBUG    => $me->translator->debug,
+        ABSOLUTE => 1, # Set so we can use from the command line sensibly
+        RELATIVE => 1, # Maybe the cmd line code should set it! Security!
+        %args,         # Allow any TT opts to be passed in the producer_args
+    ) || die "Failed to initialize Template object: ".Template->error;
+
+    $tt->process( $tmpl, { $me->tt_default_vars, $me->tt_vars, }, \$out )
+    or die "Error processing template '$tmpl': ".$tt->error;
+
+    return $out;
+}
+
+# Returns template file to use, or a scalar ref of tt source, or io handle.
+# See L<Template>
+sub tt_schema { shift->args("ttfile") };
+
+# Returns hash-ref of the defaults vars given to the template.
+# You wouldn't normally over-ride but here just in case.
+sub tt_default_vars {
+    my $me = shift;
+    return (
+        translator => $me->translator,
+        schema     => $me->translator->schema,
+    );
+}
+
+# Return hash of template vars to add to the default set.
+sub tt_vars { () };
+1;
+
+# -------------------------------------------------------------------
+
+=pod
+
+=head1 AUTHOR
+
+Mark Addison E<lt>grommit@users.sourceforge.netE<gt>.
+
+=head1 TODO
+
+Lots! But the next things include;
+
+- Hook to allow sub-class to set the options given to the C<Template> instance.
+
+- Add support for a sqlf template repository somewhere, set as an INCLUDE_PATH,
+so that sub-classes can easily include file based templates.
+
+- Merge in TT::Table.
+
+=head1 SEE ALSO
+
+SQL::Translator.
+
+=cut
diff --git a/t/34tt-base.t b/t/34tt-base.t
new file mode 100644
index 0000000..42564d2
--- /dev/null
+++ b/t/34tt-base.t
@@ -0,0 +1,58 @@
+#!/usr/bin/perl -w 
+# vim:filetype=perl
+
+# Before `make install' is performed this script should be runnable with
+# `make test'. After `make install' it should work as `perl test.pl'
+
+use strict;
+use Test::More;
+use Test::Exception;
+use Test::SQL::Translator qw(maybe_plan);
+
+use Data::Dumper;
+use vars '%opt';
+BEGIN { map { $opt{$_}=1 if s/^-// } @ARGV; }
+use constant DEBUG => (exists $opt{d} ? 1 : 0);
+
+use FindBin qw/$Bin/;
+use lib ("$Bin/lib");
+
+# Testing 1,2,3,4...
+#=============================================================================
+package main;
+
+BEGIN {
+    maybe_plan(4, 'Template', 'Test::Differences')
+}
+use Test::Differences;
+
+use SQL::Translator;
+use SQL::Translator::Producer::TTSchema;
+
+# Parse the test XML schema
+my $obj;
+$obj = SQL::Translator->new(
+    debug          => DEBUG, #$opt{d},
+    show_warnings  => 1,
+    add_drop_table => 1,
+    from           => "XML-SQLFairy",
+    filename       => "$Bin/data/xml/schema-basic.xml",
+    to             => "Producer::BaseTest::produce",
+    producer_args  => {
+        ttfile => "$Bin/data/template/basic.tt",
+    },
+);
+my $out;
+lives_ok { $out = $obj->translate; }  "Translate ran";
+is $obj->error, ''                   ,"No errors";
+ok $out ne ""                        ,"Produced something!";
+local $/ = undef; # slurp
+eq_or_diff $out, <DATA>              ,"Output looks right";
+
+print $out if DEBUG;
+#print "Debug:", Dumper($obj) if DEBUG;
+
+__DATA__
+Hello World
+Basic
+foo:bar
diff --git a/t/lib/Producer/BaseTest.pm b/t/lib/Producer/BaseTest.pm
new file mode 100644
index 0000000..bc97aab
--- /dev/null
+++ b/t/lib/Producer/BaseTest.pm
@@ -0,0 +1,17 @@
+package Producer::BaseTest;
+
+use base qw/SQL::Translator::Producer::TT::Base/;
+
+# Make sure we use our new class as the producer
+sub produce { return __PACKAGE__->new( translator => shift )->run; };
+
+sub tt_schema { local $/ = undef; return \<DATA>; }
+
+sub tt_vars { ( foo => "bar" ); }
+
+1;
+
+__DATA__
+Hello World
+[% schema.get_tables %]
+foo:bar