Acme-FSM
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 },
[qw| archipel Civetta tturn superversion |],
{ noted => qr.(?m)\Q[query_switch]: {START}{switch} isa (CODE). } ],
[ q|{switch} isa (CODE), {namespace} unset, returns FALSE, no arg|,
[qw| pass noise |],
sub { push_push( !1 ), { } },
[ ],
sub { $bb->{RCS}, exists $bb->{CSSC}, $rc },
[ q|mercurial|, '', q|fturn| ],
{ noted => qr.(?m)\Q[query_switch]: {START}{switch} isa (CODE). } ],
[ q|{switch} isa (CODE), {namespace} unset, returns FALSE, arg|,
[qw| pass noise |],
sub { undef, { } },
[qw| Onda |],
sub { @$bb{qw| RCS CSSC |}, @$rc },
[qw| surround_SCM Onda fturn asvcs |],
{ noted => qr.(?m)\Q[query_switch]: {START}{switch} isa (CODE). } ],
[ q|{switch} isa (CODE), {namespace} isa set|,
[qw| pass noise |],
sub { push_push( !0 ), { namespace => q|vesta| } },
[ ],
sub { $bb->{RCS}, exists $bb->{CSSC}, $rc },
[ q|dcvs|, '', q|tturn| ],
{ noted => qr.(?m)\Q[query_switch]: {START}{switch} isa (CODE). } ],
[ q|{switch} isa (CODE), {namespace} isa set, argument isa set|,
[qw| pass noise |],
sub { undef, { namespace => q|vesta| } },
[qw| allfusion_harvest_change_manager |],
sub { @$bb{qw| RCS CSSC |}, @$rc },
[qw| so6 allfusion_harvest_change_manager tturn fastcst |],
{ noted => qr.(?m)\Q[query_switch]: {START}{switch} isa (CODE). } ],
[ q|{switch} isa (), {namespace} !isa defined|,
[qw| fail noise |],
sub { q|snapshotcm|, { } },
[ ],
qr.\Q {namespace} !isa defined.,
{ noted => qr.(?m)\Q[query_switch]: {START}{switch} isa (). }, ],
[ q|{switch} !isa defined method, {namespace} eq ()|,
[qw| fail noise noise |],
sub {
$t::TestSuite::class_cheat = q|t::TestSuite::FSM|;
q|hsup_hsup|, { namespace => '' } },
[ ],
qr.\Q <t::TestSuite::FSM> can't [hsup_hsup] method .,
{ defaulting => qr.(?xm)\[query_switch\]:\s
defaulting\s\{START\}\{switch\}\sto\s\x24self.,
defaulted => qr.(?xm)\[query_switch\]:\s
\{namespace\}\sisa\s\(t::TestSuite::FSM\). } ],
[ q|{switch} isa defined method, {namespace} eq ()|,
[qw| pass noise |],
sub { q|push_push|, { namespace => '' } },
[ ],
sub { $bb->{MKS}, exists $bb->{CS_RCS}, $rc },
[ q|arx|, '', q|tturn| ],
{ noted => qr.(?xm)\[query_switch\]:\s
going\sfor\s<t::TestSuite::FSM>->\[push_push\]. } ],
[q|{switch} isa defined method, {namespace} eq (), argument is set|,
[qw| pass noise |],
sub { undef, { namespace => '' } },
[qw| darcs |],
sub { @$bb{qw| MKS CS_RCS |}, @$rc },
[qw| cvsnt darcs tturn sourceanywhere |],
{ noted => qr.(?xm)\[query_switch\]:\s
going\sfor\s<t::TestSuite::FSM>->\[push_push\]. } ],
[ q|{switch} !isa defined method, | .
q|{namespace} isa (t::TestSuite::switch)|,
[qw| fail noise noise |],
sub {
$switch = t::TestSuite::switch->new;
undef $t::TestSuite::class_cheat;
q|hsup_hsup|, { namespace => $switch } },
[ ],
qr.\Q <t::TestSuite::switch> can't [hsup_hsup] method .,
{ -misdefaulting => qr.(?xm)\[query_switch\]:\s
defaulting\s\{switch\}\sto\s\x24self.,
noted => qr.(?xm)\[query_switch\]:\s
\{namespace\}\sisa\s\(t::TestSuite::switch\). } ],
[ q|{switch} isa defined method, | .
q|{namespace} isa (t::TestSuite::switch)|,
[qw| pass noise |],
sub { q|push_push|, { namespace => $switch } },
[ ],
sub {
$switch->{jedi_vcs}, exists $switch->{gat}, exists $bb->{MKS},
$rc },
[ q|opencm|, '', '', q|tturn| ],
{ noted => qr.(?xm)\[query_switch\]:\s
going\sfor\s<t::TestSuite::switch>->\[push_push\]. } ],
[ q|{switch} isa defined method, | .
q|{namespace} isa (t::TestSuite::switch), argument is set|,
[qw| pass noise |],
sub { undef, { namespace => $switch } },
[qw| serena_version_manager |],
sub { @$switch{qw| jedi_vcs gat |}, exists $bb->{MKS}, @$rc },
[qw| cvs serena_version_manager |, '', qw| tturn codeville |],
{ noted => qr.(?xm)\[query_switch\]:\s
going\sfor\s<t::TestSuite::switch>->\[push_push\]. } ],
[ q|{switch} !isa defined subroutine, | .
q|{namespace} eq (t::TestSuite::switch)|,
[qw| fail noise noise |],
sub { q|hsup_hsup|, { namespace => q|t::TestSuite::switch| } },
[ ],
qr.(?xm)\[query_switch\]:\s
<t::TestSuite::switch>\spackage\scan't\s\[hsup_hsup\].,
{ -misdefaulting =>
qr.(?m)\Q[query_switch]: defaulting {switch} to \E\x24self.,
scalar_noted => qr.(?m)\Q[query_switch]: {namespace} isa (). } ],
[ q|{switch} isa defined subroutine, | .
q|{namespace} eq (t::TestSuite::switch)|,
[qw| pass noise |],
sub { q|push_push|, { namespace => q|t::TestSuite::switch| } },
[ ],
sub { $bb->{jedi_vcs}, exists $bb->{MKS}, $rc },
[ q|controltier|, '', q|tturn| ],
{ noted => qr.(?xm)\[query_switch\]:\s
going\sfor\s<t::TestSuite::switch>::\[push_push\]. } ],
[ q|{switch} isa defined subroutine, | .
q|{namespace} eq (t::TestSuite::switch), argument is set|,
[qw| pass noise |],
sub { undef, { namespace => q|t::TestSuite::switch| } },
[qw| TLIB |],
sub { @$bb{qw| jedi_vcs gat |}, exists $bb->{MKS}, @$rc },
[qw| rmtrcs TLIB |, '', qw| tturn ic_manage |],
{ noted => qr.(?xm)\[query_switch\]:\s
going\sfor\s<t::TestSuite::switch>::\[push_push\]. } ],
[q|no turns, {switch} returns empty|,
[qw| pass |],
sub { sub { }, { } },
[ ],
sub { $rc },
[qw| uturn |] ],
[q|no turns, {switch} returns empty, argument is set|,
[qw| pass |],
sub { sub { }, { } },
[qw| clearcase |],
sub { $rc },
[qw| uturn |] ],
[q|no turns, {switch} returns explicit (undef)|,
[qw| pass |],
sub { sub { undef }, { } },
[ ],
sub { $rc },
[qw| uturn |] ],
[q|no turns, {switch} returns explicit (undef), argument is set|,
[qw| pass |],
sub { sub { undef }, { } },
[qw| clearcase |],
sub { $rc },
[qw| uturn |] ],
[q|no turns, {switch} returns empty string|,
[qw| pass |],
sub { sub { '' }, { } },
[ ],
sub { $rc },
[qw| fturn |], ],
[q|no turns, {switch} returns empty string, argument is set|,
[qw| pass |],
sub { sub { '' }, { } },
[qw| team_foundation_server |],
sub { $rc },
[qw| fturn |] ],
[q|no turns, {switch} returns nil|,
[qw| pass |],
sub { sub { 0 }, { } },
[ ],
sub { $rc },
[qw| fturn |], ],
[q|no turns, {switch} returns nil, argument is set|,
[qw| pass |],
sub { sub { 0 }, { } },
[qw| siveco |],
sub { $rc },
[qw| fturn |], ],
[q|no turns, {switch} returns one item|,
[qw| pass |],
sub { sub { q|opencvs| }, { } },
[ ],
sub { $rc },
[qw| tturn |] ],
[q|no turns, {switch} returns one item, argument is set|,
[qw| pass |],
sub { sub { q|opencvs| }, { } },
[qw| Perforce |],
sub { $rc },
[qw| tturn |] ],
[ q|no turns, {switch} returns two items|,
[qw| pass |],
sub { sub { qw| bitkeeper evolution | }, { } },
[ ],
sub { $rc },
[qw| tturn |] ],
[q|no turns, {switch} returns two items, argument is set|,
[qw| pass |],
sub { sub { qw| bitkeeper evolution | }, { } },
[qw| sccs |],
sub { @$rc },
[qw| tturn evolution |] ],
[ q|{eturn}, {switch} returns empty|,
[qw| pass |],
sub { $st{START}{eturn} = [qw| START DONE |]; sub { }, { } },
[ ],
sub { $rc },
[qw| uturn |] ],
[q|{eturn}, {switch} returns empty, argument is set|,
[qw| pass |],
sub { sub { }, { } },
[qw| clearcase |],
sub { $rc },
[qw| uturn |] ],
[q|{eturn}, {switch} returns explicit (undef)|,
[qw| pass |],
sub { sub { undef }, { } },
[ ],
sub { $rc },
[qw| uturn |] ],
[q|{eturn}, {switch} returns explicit (undef), argument is set|,
[qw| pass |],
sub { sub { undef }, { } },
[qw| clearcase |],
sub { $rc },
[qw| uturn |] ],
[q|{eturn}, {switch} returns empty string|,
[qw| pass |],
sub { sub { '' }, { } },
[ ],
sub { $rc },
[qw| fturn |] ],
[q|{eturn}, {switch} returns empty string, argument is set|,
[qw| pass |],
sub { sub { '' }, { } },
[qw| team_foundation_server |],
sub { $rc },
[qw| fturn |] ],
[q|{eturn}, {switch} returns nil|,
[qw| pass |],
sub { sub { 0 }, { } },
[ ],
sub { $rc },
[qw| fturn |] ],
[q|{eturn}, {switch} returns nil, argument is set|,
[qw| pass |],
sub { sub { 0 }, { } },
[qw| siveco |],
sub { $rc },
[qw| fturn |] ],
[q|{eturn}, {switch} returns one item|,
[qw| pass |],
sub { sub { q|opencvs| }, { } },
[ ],
sub { $rc },
[qw| tturn |] ],
[q|{eturn}, {switch} returns one item, argument is set|,
[qw| pass |],
sub { sub { q|opencvs| }, { } },
[qw| Perforce |],
sub { $rc },
[qw| tturn |] ],
[ q|{eturn}, {switch} returns two items|,
[qw| pass |],
sub { sub { qw| bitkeeper evolution | }, { } },
[ ],
sub { $rc },
[qw| tturn |] ],
[q|{eturn}, {switch} returns two items, argument is set|,
[qw| pass |],
sub { sub { qw| bitkeeper evolution | }, { } },
[qw| sccs |],
sub { @$rc },
[qw| tturn evolution |] ],
[
q|{uturn}, {switch} returns empty|,
[qw| pass |],
sub {
delete $st{START}{eturn};
$st{START}{uturn} = [qw| START DONE |];
sub { }, { } },
[ ],
sub { $rc },
[qw| uturn |] ],
[q|{uturn}, {switch} returns empty, argument is set|,
[qw| pass |],
sub { sub { }, { } },
[qw| clearcase |],
sub { $rc },
[qw| uturn |] ],
[q|{uturn}, {switch} returns empty, explicit (undef)|,
[qw| pass |],
sub { sub { undef }, { } },
[ ],
sub { $rc },
[qw| uturn |] ],
[q|{uturn}, {switch} returns explicit (undef), argument is set|,
[qw| pass |],
sub { sub { undef }, { } },
[qw| clearcase |],
sub { $rc },
[qw| uturn |] ],
[q|{uturn}, {switch} returns empty string|,
[qw| pass |],
sub { sub { '' }, { } },
[ ],
sub { $rc },
[qw| fturn |] ],
[q|{uturn}, {switch} returns empty string, argument is set|,
[qw| pass |],
sub { sub { '' }, { } },
[qw| team_foundation_server |],
sub { $rc },
[qw| fturn |] ],
[q|{uturn}, {switch} returns nil|,
[qw| pass |],
sub { sub { 0 }, { } },
[ ],
sub { $rc },
[qw| fturn |] ],
[q|{uturn}, {switch} returns nil, argument is set|,
[qw| pass |],
sub { sub { 0 }, { } },
[qw| siveco |],
sub { $rc },
[qw| fturn |] ],
[q|{uturn}, {switch} returns one item|,
[qw| pass |],
sub { sub { q|opencvs| }, { } },
[ ],
sub { $rc },
[qw| tturn |] ],
[q|{uturn}, {switch} returns one item, argument is set|,
[qw| pass |],
sub { sub { q|opencvs| }, { } },
[qw| Perforce |],
sub { $rc },
[qw| tturn |] ],
[ q|{uturn}, {switch} returns two items|,
[qw| pass |],
sub { sub { qw| bitkeeper evolution | }, { } },
[ ],
sub { $rc },
[qw| tturn |] ],
[q|{uturn}, {switch} returns two items, argument is set|,
[qw| pass |],
sub { sub { qw| bitkeeper evolution | }, { } },
[qw| sccs |],
sub { @$rc },
[qw| tturn evolution |] ],
[q|{tturn}, {switch} returns empty|,
[qw| pass |],
sub {
delete $st{START}{uturn};
$st{START}{tturn} = [qw| START DONE |];
sub { }, { } },
[ ],
sub { $rc },
[qw| uturn |] ],
[q|{tturn}, {switch} returns empty, argument is set|,
[qw| pass |],
sub { sub { }, { } },
[qw| clearcase |],
sub { $rc },
[qw| uturn |] ],
[q|{tturn}, {switch} returns explicit (undef)|,
[qw| pass |],
sub { sub { undef }, { } },
[ ],
sub { $rc },
[qw| uturn |] ],
[q|{tturn}, {switch} returns explicit (undef), argument is set|,
[qw| pass |],
sub { sub { undef }, { } },
[qw| clearcase |],
sub { $rc },
[qw| uturn |] ],
[q|{tturn}, {switch} returns empty string|,
[qw| pass |],
sub { sub { '' }, { } },
[ ],
sub { $rc },
[qw| fturn |] ],
[q|{tturn}, {switch} returns empty string, argument is set|,
[qw| pass |],
sub { sub { '' }, { } },
[qw| team_foundation_server |],
sub { $rc },
[qw| fturn |] ],
[q|{tturn}, {switch} returns nil|,
[qw| pass |],
sub { sub { 0 }, { } },
[ ],
sub { $rc },
[qw| fturn |] ],
[q|{tturn}, {switch} returns nil, argument is set|,
[qw| pass |],
sub { sub { 0 }, { } },
[qw| siveco |],
sub { $rc },
[qw| fturn |] ],
[q|{tturn}, {switch} returns one item|,
[qw| pass |],
sub { sub { q|opencvs| }, { } },
[ ],
sub { $rc },
[qw| tturn |] ],
[q|{tturn}, {switch} returns one item, argument is set|,
[qw| pass |],
sub { sub { q|opencvs| }, { } },
[qw| Perforce |],
sub { $rc },
[qw| tturn |] ],
[ q|{tturn}, {switch} returns two items|,
[qw| pass |],
sub { sub { qw| bitkeeper evolution | }, { } },
[ ],
sub { $rc },
[qw| tturn |] ],
[q|{tturn}, {switch} returns two items, argument is set|,
[qw| pass |],
sub { sub { qw| bitkeeper evolution | }, { } },
[qw| sccs |],
sub { @$rc },
[qw| tturn evolution |] ],
[q|{fturn}, {switch} returns empty|,
[qw| pass |],
sub {
delete $st{START}{tturn};
$st{START}{fturn} = [qw| START DONE |];
sub { }, { } },
[ ],
sub { $rc },
[qw| uturn |] ],
[q|{fturn}, {switch} returns empty, argument is set|,
[qw| pass |],
sub { sub { }, { } },
[qw| clearcase |],
sub { $rc },
[qw| uturn |] ],
[q|{fturn}, {switch} returns explicit (undef)|,
[qw| pass |],
sub { sub { undef }, { } },
[ ],
sub { $rc },
[qw| uturn |] ],
[q|{fturn}, {switch} returns explicit (undef), argument is set|,
[qw| pass |],
sub { sub { undef }, { } },
[qw| clearcase |],
sub { $rc },
[qw| uturn |] ],
[q|{fturn}, {switch} returns empty string|,
[qw| pass |],
sub { sub { '' }, { } },
[ ],
sub { $rc },
[qw| fturn |] ],
[q|{fturn}, {switch} returns empty string, argument is set|,
[qw| pass |],
sub { sub { '' }, { } },
[qw| team_foundation_server |],
sub { $rc },
[qw| fturn |] ],
[q|{fturn}, {switch} returns nil|,
[qw| pass |],
sub { sub { 0 }, { } },
[ ],
sub { $rc },
[qw| fturn |] ],
[q|{fturn}, {switch} returns nil, argument is set|,
[qw| pass |],
sub { sub { 0 }, { } },
[qw| siveco |],
sub { $rc },
[qw| fturn |] ],
[q|{fturn}, {switch} returns one item|,
[qw| pass |],
sub { sub { q|opencvs| }, { } },
[ ],
sub { $rc },
[qw| tturn |] ],
[q|{fturn}, {switch} returns one item, argument is set|,
[qw| pass |],
sub { sub { q|opencvs| }, { } },
[qw| Perforce |],
sub { $rc },
[qw| tturn |] ],
[ q|{fturn}, {switch} returns two items|,
[qw| pass |],
sub { sub { qw| bitkeeper evolution | }, { } },
[ ],
sub { $rc },
[qw| tturn |] ],
[q|{fturn}, {switch} returns two items, argument is set|,
[qw| pass |],
sub { sub { qw| bitkeeper evolution | }, { } },
[qw| sccs |],
sub { @$rc },
[qw| tturn evolution |] ],
[q|{turns}, {switch} returns empty|,
[qw| pass |],
sub {
delete $st{START}{fturn};
$st{START}{turns} = { cogito => [qw| START DONE |] };
sub { }, { } },
[ ],
sub { $rc },
[qw| uturn |] ],
[q|{turns}, {switch} returns empty, argument is set|,
[qw| pass |],
sub { sub { }, { } },
[qw| clearcase |],
sub { $rc },
[qw| uturn |] ],
[q|{turns}, {switch} returns explicit (undef)|,
[qw| pass |],
sub { sub { undef }, { } },
[ ],
sub { $rc },
[qw| uturn |] ],
[q|{turns}, {switch} returns explicit (undef), argument is set|,
[qw| pass |],
sub { sub { undef }, { } },
[qw| clearcase |],
sub { $rc },
[qw| uturn |] ],
[q|{turns}, {switch} returns empty string|,
[qw| pass |],
sub { sub { '' }, { } },
[ ],
sub { $rc },
[qw| turn% |], ],
[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]->();
( run in 1.638 second using v1.01-cache-2.11-cpan-d80b1682f3f )