view release on metacpan or  search on metacpan

t/common.t  view on Meta::CPAN

    open(ERR, ">/dev/null");
    print ERR @_;
    close ERR;
    exit 1;
}

no Moose;
__PACKAGE__->meta->make_immutable;

package main;

local %ENV = %ENV;

# ensure we run the tests using the default value.
delete $ENV{COLUMNS};

my $sc = Test::Script::Common->new;

my $switches = qq{--baz              The baz option
--foo=<f>          The foo option should be <f> (default: bar)
--fribitz=<f>      fribitz is a floating-point option (default: 0.01)
--help             Show this help information
--quux=N           quux is an integer option (default: 7)
};
my $scswitches = $sc->switches;
$scswitches =~ s/\s+/ /g;
$switches   =~ s/\s+/ /g;

is($sc->getOption('help'), undef,           'help was not requested');
is($sc->run,               0,               'run() returns 0');
is($sc->script_name,       'common.t',      'script_name() returns correct value');
is(trim($scswitches),      trim($switches), 'switches() returns correct value');
divert_stderr(
    sub {
        exits_ok(sub { $sc->usage; }, "usage() method causes exit");
        warnings_like {
            exits_ok(sub { $sc->__error("Error message"); }, "__error() method causes exit");
        }
        [qr/^Error message/], "Expected warning on __error";
        throws_ok { $sc->getOption('bogus_option'); } qr/Unknown option/, 'Bogus option names cause death';

        is($sc->run, 0, 'Run returns 0');

        COLUMNS:
        {
            my $long_switches = qq{--baz              The baz option
--foo=<f>          The foo option should be <f> (default: bar)
--fribitz=<f>      fribitz is a floating-point option (default: 0.01)
--help             Show this help information
--quux=N           quux is an integer option (default: 7)
};

            local %ENV;
            $ENV{COLUMNS} = 100;
            $long_switches =~ s/\s+/ /g;
            is(trim($long_switches), trim($scswitches), 'COLUMNS environment variable controls width of switch table output');
        }

        HELP:
        {
            local @ARGV = ('--help');
            exits_ok(sub { Test::Script::Common->new; }, "--help forces exit");
        }

        NONSENSE:
        {
            local @ARGV = ('--nonsense-option');
            warnings_like {
                exits_ok(sub { Test::Script::Common->new; }, "Can't instantiate a script with an invalid option");
            }
            qr/Unknown option/, 'Unknown option warns';
        }

        INVALID_OPTION_VALUE:
        {
            local @ARGV = ('--quux=a_string');
            warnings_like {
                exits_ok(sub { Test::Script::Common->new; },
                    "Can't instantiate a script with an option value that does not match the specified type");
            }
            qr/invalid for option quux/, 'option with invalid type warns';
        }
    });

done_testing;