view release on metacpan or  search on metacpan

t/base/query_switch.t  view on Meta::CPAN

# $Id: query_switch.t 484 2013-05-09 20:56:46Z whynot $
# Copyright 2012, 2013 Eric Pozharski <whynot@pozharski.name>
# GNU GPLv3
# AS-IS, NO-WARRANTY, HOPE-TO-BE-USEFUL

use strict;
use warnings;

package t::TestSuite::FSM;
use parent qw| Acme::FSM |;

sub push_push                    {
    my $bb        = shift @_;
    $bb->{MKS}    = shift @main::flags;
    $bb->{CS_RCS} = shift @_                                            if @_;
    return !0, shift @main::flags }

package t::TestSuite::switch;

sub new { bless { }, shift @_ }

sub push_push                    {
    my $bb          = shift @_;
    $bb->{jedi_vcs} = shift @main::flags;
    $bb->{gat}      = shift @_                                          if @_;
    return !0, shift @main::flags }

package main;
use version 0.77; our $VERSION = version->declare( v2.3.4 );

use t::TestSuite qw| :diag :wraps |;
use Test::More;

use Acme::FSM;
use List::Util qw| sum |;

our( $bb, $rc, $stderr );
our %st    = ( START => { switch => undef, });
my $method = q|query_switch|;

our( $lock, $tag );
our @flags =
qw| m_files     Chiocciola
    archipel  superversion
    mercurial Valdimontone
    surround_SCM     asvcs
    dcvs            Aquila
    so6            fastcst
    arx            Nicchio
    cvsnt   sourceanywhere
    opencm         Pantera
    cvs          codeville
    controltier      Torre
    rmtrcs       ic_manage |;

sub push_push                      {
    my $rc = shift @_;
    return sub                    {
    my $bb      = shift @_;
    $bb->{RCS}  = shift @main::flags;
    $bb->{CSSC} = shift @_                                              if @_;
    return $rc, shift @main::flags }}

my %plug = ( diag_level => 5 );
my $switch;

my @data =
([            q|{switch} isa (undef)|,
  [qw|                        fail |],
  sub {                  undef, { } },
  [                                 ],
  qr.\Q {START}{switch} !isa defined.                                 ],
 [                                           q|{switch} isa (SCALAR)|,
  [qw|                                                  fail noise |],
  sub {                                               \$method, { } },
  [                                                                 ],
                                                  qr.\Q isa (SCALAR)., 
  { noted => qr.(?m)\Q[query_switch]: {START}{switch} isa (SCALAR). } ],
 [                                    q|{switch} isa (Acme::FSM)|,
  [qw|                                         copy fail noise |],
  sub {                                                $bb, { } },
  [                                                             ],
                                           qr.\Q isa (Acme::FSM).,
  { noted =>
      qr.(?m)\Q[query_switch]: {START}{switch} isa (Acme::FSM). }     ],
 [  q|{switch} isa (CODE), {namespace} unset, returns TRUE, no arg|,
  [qw|                                                pass noise |],
  sub {                                      push_push( !0 ), { } },
  [                                                               ],
  sub {                       $bb->{RCS}, exists $bb->{CSSC}, $rc },
  [                                      q|m_files|, '', q|tturn| ],
  { noted => qr.(?m)\Q[query_switch]: {START}{switch} isa (CODE). }   ],
 [     q|{switch} isa (CODE), {namespace} unset, returns TRUE, arg|,
  [qw|                                                pass noise |],
  sub {                                                undef, { } },
  [qw|                                                   Civetta |],
  sub {                                @$bb{qw| RCS CSSC |}, @$rc },

t/base/query_switch.t  view on Meta::CPAN

 [q|{turns}, {switch} returns empty string, argument is set|,
  [qw|                                               pass |],
  sub {                                    sub { '' }, { } },
  [qw|                             team_foundation_server |],
  sub {                                                $rc },
  [qw|                                              turn% |]          ],
 [q|{turns}, {switch} returns nil|,
  [qw|                     pass |],
  sub {           sub { 0 }, { } },
  [                              ],
  sub {                      $rc },
  [qw|                   turn%0 |]                                    ],
 [q|{turns}, {switch} returns nil, argument is set|,
  [qw|                                      pass |],
  sub {                            sub { 0 }, { } },
  [qw|                                    siveco |],
  sub {                                       $rc },
  [qw|                                    turn%0 |]                   ],
 [q|{turns}, {switch} returns one item|,
  [qw|                          pass |],
  sub {       sub { q|opencvs| }, { } },
  [                                   ],
  sub {                           $rc },
  [qw|                  turn%opencvs |]                               ],
 [q|{turns}, {switch} returns one item, argument is set|,
  [qw|                                           pass |],
  sub {                        sub { q|opencvs| }, { } },
  [qw|                                       Perforce |],
  sub {                                            $rc },
  [qw|                                   turn%opencvs |]              ],
 [        q|{turns}, {switch} returns two items|,
  [qw|                                   pass |],
  sub { sub { qw| bitkeeper evolution | }, { } },
  [                                            ],
  sub {                                    $rc },
  [qw|                         turn%bitkeeper |]                      ],
 [q|{turns}, {switch} returns two items, argument is set|,
  [qw|                                            pass |],
  sub {          sub { qw| bitkeeper evolution | }, { } },
  [qw|                                            sccs |],
  sub {                                            @$rc },
  [qw|                        turn%bitkeeper evolution |]             ] );

plan tests => sum map          {
  ( grep( $_ eq q|pass|, @$_ ) ? 1 :
    grep( $_ eq q|fail|, @$_ ) ? 1 : 0 ) +
    grep( $_ eq q|noise|, @$_ ) }
    map {               $_->[1] } @data;

foreach my $unit ( @data )                      {
    my( $lfix, $rfix ) = $unit->[2]->();
    $st{START}{switch} = $lfix // $st{START}{switch};
    if( grep $_ eq q|copy|, @{$unit->[1]} )      {
                    AFSMTS_object_wrap $bb, $rfix }
    else                                         {
        AFSMTS_class_wrap { %plug, %$rfix }, \%st }
    AFSMTS_method_wrap $method, @{$unit->[3]};
    if( grep $_ eq q|pass|, @{$unit->[1]} )    {
        is_deeply [ $unit->[4]->() ], $unit->[5], qq|$unit->[0], queried|;
        grep $_ eq q|noise|, @{$unit->[1]}                            or next;
        like $stderr, $unit->[6]{$_}, qq|$unit->[0], $_|
                     foreach keys %{$unit->[6]} }
    elsif( grep $_ eq q|fail|, @{$unit->[1]} ) {
        like $@, $unit->[4], AFSMTS_croakson qq|$unit->[0], queried|;
        grep $_ eq q|noise|, @{$unit->[1]}                            or next;
        Test::More->can( index( $_, '-' ) ? q|like| : q|unlike| )->
        ( $stderr, $unit->[5]{$_}, qq|$unit->[0], $_| )
                     foreach keys %{$unit->[5]} }}

# vim: set filetype=perl