#!./perl

# this will be needed for inclusion in the core perl test suite
#BEGIN {
#    chdir 't' if -d 't';
#    @INC = '../lib';
#    require './test.pl';
#}

use Test::More;

use strict;
use warnings;
use Config;

my ( $UV_MAX, $UV_MIN, $IV_MAX, $IV_MIN );
$UV_MAX += 2** $_ for 0 .. 8 * $Config{uvsize} - 1; # avoid overflowing
$UV_MIN = 0;
$IV_MAX = 2**( 8 * $Config{ivsize} - 1 ) - 1;
$IV_MIN = -2**( 8 * $Config{ivsize} - 1 );
# diag "$UV_MAX $UV_MIN $IV_MAX $IV_MIN";

(my $uvuformat = "%" . $Config{uvuformat}) =~ tr/"//d;
(my $ivdformat = "%" . $Config{ivdformat}) =~ tr/"//d;

my ( $got, @got, %got );
my $true  = 1;
my $false = '';
my $zero  = 0;
my $undef = undef;

# venus
no warnings;
is( 0+ '23a',       23,   '0+' );
is( 0+ '3.00',      3,    '0+' );
is( 0+ '1.2e3',     1200, '0+' );
is( 0+ '42 EUR',    42,   '0+' );
is( 0+ 'two cents', 0,    '0+' );
ok( ( 0+ [] ) =~ /^[1-9][0-9]*$/, '0+' );
use warnings;

# baby cart
{
    local $" = ',';
    %got = ( 'a' .. 'f' );
    is( "A @{[sort keys %got]} Z", "A a,c,e Z", '@{[ ]}' );
}

# bang bang
is( !!$true,      $true,  '!!' );
is( !!$false,     $false, '!!' );
is( !!$zero,      $false, '!!' );
is( !!'a string', $true,  '!!' );
is( !!$undef,     $false, '!!' );

# key to the truth
is( 0+!!$true,      $true, '0+!!' );
is( 0+!!$false,     $zero, '0+!!' );
is( 0+!!$zero,      $zero, '0+!!' );
is( 0+!!'a string', $true, '0+!!' );
is( 0+!!$undef,     $zero, '0+!!' );

# Abbott and Costello
is_deeply( [ $true ||(), $false ||(), $undef ||(), $zero ||() ],
    [$true], '||()' );

# leaning Abbott and Costello
if( $] >= 5.010 ) {
    is_deeply( [ $true //(), $false //(), $undef //(), $zero //() ],
        [ $true, $false, $zero ], '//()' );
}

# eskimo greeting
# TODO }{

# inchworm
$got = time;
is( scalar localtime $got, ~~ localtime $got, '~~' );
@got = localtime;
is( ~~ @got, 9, '~~' );

is( ~~ 1.23, 1, '~~ exception' );    # floating point

$got = '1.23';                       # string
is( ~~ $got, 1, '~~ exception' ) if $got != 0;    # used in numeric context

$got = $UV_MAX + 1;
is( ~~ $got, sprintf($uvuformat, $UV_MAX), '~~ exception' );
$got = -1;
is( ~~ $got, sprintf($uvuformat, $UV_MAX), '~~ exception' );

$got = 2**( 8 * $Config{uvsize} - 1 );
{
    use integer;
    is( ~~ $got, sprintf($ivdformat, $IV_MIN), '~~ exception' );
}
$got = -2**( 8 * $Config{uvsize} - 1 ) - 1;
{
    use integer;
    is( ~~ $got, sprintf($ivdformat, $IV_MIN), '~~ exception' );
}

# TODO
# show overloading "" example

# backward inchworm on a stick
for my $val ( $IV_MAX, $IV_MIN + 1, 0, 1, -1 ) {
    $got = $val;
    if( $val <= 0 ) {
        use integer;
        is( ~- $got, $val - 1, '~-' );
    }
    elsif( $Config{'use64bitint'} ) {
        TODO: {
            local $TODO = 'fails with use64bitint';
            is( ~- $got, $val - 1, '~-' ); # TODO
        }
    }
    else {
        is( ~- $got, $val - 1, '~-' );
    }
}

# forward inchworm on a stick
for my $val ( $IV_MAX -1 , $IV_MIN, 0, 1, -1 ) {
    $got = $val;
    if( $val >= 0 ) {
        use integer;
        is( -~ $got, $val + 1, '-~' );
    }
    elsif( $Config{'use64bitint'} ) {
        TODO: {
            local $TODO = 'fails with use64bitint';
            is( -~ $got, $val + 1, '-~' );
        }
    }
    else {
        is( -~ $got, $val + 1, '-~' );
    }
}


    # $y = ~-$x * 4;    # identical to $y = ($x-1)*4;

# Exceptions

# space station
no warnings;
is( -+- '23a',       23,   '-+-' );
is( -+- '3.00',      3,    '-+-' );
is( -+- '1.2e3',     1200, '-+-' );
is( -+- '42 EUR',    42,   '-+-' );
ok( ( -+- [] ) =~ /^[1-9][0-9]*$/, '-+-' );
use warnings;

is( -+- 'two cents', '+two cents',    '-+- exception' );
is( -+- '-2B' x 5, '-2B-2B-2B-2B-2B', '-+- exception' );

# goatse
my $n;
$_ = "word2 and word3";
$n =()= /word1|word2|word3/g;
is( $n, 2, '=()=' );
$n =()= "abababab" =~ /a/;
is( $n, 1, '=()=' );
$n =()= "abababab" =~ /a/g;
is( $n, 4, '=()=' );
$n =($got)= "abababab" =~ /a/g;
is( $n, 4, '=()=' );
is( $got, 'a', '=()=' );
$n =(@got)= "abababab" =~ /a/g;
is( $n, 4, '=()=' );
is( "@got", 'a a a a', '=()=' );

# right-handed goatse
{
    my @a = ( [], [1], [ 1, 2 ], [], [ 5 .. 9 ], [] );
    is_deeply( [ grep +()= @$_, @a ], [ [1], [ 1, 2 ], [ 5 .. 9 ] ], '()=' );
}

# goatse + split
$n =()= @{[ split /:/, "a:a:a:a" ]};
is( $n, 4, "=()= split" );
$n =()= split /:/, "a:a:a:a", -1;
is( $n, 4, "=()= split" );

# flaming xwing
@got =<DATA>=~ /(\d+) is (\w+)/;
is( "@got", '31337 eleet', '=<>=~' );

# kite
@got = ( ~~<DATA>, ~~<DATA> );
is( "@got", "camel\n llama\n", '~~<>' );
@got = ( ~~<DATA> );     # return '' instead of undef at EOF
is( "@got", '', '~~<>' );

# ornate double-bladed sword
$got = 1;

<<m=~m>>

# this is not code
# and should never be run
$got = 0;

m
;

ok( $got, '<<=~m>> m ;' );


# screwdrivers
for my $val ( -1, 0, 1, 1.5, -1.5, -0.5 ) {
   my $val_plus_1  = $val + 1;
   my $val_minus_1 = $val - 1;

   # flathead long handle
   ($got = $val ) -=!! $true;
   is( $got, $val_minus_1, '-=!!' );
   ($got = $val ) -=!! $false;
   is( $got, $val, '-=!!' );

   # flathead short handle
   ($got = $val ) -=! $true;
   is( $got, $val, '-=!' );
   ($got = $val ) -=! $false;
   is( $got, $val_minus_1, '-=!' );

   # phillips long handle
   ($got = $val ) +=!! $true;
   is( $got, $val_plus_1, '+=!!' );
   ($got = $val ) +=!! $false;
   is( $got, $val, '+=!!' );

   # phillips short handle
   ($got = $val ) +=! $true;
   is( $got, $val, '+=!' );
   ($got = $val ) +=! $false;
   is( $got, $val_plus_1, '+=!' );

   # torx long handle
   ($got = $val ) *=!! $true;
   is( $got, $val, "$val *=!! true" );

SKIP: {
    skip '*=!! and *=! broken with negative != -1 on perl <= 5.013005', 2
       if $val < 0 && $val != -1 && $] <= 5.013005;
    ( $got = $val ) *=!! $false;
    is( $got, 0, "$val *=!! false" );

   # torx short handle
   ($got = $val ) *=! $true;
   is( $got, 0, "$val *=! true" );
}
   ($got = $val ) *=! $false;
   is( $got, $val, "$val *=! false" );

   # pozidriv long handle
   ($got = $val ) x=!! $true;
   is( $got, $val . '' , 'x=!!' );
   ($got = $val ) x=!! $false;
   is( $got, '', 'x=!!' );

   # pozidriv short handle
   ($got = $val ) x=! $true;
   is( $got, '', 'x=!' );
   ($got = $val ) x=! $false;
   is( $got, $val . '', 'x=!' );
}


# Winking fat comma
sub APPLE  () { 1 }
sub CHERRY () { 2 }
sub BANANA () { 3 }
%got = (
  APPLE   ,=>  "green",
  CHERRY  ,=>  "red",
  BANANA  ,=>  "yellow",
);
is( "@{[ sort keys %got ]}", '1 2 3', ',=>' );

# Enterprise
%got = (
    apples   => 3,
    bananas  => 1,
    cherries => 41,
    gin      => 1,
);
@got = (
    'bread',
    'milk',
   ('apples'  )x!! ( $got{apples} < 2 ),
   ('bananas' )x!! ( $got{bananas} < 2 ),
   ('cherries')x!! ( $got{cherries} < 20 ),
   ('tonic'   )x!! $got{gin},
);
is( "@got", "bread milk bananas tonic", '()x!!' );

# space fleet
no warnings;
is( <=><=><=>, 0, '<=><=><=>' );
use warnings;

# amphisbaena
# TODO <~>

done_testing;

__DATA__
31337 is eleet
camel
llama