File Coverage

lib/Class/Dot/Types.pm

Criterion	Covered	Total	%
statement	75	78	96.1
branch	20	26	76.9
condition	1	3	33.3
subroutine	25	25	100.0
pod	8	8	100.0
total	129	140	92.1

# $Id: Dot.pm 28 2007-10-29 17:35:27Z asksol $
# $Source: /opt/CVS/Getopt-LL/lib/Class/Dot.pm,v $
# $Author: asksol $
# $HeadURL: https://class-dot.googlecode.com/svn/class-dot/lib/Class/Dot.pm $
# $Revision: 28 $
# $Date: 2007-10-29 18:35:27 +0100 (Mon, 29 Oct 2007) $
package Class::Dot::Types;

use strict;
use warnings;
use version qw(qv);
use 5.006000;

use Carp qw(croak);

our $VERSION   = qv('1.5.0');
our $AUTHORITY = 'cpan:ASKSH';

our @STD_TYPES = qw(
    isa_String isa_Int isa_Array isa_Hash
    isa_Data isa_Object isa_Code isa_File
);

my @EXPORT_OK = @STD_TYPES;

my %EXPORT_CLASS = (
   ':std'  => [@EXPORT_OK],
);

our %__TYPEDICT__ = (
   'Array'     => \&isa_Array,
   'Code'      => \&isa_Code,
   'Data'      => \&isa_Data,
   'File'      => \&isa_File,
   'Hash'      => \&isa_Hash,
   'Int'       => \&isa_Int,
   'Object'    => \&isa_Object,
   'String'    => \&isa_String,
);

sub import { ## no critic
    my $this_class   = shift;
    my $caller_class = caller;

    my $export_class;
    my @subs;
    for my $arg (@_) {
        if ($arg =~ m/^:/xms) {
            croak(   'Only one export class can be used. '
                    ."(Used already: [$export_class] now: [$arg])")
                if $export_class;

            $export_class = $arg;
        }
        else {
            push @subs, $arg;
        }
    }

    my @subs_to_export
        = $export_class && $EXPORT_CLASS{$export_class}
        ? (@{ $EXPORT_CLASS{$export_class} }, @subs)
        : @subs;

    no strict 'refs'; ## no critic;
    for my $sub_to_export (@subs_to_export) {
        _install_sub_from_class($this_class, $sub_to_export => $caller_class);
    }

    return;
}

sub _install_sub_from_class {
    my ($pkg_from, $sub_name, $pkg_to) = @_;
    my $from = join q{::}, ($pkg_from, $sub_name);
    my $to   = join q{::}, ($pkg_to,   $sub_name);

    no strict 'refs'; ## no critic
    *{$to} = *{$from};

    return;
}


sub isa_String { ## no critic
    my ($default_value) = @_;

    return sub {
        return $default_value
            if defined $default_value;
        return;
    };
}

sub isa_Int    { ## no critic
    my ($default_value) = @_;

    return sub {
        return $default_value
            if defined $default_value;
        return;
    };
}

sub isa_Array  { ## no critic
    my @default_values = @_;

    return sub {
        return scalar @default_values
            ? \@default_values
            : [ ];
    };
}

sub isa_Hash   { ## no critic
    my %default_values = @_;

    return sub {
        return scalar keys %default_values
            ? \%default_values
            : { };

        # have to test if there are any entries in the hash
        # so we return a new anonymous hash if it ain't.
    };
}

sub isa_Data   { ## no critic
    my ($default_value) = @_;

    return sub {
        return $default_value
            if defined $default_value;
        return;
    };
}

sub isa_Code (;&;) { ## no critic
    my $code_ref = shift;

    return sub {
        return defined $code_ref ? $code_ref : sub { };
    }
}

sub isa_File   { ## no critic
    my $filehandle = shift;

    return sub {
        if (defined $filehandle) {
            return $filehandle;
        }
        else {
            require FileHandle;
            return FileHandle->new( );
        }
    }
}

sub isa_Object { ## no critic
    my $class = shift;
    my %opts;
    if (!scalar @_ % 2) {
        %opts = @_;
    }
    return sub {
        return if not defined $class;
        if ($opts{auto}) {
            return        $class->new();
        }
        return;
    };
}

1;

__END__