File Coverage

blib/lib/SQL/Generator.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

# Author: Murat Uenalan ([e-mail])
#
# Copyright (c) 2001 Murat Uenalan. All rights reserved.
#
# Note: This program is free software; you can redistribute
#
# it and/or modify it under the same terms as Perl itself.

our $VERSION = '0.02';

require 5.005_62;

use warnings;

use Carp;

use Class::Maker;

package Object::ObjectList;

use Class::Maker::Examples::Array;

#use Types::Array;

Class::Maker::class
{
	isa => [qw(Array)],

	attribute =>
	{
		getset => [ qw/name blessed/ ],
	},
};

sub push_new
{
	my $this = shift;

	my %arghash = @_;

	my $obj;

	my $class = $this->blessed();

	unless( $class->can( 'new' ) )
	{
			::croak "Couldn't call method new via module '$class' :$@";
	}

	$obj = $class->new( %arghash );

	$this->push( $obj );

return $obj;
}

	# search our object list and return the obj with matching attributes

sub get_where
{
	my $this = shift;

	my %arghash = @_;

	my $key = shift @{ [ keys %arghash ] };

	my @results;

		foreach my $obj ( $this->get )
		{
			if( $obj->$key() eq $arghash{$key} )
			{
				push @results, $obj;
			}
		}

	return undef unless @results;

return wantarray ? @results : $results[0];
}

sub get_where_islike
{
	my $this = shift;

	my %arghash = @_;

	my $key = shift @{ [ keys %arghash ] };

	my @results;

		foreach my $obj ( @{ $this->get } )
		{
			if( $obj->$key() =~ /$arghash{$key}/ )
			{
				push @results, $obj;
			}
		}

return \@results;
}

package SQL::Generator::Argument;

Class::Maker::class
{
	attribute =>
	{
		getset =>
		[
			qw(replace pre post token parameter),

			qw(token_printf joinstr param_printf),

			qw(joinseperator),

			qw(hash_keyprintf hash_valueprintf hash_assigner),

			qw(array_valueprintf),
		],

		hash => [qw(argtypes)],
	},
};

require 5.005_62; use warnings; use strict;

# Preloaded methods go here.

sub _preinit
{
	my $this = shift;

	$this->pre('');
	$this->post('');

	$this->token_printf('%s');	# format tokenstring
	$this->param_printf('%s');	# format paramstring
	$this->joinstr(' ');

	$this->joinseperator(', ');	# what is the seperator between elements

	$this->hash_keyprintf('%s');	# do we should quote the keys ?
	$this->hash_valueprintf("'%s'");	# do we should quote the values ?
	$this->hash_assigner(' => ');	# string between key => value pairs

	$this->array_valueprintf('%s');	# do we should quote the values ?

	$this->replace( 0 );
}

sub _postinit
{
	my $this = shift;

	if( $this->pre )
	{
		$this->token_printf( $this->pre.$this->token_printf );	# format tokenstring
	}

	if( $this->post )
	{
		$this->param_printf( $this->param_printf.$this->post );	# format tokenstring
	}

	if( $this->replace )
	{
		$this->token('');

		$this->param_printf('%s');
	}

	unless( keys %{ $this->argtypes } )
	{
		$this->argtypes->{SCALAR} = 1;
	}
}

sub scalar_totext
{
	my $this = shift;

return sprintf( $this->param_printf, ref($this->parameter) ? ${$this->parameter} : $this->parameter );
}

sub array_totext
{
	my $this = shift;

	my @fields=();

	foreach my $field ( @{ $this->parameter } )
	{
		push @fields, sprintf( $this->array_valueprintf, $field );
	}

return sprintf( $this->param_printf, join( $this->joinseperator, @fields ) );
}

sub hash_totext
{
	my $this = shift;

	my @fields=();

	while( my ($key, $value) = each %{$this->parameter} )
	{
		my $field='';

		$field .= sprintf( $this->hash_keyprintf, $key );

		$field .= $this->hash_assigner;

		$field .= sprintf( $this->hash_valueprintf, $value );

		push @fields, $field;
	}

return sprintf( $this->param_printf, join( $this->joinseperator, @fields ) );
}

sub param : method
{
	my $this = shift;

		my $param = shift;

			my $type = ref( $param ) || 'SCALAR';

			unless( $this->testType( $type ) )
			{
				::carp  'Incorrect type ', $type, ', use ', join( ' or ',$this->wantType ), ' instead';
			}

return $this->parameter( $param );
}

sub reset : method
{
	my $this = shift;

		$this->parameter( undef );
return;
}

sub wantType : method
{
	my $this = shift;

		my @allowed = ();

		foreach ( keys %{ $this->argtypes } )
		{
			if( $this->argtypes->{$_} )
			{
				push @allowed, $_;
			}
		}

return @allowed;
}

	# tests wether the given type is allowed and with undef argument returns list of allowed
	# types

sub testType($) : method
{
	my $this = shift;

		my $type = shift;

		if( $this->argtypes->{'ALL'} )
		{
			return 'ALL';
		}

		if( $this->argtypes->{$type} )
		{
			return $type;
		}

return undef;
}

	#
	# translates the element to a sql language element
	#

sub totext : method
{
	my $this = shift;

	my $pre = sprintf( $this->token_printf, $this->token );	# format tokenstring

	if( $pre )
	{
		$pre .= $this->joinstr;
	}

	my $type =  ref( $this->parameter ) || 'SCALAR';

	if( $type eq 'ARRAY' )
	{
		return $pre.$this->array_totext( $this->parameter );
	}
	elsif( $type eq 'HASH' )
	{
		return $pre.$this->hash_totext( $this->parameter );
	}
	else
	{
		return $pre.$this->scalar_totext( $this->parameter );
	}

return undef;
}

package SQL::Generator::Command;

Class::Maker::class
{
	can => [qw( validate )],

	attribute =>
	{
		getset => [qw(id subobject prettyprint)],

		array => [qw(template required)],

		hash => [qw(arguments subobjects defaults)],
	},
};

require 5.005_62;

use strict;

use warnings;

# Preloaded methods go here.

sub _preinit : method
{
	my $this = shift;

		$this->prettyprint( '' );

return;
}

sub _postinit : method
{
	my $this = shift;

			# generate 'Argument' instances for every arg of the template

		foreach my $arg ( @{ $this->template } )
		{
			if( exists $this->arguments->{$arg} )
			{
				$this->arguments->{$arg} = new SQL::Generator::Argument( token => $arg, %{ $this->arguments->{$arg} } );
			}
			else
			{
				$this->arguments->{$arg} = new SQL::Generator::Argument( token => $arg, argtypes => { SCALAR => 1 } );
			}
		}

return;
}

sub validate : method
{
	my $this = shift;

		my $href_args = shift;

			# validate if all required fields are existing

		my @missing = ();

		foreach my $element ( @{ $this->required } )
		{
			if( not exists $href_args->{$element} )
			{
				if( not exists $this->defaults->{$element} )
				{
					push @missing, $element;
				}
			}
		}

		die sprintf( 'Required argument(s) (%s) %s missing (defaults: %s)', join( ', ',@missing ), @missing > 1 ? 'are' : 'is', join( ', ', keys %{ $this->defaults } ) ) if @missing;

return 1;
}

sub totext
{
	my $this = shift;

		my $href_args = shift;

		$this->validate( $href_args );

		my @construct;

		foreach my $element ( @{ $this->template } )
		{
			#$this->debugPrint( sprintf "%s( '%s' %s )\n",$this->id, $element, (exists $href_args->{$element}) ? 'EXISTS' : 'NOT FOUND' );

			# defaults should be use, if value is missing ## ERROR/WARN: ONLY WHEN IT IS A REQUIRED ELEMENT ...see validate !!

			unless( exists $href_args->{$element} )
			{
				if( exists $this->defaults->{$element} )
				{
					$href_args->{$element} = $this->defaults->{$element};
				}
			}

			if( exists $href_args->{$element} )
			{
				if( my $subcmd = $this->subobjects->{$element} )
				{
					$this->arguments->{$element}->param( $subcmd->totext( $href_args ) );
				}
				else
				{
					$this->arguments->{$element}->param( $href_args->{$element} );
				}

				push @construct, sprintf '%s%s', $this->arguments->{$element}->totext(), $this->prettyprint;

				$this->arguments->{$element}->reset();
			}
		}

return join( ' ', @construct);
}

package SQL::Generator;

Class::Maker::class
{
	attribute =>
	{
		getset =>
		[
			qw/command pre post autoprint prettyprint  historysize/,

			qw/table database where/,

			qw/lang langrules file handle/,
		],

		array => [ qw/history/ ],

		hash => [ qw/defaults/ ],
	},
};

use strict;

use IO::File;

use vars qw($AUTOLOAD $VERSION);

use Exporter;

our %EXPORT_TAGS = ( 'all' => [ qw( ) ]  );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw( );

# Preloaded methods go here.

sub _preinit
{
	my $this = shift;

	$this->pre( '' );

	$this->post( '' );

	$this->autoprint(0);

	$this->prettyprint(0);

	$this->historysize(100);

	$this->lang( 'MYSQL' );

	$this->file( undef );

	#$this->debugOn;
}

sub close
{
	my $this = shift;

	if( defined $this->handle() )
	{
		$this->handle->close();
	}
}

sub _postinit
{
	my $this = shift;

	$this->change_dialect( $this->lang );

	if( $this->file )
	{
		$this->debugPrint( sprintf "opening file %s as STDOUT", $this->file );

		$this->handle( new IO::File( $this->file ) ) ;

		unless( defined $this->handle() )
		{
			die sprintf "FAILURE: opening file %s as STDOUT", $this->file;
		}
	}
}

sub dialect_path
{
	my $this = shift;

		my $lang = shift || $this->lang;

return 'SQL::Generator::Lang::'.$lang;
}

sub change_dialect
{
	my $this = shift;

		my $lang = shift;

		#die "WE DIE HERE";

		my $dialect = $this->dialect_path($lang);

		eval "require $dialect";

		if( $@ )
		{
			::croak "Couldn't change/load language module '$dialect' :$@";
		}

		# update rules via new CommandList instance: SQL::Generator::Lang::*->new()

		$this->langrules( $dialect->new() );

		die "Failed loading language module" unless $this->langrules;

return $this->lang( $lang );
}

sub DEFAULT : method
{
	my $this = shift;

		my %args = @_;

		$this->defaults( \%args );

#		foreach my $key ( keys %{ $this->defaults } )
#		{
#			print "SETTING DEFAULT: $key => ", $args{$key}, "\n\n";
#		}

return;
}

sub AUTOLOAD
{
	my $func = $AUTOLOAD;

	$func =~ s/.*:://;

	return if $func eq 'DESTROY';

	my $this = shift;

		my %args = @_;

		my $result;

			# only single command per func in this version !!! we take the first one...

		my ( $cmd ) =  $this->langrules->get_where( id => $func );

		if(  defined $cmd )
		{
			$cmd->defaults( \%{ $this->defaults } );

			$result = sprintf '%s %s', $func, $cmd->totext( \%args );

			$result = $this->pre.$result.$this->post;

			if( $result eq 1 )
			{
				die "DONT KNOW WHAT THE HELL HAPPENED";
			}
		}
		else
		{
			warn( "Can't find command for $func in ", $this->dialect_path );
		}

		$this->handle->print($result) if $this->file;

		print $result if $this->autoprint;

		if( $this->history )
		{
			if( @{ $this->history } < $this->historysize )
			{
				push @{ $this->history }, $result;
			}
		}

return $result;
}

sub dump_history
{
	my $this = shift;

	my $pre = shift;

	my $post = shift;

		foreach ( @{ $this->history } )
		{
			print $pre || '', $_, $post || '';
		}

		@{ $this->history } = [];
}

1;

__END__