File Coverage

blib/lib/Language/Prolog/Sugar.pm

Criterion	Covered	Total	%
statement	24	101	23.7
branch	1	38	2.6
condition	0	3	0.0
subroutine	8	22	36.3
pod	0	1	0.0
total	33	165	20.0

package Language::Prolog::Sugar;

our $VERSION = '0.06';

use strict;
use warnings;

use Carp qw(carp croak);
use Language::Prolog::Types ':ctors';


sub export {
    my ($sub, $pkg, $name)=@_;
    no strict 'refs';
    *{$pkg.'::'.$name}=$sub;
}

sub import {
    my $class=shift;
    my $to=caller
	or die "unable to infer importer package";
    while(@_) {
	my $key=shift;
	if ($key eq 'vars' or $key eq 'variables') {
	    my $vars=shift;
	    if (ref $vars eq 'ARRAY') {
		foreach (@{$vars}) {
		    my $var=prolog_var($_);
		    export sub () { $var }, $to, $_;
		}
	    }
	    elsif (ref $vars eq 'HASH') {
		foreach my $name (keys %{$vars}) {
		    my $var=prolog_var($name);
		    export sub () { $var }, $to, $name;
		}
	    }
	    else {
		croak "invalid argument '$vars' for $key option";
	    }
	}
	elsif ($key eq 'functors') {
	    my $functors=shift;
	    if (ref $functors eq 'ARRAY') {
		foreach (@{$functors}) {
		    my $functor=$_;
		    export sub {
			prolog_functor($functor, @_);
		    }, $to, $functor;
		}
	    }
	    elsif (ref $functors eq 'HASH') {
		foreach my $name (keys %{$functors}) {
		    my $functor=$functors->{$name};
		    export sub {
			prolog_functor($functor, @_);
		    }, $to, $name;
		}
	    }
	    else {
		croak "invalid argument '$functors' for $key option";
	    }
	}
	elsif ($key eq 'atoms') {
	    my $atoms=shift;
	    if (ref $atoms eq 'ARRAY') {
		foreach (@{$atoms}) {
		    my $atom=$_;
		    export sub () { $atom }, $to, $atom;
		}
	    }
	    elsif (ref $atoms eq 'HASH') {
		foreach my $name (keys %{$atoms}) {
		    my $atom=$atoms->{$name};
		    export sub () { $atom }, $to, $name;
		}
	    }
	    else {
		croak "invalid argument '$atoms' for $key option";
	    }
	}
	elsif ($key eq 'chains') {
	    my $chains=shift;
	    if (ref $chains eq 'ARRAY') {
		foreach (@{$chains}) {
		    my $chain=$_;
		    export sub {
			prolog_chain($chain, @_);
		    }, $to, $chain;
		}
	    }
	    elsif (ref $chains eq 'HASH') {
		foreach my $name (keys %{$chains}) {
		    my $chain=$chains->{$name};
		    export sub {
			prolog_chain($chain, @_);
		    }, $to, $name;
		}
	    }
	    else {
		croak "invalid argument '$chains' for $key option";
	    }
	}
        elsif ($key eq 'auto_functor') {
            carp "Language::Prolog::Sugar auto_functor has been obsoleted";
            export \&_auto_functor, $to, 'AUTOLOAD';
        }
        elsif ($key eq 'auto_term') {
            export \&_auto_term, $to, 'AUTOLOAD';
        }
	else {
	    croak "Unknow option '$key'";
	}
    }
}

our $AUTOLOAD;
sub _auto_functor {
    my ($pkg, $name) = $AUTOLOAD =~ /(?:(.*)::)?(.*)/;
    $pkg = 'main' unless length $pkg;
    $name =~ /^[A-Z]/
        and croak "invalid functor name '$name': starts with uppercase";

    export sub { prolog_functor($name, @_) }, $pkg, $name;

    no strict 'refs';
    goto &$AUTOLOAD
}

sub _auto_term {
    my ($pkg, $name) = $AUTOLOAD =~ /(?:(.*)::)?(.*)/;
    $pkg = 'main' unless length $pkg;
    if ($name =~ /^[A-Z]/) {
        my $var = prolog_var $name;
        my $sub = sub () { $var };
        export $sub, $pkg, $name;
    }
    else {
        export sub { prolog_functor($name, @_) }, $pkg, $name;
    }

    no strict 'refs';
    goto &$AUTOLOAD
}

1;
__END__