File Coverage

blib/lib/Prolog/Utility/FromPerl.pm

Criterion	Covered	Total	%
statement	67	90	74.4
branch	24	46	52.1
condition	3	12	25.0
subroutine	12	13	92.3
pod	5	8	62.5
total	111	169	65.6

package Prolog::Utility::FromPerl;

use warnings;
use strict;

use version;

our $VERSION = qv('1.0.2');

use Regexp::Common qw(balanced);

use base qw(Exporter);

our @EXPORT = qw(printable_prolog chain_terms prolog_term prolog_hash prolog_list);


sub printable_prolog {

 my $prolog = shift;

 return $prolog if !defined($prolog);

 if(ref($prolog) eq 'SCALAR') {

    ${$prolog} .= '.' if ${$prolog} !~ /\.$/;

 } elsif(ref(\$prolog) eq 'SCALAR') {
    $prolog .= '.' if $prolog !~ /\.$/;
 }

 return $prolog;

}

sub chain_terms {

  my @terms = ();

  if(scalar(@_) == 1 && ref($_[0]) eq 'ARRAY') {

    @terms = @{$_[0]};

  } else {

    @terms = @_;

  }

  return printable_prolog( join(',',map { s/\.$//g; $_; } grep { defined($_) } @terms ) );

}

sub prolog_term {

  my @nested = caller(1);

  my $term = shift;

  my $prolog = $term .  '(';

  foreach my $value (@_) {

    if(ref($value)) {

        $prolog .= convert_ref_to_prolog($value);

    } else {

        if(ref(\$value) ne 'SCALAR') {

            $prolog .= convert_ref_to_prolog(\$value);

        } else {

            $prolog .= quote_prolog_value($value) . ',';

        }

    }

  }

  if( scalar(@nested) > 0 ) {

    $prolog =~ s/,$//g;

    return $prolog . ')';

 } else {

    return add_prolog_term_end($prolog);

  }

}


sub add_prolog_term_end {

  my $partial_prolog_string = shift;

  $partial_prolog_string =~ s/,$//g;

  my $PATTERN = $RE{balanced};

  my @parts = ($partial_prolog_string =~ /$PATTERN/g);

  if( scalar(@parts) > 1 ) {

    $partial_prolog_string .= ')';

  } elsif(scalar(@parts) == 1 && length($partial_prolog_string) < length($parts[1])) {

    $partial_prolog_string .= ')';

  } else {

    if($partial_prolog_string =~ /\(/ && $partial_prolog_string !~ /\)/) {

        $partial_prolog_string =~ s/,$//g;

        $partial_prolog_string .= ')';

    }

  }

  return $partial_prolog_string;

}

sub convert_ref_to_prolog {

  my $ref = shift;

  if(ref($ref) eq 'ARRAY') {

    return prolog_list($ref);

  } elsif(ref($ref) eq 'HASH') {

    return prolog_hash($ref);

  } elsif(ref($ref) eq 'SCALAR') {

    return quote_prolog_value(${$ref});

  } else {

    die(ref($ref) . ' unsuppored reference' . "\n");

  }

}

sub prolog_list {

 my @list = ();

 if(ref($_[0])) {

    @list = @{$_[0]};

 } else {

    @list = @_;

 }

 return '[' . join(',',map { if(defined($_)) { quote_prolog_value($_); } else { "'nil'"; } } @list) . ']';

}

sub prolog_hash {

  my %hash;

  if(ref($_[0])) {

        %hash = %{$_[0]};

  } else {

        %hash = @_;

  }

  my $sort = delete $hash{_SORT};

  if(defined($sort) && ref($sort) eq 'ARRAY') {

    return join(',',map { prolog_term($_,$hash{$_}); } grep { exists($hash{$_}) } @$sort);

  } else {

    return join(',',map { prolog_term($_,$hash{$_}); } sort keys %hash);

  }

}

sub quote_prolog_value {

  my $value = shift;

  return $value if $value =~ /\(/;

  return $value if $value =~ /^[a-z]+[a-z0-9]+$/;

  return $value if $value =~ /^\d+(\.\d+)?$/;

  return $value if $value eq '[]';

  return "'" . $value . "'";

}


1; # Magic true value required at end of module
__END__