package Text::Wigwam::Library::Comparators;

    use strict;
    use warnings;
    no warnings q/recursion/;
    no warnings 'uninitialized';
    our $VERSION = '0.01';

    use base q/Exporter/;

    use Text::Wigwam::Const qw/ BOOLEAN VAR ANY STRING ARRAY /;

    our %EXPORT_TAGS = (
        all => [
          qw/
            _proto_and     _and
            _proto_cmp     _cmp
            _proto_eq      _eq
            _proto_ge      _ge
            _proto_grep    _grep
            _proto_gt      _gt
            _proto_in      _in
            _proto_le      _le
            _proto_lt      _lt
            _proto_ne      _ne
            _proto_ni      _ni
            _proto_not     _not
            _proto_or      _or
            _proto_regex   _regex
            _proto_replace _replace
            _proto_sgrep   _sgrep
            _proto_xor     _xor
          /
        ],
        and     => [ qw/ _proto_and     _and / ],
        cmp     => [ qw/ _proto_cmp     _cmp / ],
        eq      => [ qw/ _proto_eq      _eq / ],
        ge      => [ qw/ _proto_ge      _ge / ],
        grep    => [ qw/ _proto_grep    _grep / ],
        gt      => [ qw/ _proto_gt      _gt / ],
        in      => [ qw/ _proto_in      _in / ],
        le      => [ qw/ _proto_le      _le / ],
        lt      => [ qw/ _proto_lt      _lt / ],
        ne      => [ qw/ _proto_ne      _ne / ],
        ni      => [ qw/ _proto_ni      _ni / ],
        not     => [ qw/ _proto_not     _not / ],
        or      => [ qw/ _proto_or      _or / ],
        regex   => [ qw/ _proto_regex   _regex / ],
        replace => [ qw/ _proto_replace _replace / ],
        sgrep   => [ qw/ _proto_sgrep   _sgrep / ],
        xor     => [ qw/ _proto_xor     _xor / ],
    );

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


=head1 Name

Text::Wigwam::Library::Comparators - A Wigwam directive library.

=head1 Description

This library provides directives which are useful for comparing and testing
values.

=head1 Usage

The directives within this library can be imported into specific branches of
the directive tree (which transcends from  C<Text::Wigwam::Directives>) via
plug-ins or modules using one of the following techniques.

 package Text::Wigwam::Directives::some::arbitrary::branch;
 # import everything
 use Text::Wigwam::Library::Comparators qw/:all/;

 package Text::Wigwam::Directives::another::arbitrary::branch;
 # import selectively
 use Text::Wigwam::Library::Comparators(
  qw/ :and :cmp :eq :ge :gt :in :le :lt :ne :ni :not :or :xor /
 );

=head1 Directives

=cut

sub _proto_and { [ ANY, ANY ] }
sub _and {
    my ($Api) = @_;
    return $Api->get_arg
        if is_true($Api, my $val = $Api->get_arg);
    $Api->kill_arg(1);
    return $val;
}

sub is_true {
    my ($Api, $val) = @_;
    return $Api->is_num($val) ? $val+0 : $val;
}

=head2 #and I<arg1> I<arg2>

Returns the value of I<arg1> if it's false, otherwise returns the value of
I<arg2>.

 [!! #and 1 2 /* output: 2 */ !!]

The C<#and> directive's short-circuit behavior can be used to perform some
simple in-line logic functions.

[!!
 #define params < 1 1 0 1 0 1 0 0 1 >
 #define true_count 0
 #while params
   #push list
     #and
      #shift params
      #incr true_count
 #join ", " list
 /* output: 
  1, 2, 0, 3, 0, 4, 0, 0, 5
 */
!!]

=cut

sub _proto_cmp { [ STRING, STRING ] }
sub _cmp {
    my ($Api) = @_;
    my $var1 = $Api->get_arg;
    my $var2 = $Api->get_arg;
    return ($Api->is_num($var1) && $Api->is_num($var2)) ?
      $var1 <=> $var2 : $var1 cmp $var2
    ;
}

=head2 #cmp I<arg1> I<arg2>

Returns a signed value which represents how I<arg1> compares to I<arg2>.
Zero is equal, -1 is less than, +1 is greater than.

 [!!
  #given #cmp x y {
    #when 0  "x and y are equal"
    #when 1  "x is greater than y"
    #when -1 "x is less than y"
  }
 !!]

=cut

sub _proto_eq { [ STRING, STRING ] }
sub _eq {
    my ($Api) = @_;
    my $var1 = $Api->get_arg;
    my $var2 = $Api->get_arg;
    return ($Api->is_num($var1) && $Api->is_num($var2)) ?
      $var1 == $var2 : $var1 eq $var2
    ;
}

=head2 #eq I<arg1> I<arg2>

Returns true if I<arg1> is equal to I<arg2>.

 [!!
  #if #eq { "b" "a" "r" } "bar" { "bar equals \"bar\"" }
  /* output:
   bar equals "bar"
  */
 !!]

Numeric values are auto-detected, and the appropriate comparison operation is
performed on the arguments.

 [!! #if #eq 1 "1.00" "True" /* output: True */ !!]

=cut

sub _proto_ge { [ STRING, STRING ] }
sub _ge {
    my ($Api) = @_;
    my $var1 = $Api->get_arg;
    my $var2 = $Api->get_arg;
    return ($Api->is_num($var1) && $Api->is_num($var2)) ?
      $var1 >= $var2 : $var1 ge $var2
    ;
}

=head2 #ge I<arg1> I<arg2>

Returns true if I<arg1> is greater than or equal to I<arg2>.

 [!! #if #ge grades.[student].gpa requirements.gpa.pass "Failing" !!]

Numeric values are auto-detected, and the appropriate comparison operation is
performed on the arguments.

 [!! #if #ge "0.10" "1.0E-1" "True" /* output: True */ !!]

=cut

sub _proto_gt { [ STRING, STRING ] }
sub _gt {
    my ($Api) = @_;
    my $var1 = $Api->get_arg;
    my $var2 = $Api->get_arg;
    return ($Api->is_num($var1) && $Api->is_num($var2))
      ? $var1 > $var2 : $var1 gt $var2
    ;
}

=head2 #gt I<arg1> I<arg2>

Returns true if I<arg1> is greater than I<arg2>.

 [!!
  #if #gt #reactor::actual_temp reactor.limits.max {
   "Shutting down!"
   #reactor::shutdown
  }
  /* Note: Please don't use Wigwam to control a nuclear reactor. Thx! */
 !!]

Numeric values are auto-detected, and the appropriate comparison operation is
performed on the arguments.

 [!! #if #gt 1 "1.0E-1" "True" /* output: True */ !!]

=cut

sub _proto_in { [ STRING, STRING ] }
sub _in {
    my ($Api) = @_;
    my $var1 = $Api->get_arg;
    my $var2 = $Api->get_arg;
    return $var1 =~ /$var2/is;
}

=head2 #in I<arg1> I<arg2>

Performs a non case-sensitive search for I<arg2> within I<arg1> and returns
true if it was found.

 [!! #if #in ENV.REMOTE_ADDR "^10\.1\.0\." "Local IP" !!]

=cut

sub _proto_le { [ STRING, STRING ] }
sub _le {
    my ($Api) = @_;
    my $var1 = $Api->get_arg;
    my $var2 = $Api->get_arg;
    return ($Api->is_num($var1) && $Api->is_num($var2))
      ? $var1 <= $var2 : $var1 le $var2
    ;
}

=head2 #le I<arg1> I<arg2>

Returns true if I<arg1> is less than or equal to I<arg2>.

 [!!
  #if #le "foo" "fuu" "foo is less than or equal to fuu"
  /* output:
   foo is less than or equal to fuu
  */
 !!]

Numeric values are auto-detected, and the appropriate comparison operation is
performed on the arguments.

 [!! #if #le "001.0E-1" "0.1" "True" /* output: True */ !!]

=cut

sub _proto_lt { [ STRING, STRING ] }
sub _lt {
    my ($Api) = @_;
    my $var1 = $Api->get_arg;
    my $var2 = $Api->get_arg;
    return ($Api->is_num($var1) && $Api->is_num($var2)) ?
      $var1 < $var2 : $var1 lt $var2
    ;
}

=head2 #lt I<arg1> I<arg2>

Returns true if I<arg1> is less than I<arg2>.

 [!!
  #if #lt "aardvark" "bismuth" { "aardvark is less than bismuth" }
  /* output:
   aardvark is less than bismuth
  */
 !!]

Numeric values are auto-detected, and the appropriate comparison operation is
performed on the arguments.

 [!! #if #lt 1E-1 "1.00" "True" /* output: True */ !!]

=cut

sub _proto_ne { [ STRING, STRING ] }
sub _ne {
    my ($Api) = @_;
    my $var1 = $Api->get_arg;
    my $var2 = $Api->get_arg;
    return ( $Api->is_num($var1) && $Api->is_num($var2) ) ?
      $var1 != $var2 : $var1 ne $var2
    ;
}

=head2 #ne I<arg1> I<arg2>

Returns true if I<arg1> is not equal to I<arg2>.

 [!!
  #if #ne "foo" "bar" { '"foo" does not equal "bar"' }
  /* output:
   "foo" does not equal "bar"
  */
 !!]

Numeric values are auto-detected, and the appropriate comparison operation is
performed on the arguments.

 [!! #if #ne 100 "+1.00E2" "Different" #else "Same" /* output: Same */ !!]

=cut

sub _proto_ni { [ STRING, STRING ] }
sub _ni {
    my ($Api) = @_;
    my $var1 = $Api->get_arg;
    my $var2 = $Api->get_arg;
    return $var1 !~ /$var2/is;
}

=head2 #ni I<arg1> I<arg2>

Performs a non case-sensitive search for I<arg2> within I<arg1> and returns
true if it was not found.

 [!! #if #ni ENV.REMOTE_ADDR "^10\.1\.0\." "Remote IP" !!]

=cut

sub _proto_not { [ BOOLEAN ] }
sub _not {
    my ($Api) = @_;
    return !$Api->get_arg;
#    return ! is_true($Api, $Api->get_arg)
}

=head2 #not I<arg>

Returns the negated logical value of I<arg>.

 [!! #if #not #xor a b "a and b are logically identical" !!]

=cut

sub _proto_or { [ ANY, ANY ] }
sub _or {
    my ($Api) = @_;
    return $Api->get_arg unless is_true($Api, my $val = $Api->get_arg);
    $Api->kill_arg(1);
    return $val;
}

=head2 #or I<arg1> I<arg2>

Returns I<arg1> and destroys I<arg2> if I<arg1> is true. Otherwise, returns
I<arg2>.

 [!! #or 0 3 /* output: 3 */ !!]

The C<#or> directive provides "short-circuit" behavior which is useful for
subverting C<#if>/C<#else> blocks in some simpler logic situations, as
demonstrated below.

 [!!
  #define foo "bar"
  #define quux #or foo "bazz"
  'foo is "' foo '", and quux is "' quux '"'
  /* output:
   foo is "bar", and quux is "bar"
  */
 !!]

=cut

sub _proto_replace { [ VAR, STRING, STRING ] }
sub _replace {
    my ($Api, $lcontx, $vcontx) = @_;
    my $var = $Api->get_arg;
    my $sch = $Api->get_arg;
    my $rep = $Api->get_arg;
    my $str = $Api->get_value( $var );

    if( $vcontx ){
        $str =~ s/$sch/$rep/g;
        $Api->set_value( $var, $str );
        return;
    }
    if( $lcontx ){
        my $val = [ $str =~ s/$sch/$rep/g ];
        $Api->set_value( $var, $str );
        return $val;
    }
    $str =~ s/$sch/$rep/g;
    return $Api->set_value( $var, $str );
}

sub _proto_regex { [ STRING, STRING ] }
sub _regex {
    my ($Api, $lcontx) = @_;
    my $str = $Api->get_arg;
    my $rgx = $Api->get_arg;
    return [ $str =~ /$rgx/g ] if $lcontx;
    return $str =~ /$rgx/;
}

=head2 #regex I<string> I<regex>

Performs the I<regex> on I<string> and returns a list of results when called
in array context. Otherwise, returns a boolean value which represents whether
or not the pattern matched.

 [!! #join ", " #grep 'f.' < fe fi fo fum > /* scalar context */ !!]
 [!! #params < path fname > #regex filespec '^(.*\\/)(.*)$' !!]

=cut

sub _proto_grep { [ STRING, ARRAY ] }
sub _grep {
    my ($Api) = @_;
    my $rgx = $Api->get_arg;
    my $arr = $Api->get_arg;
    return [ grep /$rgx/, @$arr ];
}

=head2 #grep I<string> I<array>

Returns a list of values from I<array> that match regular expression
I<string>.

=cut

sub _proto_sgrep { [ STRING, ARRAY ] }
sub _sgrep {
    my ($Api) = @_;
    my $srch = $Api->get_arg;
    my $arr = $Api->get_arg;
    return [ grep s/$srch/$1/, grep /./, @$arr ];
}

=head2 #sgrep I<string> I<array>

Returns a list of values from I<array> that match regular expression
I<string> and replaces each match with value captured by the regex.

=cut

sub _proto_xor { [ BOOLEAN, BOOLEAN ] }
sub _xor {
    my ($Api) = @_;
    return $Api->get_arg ^ $Api->get_arg;
}

=head2 #xor I<arg1> I<arg2>

Returns true if I<arg1> and I<arg2> are logically different, in that one
argument evaluates to true, and the other evaluates to false.

 [!!
  #define answers ( 1 0 1 0 1 0 1 0 )
  #define quiz    ( 1 1 0 1 1 0 1 1 )
  #define prob 0
  #while #lt prob @answers {
    prob " is " #ifelse #xor answers:[prob] quiz:[prob] "Wrong\n" "Correct\n"
    #inc prob
  }
 /* output:
   0 is Correct
   1 is Wrong
   2 is Wrong
   3 is Wrong
   4 is Correct
   5 is Correct
   6 is Correct
   7 is Wrong
 */
 !!]

=cut

1;
