File Coverage

blib/lib/Data/Type.pm

Criterion	Covered	Total	%
statement	1	3	33.3
branch			n/a
condition			n/a
subroutine	1	1	100.0
pod			n/a
total	2	4	50.0

# (c) 2004 by 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
# $Revision: 1.39 $
# $Header: /cygdrive/y/cvs/perl/modules/Data/Type/Type.pm.tmpl,v 1.39 2003/04/12 12:48:38 Murat Exp $

package Data::Type;

BEGIN
{
	use Regexp::Box;

	our $rebox = Regexp::Box->new( name => 'Data::Type custom datatypes' );
}

	our $VERSION = "0.02.02";

	our $DEBUG = 0;

	require 5.005_62; use strict; use warnings;

	use Carp;

	use Class::Maker;

	use Class::Maker::Exception qw(:try);

	use Locale::Language;	# required by langcode langname

	use IO::Extended qw(:all);

	use Data::Iter qw(:all);

	use Exporter;

	our @ISA = qw( Exporter );

	use subs qw(try with);

	our %EXPORT_TAGS =
        (
	  'all' => [qw(is isnt valid dvalid catalog summary try with)],

	  'valid' => [qw(is isnt valid dvalid)],

	  # same as :valid

	  'is' => [qw(is isnt valid dvalid)],

	  'try' => [qw(try with)],
	);

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

	our @EXPORT = ();

         # modules loaded registry (used by _load_dependency method)

        our $_loaded = {};

        our @_requested;

	our $_master_prefix = '';	# prefix all datatypes with that string

	our $_callers_pkg = '';

	our $_used_import_opts = {};

	use Data::Type::Collection;

        sub import
        {
		# Fetch the callers pkg

	    $_callers_pkg = scalar caller;

	    warnfln "caller is %S", $_callers_pkg if $Data::Type::DEBUG;

		# Reset master_prefix each time this module is used
                # So there is no confusion if its double used and the old
		# master_prefix is active

            $Data::Type::_master_prefix = '';

	    @_requested = ();

	    push @_requested, 'Std';

	    my @copy;

	    foreach my $id (@_)
	    {
		if( $id =~ /^\+/ )
		{
			# $id is an alias to @_ entry and therefore read-only

		    warnfln "Import Collection statement for: %S", $id if $Data::Type::DEBUG;

		    my $cp = $id;

		    $cp =~ s/^\+//;

		    if( $cp eq 'ALL' )
		    {
			warnfln "Collections %S for import registered", join( ', ', keys %$Data::Type::Collection::_ids ) if $Data::Type::DEBUG;

			push @_requested, keys %$Data::Type::Collection::_ids;
		    }
		    else
		    {
			push @_requested, $cp;
		    }
		}
		elsif( $id =~ /^<(.+)>$/ )
		{
		  $_used_import_opts->{MASTER_PREFIX} = $Data::Type::_master_prefix = $1;
		}
		elsif( $id =~ /^_$/ )
		{
		  warnfln "Export option: UNDERSCORE activated." if $Data::Type::DEBUG;

		  $Data::Type::_reformat_name = sub { $_[0] =~ s/::/_/g; };

		  $_used_import_opts->{UNDERSCORE} = 1;
		}
		elsif( $id =~ /^debug\+\+$/i )
		{
		  $_used_import_opts->{DEBUG} = $Data::Type::DEBUG++;
		}
		elsif( $id =~ /^debug\-\-$/i )
		{
		  $_used_import_opts->{DEBUG} = $Data::Type::DEBUG--;
		}
		else
		{
		    push @copy, $id;
		}
	    }

	    if( defined $_used_import_opts->{UNDERSCORE} )
	    {
		unless( defined $_used_import_opts->{MASTER_PREFIX} )
		{
		    $_used_import_opts->{MASTER_PREFIX} = $Data::Type::_master_prefix = $_callers_pkg.'::';
		}
	    }

	    my %requested;

	    $requested{$_} = '' for @_requested;

	    @_requested = grep { !/^STD$/i } keys %requested;

	    warn sprintf "Following collection where requested to export: %s", join( ', ', @Data::Type::_requested) if $Data::Type::DEBUG;

	    foreach ( 'STD', @_requested )
	    {
		my $pm = $Data::Type::Collection::_arg_to_pkg->{$_};

		$pm = $_ unless defined $pm;

		use Data::Dump qw(pp);

		die "pm var empty for $_ out of args".Data::Dump::pp( 'STD', @_requested ) unless defined $pm;

		eval "use Data::Type::Collection::$pm;";

		if( $@ )
		{
		    use Carp qw(cluck);

		    use Data::Dump qw(dump);

		    cluck "eval use Data::Type::Collection::$pm failed. Did you have a spelling mistake ? Requested where ".dump( @_requested, \%requested );


		    die $@;
		}

		codegen( $_.'::' );
	    }

	    @_ = @copy;

	    __PACKAGE__->export_to_level(1, @_);
	}

package Data::Type::Entry;

	Class::Maker::class
    	{
	    public =>
	    {
		bool => [qw( expected )],

		ref  => [qw( object )],
	    },
	};

package Data::Type::L18N;

        use strict;

	use Locale::Maketext;

	our @ISA = qw( Locale::Maketext );

package Data::Type::L18N::de;

	our @ISA = qw(Data::Type::L18N);

	use strict;

	use vars qw(%Lexicon);

	our %Lexicon =
     	(
		__current_locale__ => 'deutsch',

		"Can't open file [_1]: [_2]\n" => "Problem beim öffnen der datei [_1]. Grund: [_2]\n",

		"You won!" => "Du hast gewonnen!",
	);

package Data::Type::L18N::en;

	our @ISA = qw(Data::Type::L18N);

	use strict;

	use vars qw(%Lexicon);

	our %Lexicon =
	(
		__current_locale__ => 'english',

		"Can't open file [_1]: [_2]\n" => "Can't open file [_1]: [_2]\n",

		"You won!" => "You won!",
	 );

package Data::Type::Proxy;

	use vars qw($AUTOLOAD);

	sub AUTOLOAD
	{
		( my $func = $AUTOLOAD ) =~ s/.*:://;

	return bless [ @_ ], Data::Type::_add_package_to_name( lc $func );
	}

  #
  # The universal "Data::Type::Object Interface"
  #

package Data::Type::Object::Interface;

use Attribute::Util;

sub desc : method
{
    warn "abstract method called" if $Data::Type::DEBUG;

    return 'Universal';
}

# static string

sub info : Abstract method;

# shell commando like usage

sub usage { '' } #: Abstract method;

sub _filters : method { () }

# holds the logic of type validation. Should use Data::Type::ok()
# to dispatch public and private facets

sub test
{
  my $this = shift;

  $this->_load_dependency;

  Data::Type->filter( $this->_filters ) if scalar $this->_filters;

return $this->_test( @_ );
}

# return scalar/array/hash of alternativ choices when an inputfield
# is generated for this type

sub choice : Abstract method;

# returns a data structure used for the configuration/parameterization of
# the datatype

sub param : Abstract method;

# If some default value for C exists, they should be returned
# by this function

sub default : Abstract method;

# returns an array of required modules for this type
# [note] used to build a dependency tree

sub basic_depends : method { qw() }

sub _depends { () }

sub depends : method
{
	my $this = shift;

	my @d = ();

	@d = $this->_depends;

return ( @d, $this->basic_depends );
}

sub _load_dependency
{
    my $this = shift;

    foreach ( $this->_depends )
    {
	unless( exists $Data::Type::_loaded->{$_} )
	{
	    eval "use $_;"; die $@ if $@;

	    $Data::Type::_loaded->{$_} = caller;
	}
	else
	{
	    warn sprintf "%s tried to load twice %s", $_, join( ', ', caller ) if $Data::Type::DEBUG;
	}
    }
}

# No idea ?

sub to_text : Abstract method;

# api for casting of types
# Usage: my $a_castedto_b = TYPE_A->cast( TYPE_B );
# [note] Ideally use C for dispatching

sub cast : Abstract method;

# return static text of some sort of "manpage" for this type

sub doc : Abstract method; # A descriptive information about the interface should be placed here.

# returns a scalar. This should be implemented by an Data::Type::Collection::*::Interface class
# which is then used when generating the final exportname with C

sub prefix : method
{
	Carp::croak "abstract method prefix called";
}


# return array of alias's for that type

sub export : method
{
    my $this = shift;

    $this ||= ref($this);

    my $name = Data::Type::_cut_package_from_name( $this );

    my $pre = $this->pkg_prefix;

    $name =~ s/^${pre}//gi;

    return ( $name );
}

# return array of alias's for that type, including a prefix
# if this type is part of a collection

sub exported : method
{
    my $this = shift;

    my @result;

    foreach( $this->export )
    {
	my $n = $this->prefix().$_;

	$Data::Type::_reformat_name->( $n ) if defined $Data::Type::_reformat_name;

	push @result, Data::Type::_gen_name( $n );
    }

return @result;
}

sub summary
{
    my $this = shift;

    if( wantarray )
    {
	return Data::Type::summary( scalar @_ ? @_ : '' , $this );
    }

    my $sum;

    foreach my $entry ( Data::Type::summary( scalar @_ ? @_ : '' , $this ) )
    {
	$sum .= Data::Type::sprintfln "expecting it %s %s ", $entry->expected ? 'is' : 'is NOT', Data::Type::strlimit( $entry->object->info() );
    }

return $sum;
}

use String::ExpandEscapes;

sub pod : method
{
  my $this = shift;

  my $href = shift;

  my $escapes = {
		 e => join( ', ', $this->exported ),
		 d => $this->desc,
		 v => $this->VERSION || 'undefined',
		 u => $this->usage,
		 m => join(', ', map { "L<$_>" } $this->_depends),
		};

  my @fields;

  push @fields, '=head2 %e (since %v)', '%d';

  if( $this->usage || $this->_depends )
  {
#      $escapes->{i} = $this->info and push @fields, '%i' if $this->info;

#      $escapes->{s} = $this->summary and push @fields, '=item SUMMARY', '%s' if $this->summary;

      $escapes->{f} = join '; ', ( map { my $f = shift @$_; scalar @$_ ? "L<$f|Data::Type::Filter/$f> ".join( ', ', @$_ ) : () } $this->_filters ) and push @fields, '=head3 Filters', '%f' if $this->_filters;

      push @fields, '=head3 Usage', '%u' if $escapes->{u};

      push @fields, '=head3 Depends', '%m' if $escapes->{m};
  }

  my $fmt = join ( "\n\n", @fields )."\n\n";

  my ($result, $error) = String::ExpandEscapes::expand( $fmt, $escapes );

  Carp::croak "Illegal escape sequence $error\n" if $error;

return $result;
}

package Data::Type::Context;

	Class::Maker::class
	{
    		public =>
    		{
    			int => [qw( failed passed )],

     			scalar => [qw( value )],

     			array => [qw( types )],
    		},
	};

package Data::Type;

		# See head of file for $VERSION variable (moved because of bug in VERSION_FROM of Makefile.pl)

		# This value is important. It gets reset to undef in valid() before the test starts. During test
		# it hold the $value of the data to tested against.

	our $value;

	our @_history;

	our %_alias;       # holds alias names for type like $_alias{BIO::CODON} = 'codon';

	no strict 'refs';

        our @_locale_handles = ( 'en' );

	our $_lh = Data::Type::L18N->get_handle( @_locale_handles ) || die "What language?";

	sub lh { $_lh }

	use Data::Type::Exception;

        use Data::Type::Filter;

        use Data::Type::Facet;

		# generate Type subs

	sub current_locale
	{
    		my $this = shift;

    	return $_lh->maketext('__current_locale__');
	}

        sub set_locale : method
        {
	    my $this = shift;

            $Data::Type::_lh = Data::Type::L18N->get_handle( @_ ) || die "Locale not implented or found";
        }

        sub esc ($) { my $cpy = $_[0] || '' ; $cpy =~ s/\n/\\n/; "'".$cpy."'" }

	sub strlimit
	{
		my $limit = $_[1] || 60;

	return length( $_[0] ) > $limit ? join('', (split(//, $_[0]))[0..$limit-1]).'..' : $_[0];
	}

	sub filter : method
	{
		my $this = shift;

		foreach ( @_ )
		{
		    my ( $name, @args ) = @{$_};

		    print " " x 2;

		    my $before = $Data::Type::value;

		    "Data::Type::Filter::${name}"->filter( @args );

		    print " " x 2;

		    printf '%-20s %20s(%s) %30s => %-30s', 'FILTER', $name, join(',',@args), esc( $before), esc( $Data::Type::value) if $Data::Type::DEBUG;

		    print "\n";
		}
	}

			# Generate Type alias subs
			#
			# - Generate subs like 'VARCHAR' into this package
			# - These are then Exported
			#
			# Note that codegen is called above

	sub _gen_name
	{
		my $what = shift;

	return $Data::Type::_master_prefix.uc( $what );
	}

	sub _add_package_to_name
	{
	    my $name = shift || die "_add_package_to_name needs at least one parameter";

	return 'Data::Type::Object::'.$name;
	}

	sub _cut_package_from_name
	{
	    my $p = shift || die "_cut_package_from_name needs at least one parameter";

        return ( $p =~ /^Data::Type::Object::([^:]+)/ )[0] || die "'$p' not matchable by _cut_package_from_name";
	}

	sub _revert_alias
	{

	return exists $_alias{ shift } ? $_alias{ shift } : undef;
	}

	sub _translate
	{
		my $name = shift;

	return join ', ', $name->exported;
	}

	sub expect
	{
		my $recording = shift;

		my $expected = shift;

		foreach my $that ( @_ )
		{
		    $that = bless [ $that ], 'Data::Type::Facet::__anon' if ref($that) eq 'CODE';

		    if ( $recording )
		    {
			push @Data::Type::_history, Data::Type::Entry->new( object => $that, expected => $expected );
		    }
		    else
		    {
			Data::Type::try
			{
				$that->test;
			}
			catch Error Data::Type::with
			{
				throw Data::Type::Exception( value => $Data::Type::value, type => $that, catched => \@_ ) if $expected;
			};
		    }
		}
	}

	our $record = 0;

	sub ok { expect( $record, @_ ) }

	sub assert { println $_[0] ? '..ok' : '..nok'}

		# Tests Types

	sub valid
	{
	    $Data::Type::value = ( @_ > 1 ) ? shift : $_;

	    my $type = shift;

	    printf "%-20s %30s %-60s\n", 'VALID', esc( $Data::Type::value ), $type if $Data::Type::DEBUG;

	    die "usage: valid( VALUE, TYPE )" if @_;

	    printfln "\n\nTesting %s given '%s' (%s)", ( $type->exported )[0], $value, strlimit( $type->info ) if $Data::Type::DEBUG;

	    $type->test;
	}

		# Wrapper for dieing instead of throwing exceptions

	our @err;

	sub dvalid
	{
	    my @args = @_;

	    @err = ();

	    Data::Type::try
	    {
	      $Data::Type::value = ( @args > 1 ) ? shift @args : $_;

	      my $type = shift @args;

	      printf "%-20s %30s %-60s\n", 'DVALID', $Data::Type::value, $type if $Data::Type::DEBUG;

	      die "usage: dvalid( $Data::Type::value, $type )" if @args;

	      printfln "\n\nTesting %s given '%s' (%s)", ( $type->exported )[0], $Data::Type::value, strlimit( $type->info ) if $Data::Type::DEBUG;

	      $type->test;
	    }
	    catch Error Data::Type::with
	    {
               @err = @_;
            };

	return @err ? 0 : 1;
	}

	sub is { &dvalid }

	sub isnt { not &is }

	sub summary
	{
		@Data::Type::_history = ();

		$Data::Type::record = 1;

		$Data::Type::value = shift;

		#print Data::Dumper->Dump( [ \@_ ] );

		$_->test for @_;

		$Data::Type::record = 0;

		return @Data::Type::_history;
	}

	sub _search_pkg
	{
		my $path = '';

		my @found;

		no strict 'refs';

		foreach my $pkg ( @_ )
		{
			next unless $pkg =~ /::$/;

			$path .= $pkg;

			if( $path =~ /(.*)::$/ )
			{
				foreach my $symbol ( sort keys %{$path} )
				{
					if( $symbol =~ /(.+)::$/ && $symbol ne 'main::' )
					{
						push @found, "${path}$1";
					}
				}
			}
		}

	return @found;
	}

	sub type_list_as_packages { map { die if $_ =~ /Interface/; $_ } grep { $_ ne 'Data::Type::Object::Interface' and $_->isa( 'Data::Type::Object::Interface' ) } _search_pkg( 'Data::Type::Object::' ) }

	sub type_list { map { _cut_package_from_name($_) } type_list_as_packages() }

	sub filter_list_as_packages { grep { $_ ne 'Data::Type::Filter::Interface' and $_->isa( 'Data::Type::Filter::Interface' ) } _search_pkg( 'Data::Type::Filter::' ) }

	sub filter_list { filter_list_as_packages() }

	sub facet_list_as_packages { grep { $_ ne 'Data::Type::Facet::Interface' and $_->isa( 'Data::Type::Facet::Interface' ) } _search_pkg( 'Data::Type::Facet::' ) }

	sub facet_list { facet_list_as_packages() }

	sub l18n_list { map { /::([^:]+)$/; uc $1 } _search_pkg( 'Data::Type::L18N::' ) }

	sub _show_list
	{
		my $hash = shift;

		my $ind = shift || 2;

		my $result;

		foreach my $key (keys %$hash)
		{
			my $val = $hash->{ $key };

				# headlines

			unless( ref( $key ) )
			{
				$result .= sprintf qq|%s"%s"\n|, " " x $ind, $key;
			}
			else
			{
				$result .= sprintf qq|%s"%s"\n|, " " x $ind, $_ for @$key;
			}

				# contents

			if( ref( $val ) eq 'ARRAY' )
			{
				$result .= sprintf "\n%s  %s\n\n", " " x $ind, join( ', ', sort { $a cmp $b } @$val );
			}
			elsif( ref( $val ) eq 'HASH' )
			{
				$result .= _show_list( $val, $ind + 2 );
			}
		}

	return $result;
	}

	sub _unique_ordered
	{
		my $prev = shift;

		my @result = ( $prev );

		for ( iter \@_ )
		{
			push @result, VALUE() if VALUE() ne $prev;

			$prev = $_;
		}

	return @result;
	}

	sub toc
	{
		return '';

		my $result;

		use Tie::ListKeyedHash;

		tie my %tied_hash, 'Tie::ListKeyedHash';

		foreach my $pkg_name ( type_list_as_packages() )
		{
		  warn "$pkg_name will be reflected" if $Data::Type::DEBUG;

		  my @isa = _unique_ordered @{ Class::Maker::Reflection::inheritance_isa( @{ $pkg_name.'::ISA' } ) };

		  # this is brute and could become a trouble origin

		  @isa = grep { $_ ne 'Data::Type::Object::Interface' and $_->isa( 'Data::Type::Object::Interface' ) } @isa;

		  Carp::croak "$pkg_name has invalid isa tree with @isa" unless @isa;

		  my $special_key = [ _unique_ordered map { $_->can( 'desc' ) ?  $_->desc : () } @isa ];

		  print Data::Dumper->Dump( [ \@isa, $special_key ] ); # if $Data::Type::DEBUG;

		  $tied_hash{ $special_key } = [] unless defined $tied_hash{ $special_key };

		  push @{ $tied_hash{ $special_key } }, sprintf( '%s', _translate( $pkg_name ) );
		}

		$result .= _show_list \%tied_hash;

	return $result;
	}

		# look at sub _export below. Normally it is used to use ie. DB_VARCHAR instead of DB::VARCHAR (namespace pollution!).

	our $_reformat_name = undef;

	sub _export
	{
		my $what = shift;

		foreach my $where ( @_ )
		{
			my $c = sprintf "sub %s { Data::Type::Proxy::%s( \@_ ); };", $where, $what;

			println "_export: $c" if $Data::Type::DEBUG;

			eval $c;

			die $@ if $@;
		}
	}

	sub codegen
	{
	    my $prefix = shift;

	    warn "codegen for prefix $prefix" if $Data::Type::DEBUG;

		my @aliases;

		foreach my $type ( Data::Type::type_list() )
		{
		  printfln "generating code for %s", $type if $Data::Type::DEBUG;

		  my $p = _add_package_to_name($type)->prefix;

		  warnfln "codegen if $p eq $prefix" if $Data::Type::DEBUG > 1;

		  printfln "export if $p eq $prefix." if $Data::Type::DEBUG;

		  if( $p eq $prefix )
		  {
			printfln "exporting %S", $type if $Data::Type::DEBUG;

			_export( $type, _add_package_to_name($type)->exported );

			my @n = _add_package_to_name($type)->exported;

			push @aliases, @n;

			$_alias{$_} = $type for @n;
		  }
		}

	        if( @aliases )
		{
		    warnfln sprintf "eval: use subs qw(%s);", join ' ', @aliases if $Data::Type::DEBUG;

		    eval sprintf "use subs qw(%s);", join ' ', @aliases;

		    warn $@ if $@;
		}
	}

1;

__END__