view release on metacpan or  search on metacpan

inc/My/Module/Test.pm  view on Meta::CPAN

package My::Module::Test;

use 5.006002;

use strict;
use warnings;

use Carp;
use Test::More 0.88;

use Exporter;
our @ISA = qw{ Exporter };

no if "$]" >= 5.020, feature => qw{ signatures };

# This occurs in both inc/My/Module/Meta.pm and inc/My/Module/Test.pm
use constant CAN_USE_UNICODE	=> "$]" >= 5.008004;

our $VERSION = '0.105';

our @EXPORT =		## no critic (ProhibitAutomaticExportation)
qw{
    check_testable
    do_utf
    hex_diag
    pb_name
    pb_opt
    pb_putter
    set_test_output_encoding
    test_vs_pbpaste
    CAN_USE_UNICODE
};

use constant REF_ARRAY	=> ref [];

sub check_testable (;$) {	## no critic (ProhibitSubroutinePrototypes)
    my ( $prog ) = @_;

    if ( defined $prog ) {
	`$prog -help 2>&1`;
	$?
	    and plan skip_all => "@{[ ucfirst $prog ]} program not found";
    }

    eval {
	require Mac::Pasteboard;
	1;
    } or plan skip_all => 'Can not load Mac::Pasteboard';

    Mac::Pasteboard->set( fatal => 0 );
    Mac::Pasteboard->new();
    Mac::Pasteboard->get( 'status' ) ==
    Mac::Pasteboard::coreFoundationUnknownErr()
	and plan skip_all => 'No access to desktop (maybe running as ssh session or cron job?)';
    Mac::Pasteboard->set( fatal => 1 );

    return;
}

{
    my $do_utf = eval {
	require POSIX;
	my ( $rls ) = split qr{ [.] }smx, ( POSIX::uname() )[2];
	$rls >= 12;	# Mountain Lion.
		    # Seen to work under Mountain Lion (Darwin 12).
		    # Seen not to work under Tiger (Darwin 8).
		    # In between unknown.
    };

    sub do_utf {
	return $do_utf;
    }
}

sub hex_diag ($;$) {
    my ( $got, $expect ) = @_;
    foreach (
	[ got => $got ],
	( @_ > 1 ? [ expected => $expect ] : () ),
    ) {
	my ( $name, $value ) = @{ $_ };
	my $hex = do {
	    use bytes;
	    unpack 'H*', $value;
	};
	$hex =~ s/ ( .. ) /$1 /smxg;
	$hex =~ s/ \s+ \z //smx;
	diag sprintf '%12s: %s', $name, $hex;
	if ( $ENV{DEVELOPER_DEBUG} ) {
	    require Devel::Peek;
	    Devel::Peek::Dump( $value );
	}
    }
    return;
}

sub pb_name ($) {	## no critic (ProhibitSubroutinePrototypes, RequireArgUnpacking)
    $_[1] = 'name';
    goto &_pb_info;
}

sub pb_opt ($) {	## no critic (ProhibitSubroutinePrototypes, RequireArgUnpacking)
    $_[1] = 'pbopt';
    goto &_pb_info;
}

sub pb_putter ($) {	## no critic (ProhibitSubroutinePrototypes, RequireArgUnpacking)
    $_[1] = 'putter';
    goto &_pb_info;
}

{

    my %pasteboard_info = (