view release on metacpan or search on metacpan
lib/App/Getconf.pm view on Meta::CPAN
worry about formatting the string if it is longer and broken to separate lines
in your source code, so I think it's a good trade-off.
=cut
sub opt($) {
my ($data) = @_;
my $type = $data->{type} || "string";
my $check = $data->{check};
my $storage = $data->{storage};
lib/App/Getconf.pm view on Meta::CPAN
Aliases may only point to non-alias options.
=cut
sub opt_alias($) {
my ($dest_option) = @_;
return new App::Getconf::Node(alias => $dest_option);
}
lib/App/Getconf.pm view on Meta::CPAN
Flag option (like I<--help>, I<--verbose> or I<--debug>).
=cut
sub opt_flag() {
return opt { type => 'flag' };
}
=item C<opt_bool()>
Boolean option (like I<--recursive>). Such option gets its counterpart
called I<--no-${option}> (mentioned I<--recursive> gets I<--no-recursive>).
=cut
sub opt_bool() {
return opt { type => 'bool' };
}
=item C<opt_int()>
Integer option (I<--retries=3>).
=cut
sub opt_int() {
return opt { type => 'int' };
}
=item C<opt_float()>
Option specifying a floating point number.
=cut
sub opt_float() {
return opt { type => 'float' };
}
=item C<opt_string()>
Option specifying a string.
=cut
sub opt_string() {
return opt { type => 'string' };
}
=item C<opt_path()>
Option specifying a path in local filesystem.
=cut
sub opt_path() {
# TODO: some checks on how this looks like
# * existing file
# * existing directory
# * non-existing file (directory exists)
# * Maasai?
lib/App/Getconf.pm view on Meta::CPAN
B<NOTE>: This doesn't check DNS for the hostname to exist. This only checks
hostname's syntactic correctness (and only to some degree).
=cut
sub opt_hostname() {
return opt { check => qr/^[a-z0-9-]+(\.[a-z0-9-]+)*$/i };
}
=item C<opt_re(qr/.../)>
Option specifying a string, with check specified as regexp.
=cut
sub opt_re($) {
my ($re) = @_;
return opt { check => $re };
}
lib/App/Getconf.pm view on Meta::CPAN
Subroutine should return C<TRUE> when option value should be accepted,
C<FALSE> otherwise.
=cut
sub opt_sub(&) {
my ($sub) = @_;
return opt { check => $sub };
}
lib/App/Getconf.pm view on Meta::CPAN
Option specifying a string. The string must be one of the specified in the
array.
=cut
sub opt_enum($) {
my ($choices) = @_;
return opt { check => $choices };
}
view release on metacpan or search on metacpan
lib/App/GitHub/FixRepositoryName.pm view on Meta::CPAN
warn $@ if $@;
return $repository->url if $repository;
return $url; # Put back what we originally had
}
sub do_usage(;$) {
my $error = shift;
warn $error if $error;
warn <<'_END_';
Usage: github-fix-repository-name [...] <path>
view release on metacpan or search on metacpan
lib/App/Gitc/Reversible.pm view on Meta::CPAN
push our(@undo_stack), $code;
return;
}
sub reversibly(&) {
my ($code) = @_;
local $SIG{INT} = sub { die "SIGINT\n" };
local $SIG{TERM} = sub { die "SIGTERM\n" };
local our(@undo_stack); # to allow nested, reversible computations
view release on metacpan or search on metacpan
lib/App/Guiio/Undo.pm view on Meta::CPAN
}
return @diff_lines ;
}
sub CompareStrings($$)
{
=head2 CompareStrings
Returns the following list:
view release on metacpan or search on metacpan
inc/Test/Base.pm view on Meta::CPAN
$default_object ||= $default_class->new;
return $default_object;
}
my $import_called = 0;
sub import() {
$import_called = 1;
my $class = (grep /^-base$/i, @_)
? scalar(caller)
: $_[0];
if (not defined $default_class) {
inc/Test/Base.pm view on Meta::CPAN
$caller =~ s/.*:://;
croak "Too late to call $caller()"
}
}
sub find_my_self() {
my $self = ref($_[0]) eq $default_class
? splice(@_, 0, 1)
: default_object();
return $self, @_;
}
sub blocks() {
(my ($self), @_) = find_my_self(@_);
croak "Invalid arguments passed to 'blocks'"
if @_ > 1;
croak sprintf("'%s' is invalid argument to blocks()", shift(@_))
inc/Test/Base.pm view on Meta::CPAN
}
return (@blocks);
}
sub next_block() {
(my ($self), @_) = find_my_self(@_);
my $list = $self->_next_list;
if (@$list == 0) {
$list = [@{$self->block_list}, undef];
$self->_next_list($list);
inc/Test/Base.pm view on Meta::CPAN
$block->run_filters;
}
return $block;
}
sub first_block() {
(my ($self), @_) = find_my_self(@_);
$self->_next_list([]);
$self->next_block;
}
sub filters_delay() {
(my ($self), @_) = find_my_self(@_);
$self->_filters_delay(defined $_[0] ? shift : 1);
}
sub no_diag_on_only() {
(my ($self), @_) = find_my_self(@_);
$self->_no_diag_on_only(defined $_[0] ? shift : 1);
}
sub delimiters() {
(my ($self), @_) = find_my_self(@_);
$self->check_late;
my ($block_delimiter, $data_delimiter) = @_;
$block_delimiter ||= $self->block_delim_default;
$data_delimiter ||= $self->data_delim_default;
$self->block_delim($block_delimiter);
$self->data_delim($data_delimiter);
return $self;
}
sub spec_file() {
(my ($self), @_) = find_my_self(@_);
$self->check_late;
$self->_spec_file(shift);
return $self;
}
sub spec_string() {
(my ($self), @_) = find_my_self(@_);
$self->check_late;
$self->_spec_string(shift);
return $self;
}
sub filters() {
(my ($self), @_) = find_my_self(@_);
if (ref($_[0]) eq 'HASH') {
$self->_filters_map(shift);
}
else {
inc/Test/Base.pm view on Meta::CPAN
push @$filters, @_;
}
return $self;
}
sub filter_arguments() {
$Test::Base::Filter::arguments;
}
sub have_text_diff {
eval { require Text::Diff; 1 } &&
$Text::Diff::VERSION >= 0.35 &&
$Algorithm::Diff::VERSION >= 1.15;
}
sub is($$;$) {
(my ($self), @_) = find_my_self(@_);
my ($actual, $expected, $name) = @_;
local $Test::Builder::Level = $Test::Builder::Level + 1;
if ($ENV{TEST_SHOW_NO_DIFFS} or
not defined $actual or
inc/Test/Base.pm view on Meta::CPAN
ok $actual eq $expected,
$name . "\n" . Text::Diff::diff(\$expected, \$actual);
}
}
sub run(&;$) {
(my ($self), @_) = find_my_self(@_);
my $callback = shift;
for my $block (@{$self->block_list}) {
$block->run_filters unless $block->is_filtered;
&{$callback}($block);
inc/Test/Base.pm view on Meta::CPAN
sub END {
run_compare() unless $Have_Plan or $DIED or not $import_called;
}
sub run_compare() {
(my ($self), @_) = find_my_self(@_);
$self->_assert_plan;
my ($x, $y) = $self->_section_names(@_);
local $Test::Builder::Level = $Test::Builder::Level + 1;
for my $block (@{$self->block_list}) {
inc/Test/Base.pm view on Meta::CPAN
is($block->$x, $block->$y, $block->name ? $block->name : ());
}
}
}
sub run_is() {
(my ($self), @_) = find_my_self(@_);
$self->_assert_plan;
my ($x, $y) = $self->_section_names(@_);
local $Test::Builder::Level = $Test::Builder::Level + 1;
for my $block (@{$self->block_list}) {
inc/Test/Base.pm view on Meta::CPAN
$block->name ? $block->name : ()
);
}
}
sub run_is_deeply() {
(my ($self), @_) = find_my_self(@_);
$self->_assert_plan;
my ($x, $y) = $self->_section_names(@_);
for my $block (@{$self->block_list}) {
next unless exists($block->{$x}) and exists($block->{$y});
inc/Test/Base.pm view on Meta::CPAN
$block->name ? $block->name : ()
);
}
}
sub run_like() {
(my ($self), @_) = find_my_self(@_);
$self->_assert_plan;
my ($x, $y) = $self->_section_names(@_);
for my $block (@{$self->block_list}) {
next unless exists($block->{$x}) and defined($y);
inc/Test/Base.pm view on Meta::CPAN
$block->name ? $block->name : ()
);
}
}
sub run_unlike() {
(my ($self), @_) = find_my_self(@_);
$self->_assert_plan;
my ($x, $y) = $self->_section_names(@_);
for my $block (@{$self->block_list}) {
next unless exists($block->{$x}) and defined($y);
inc/Test/Base.pm view on Meta::CPAN
};
}
return $spec;
}
sub _strict_warnings() {
require Filter::Util::Call;
my $done = 0;
Filter::Util::Call::filter_add(
sub {
return 0 if $done;
inc/Test/Base.pm view on Meta::CPAN
$done = 1;
}
);
}
sub tie_output() {
my $handle = shift;
die "No buffer to tie" unless @_;
tie $handle, 'Test::Base::Handle', $_[0];
}
inc/Test/Base.pm view on Meta::CPAN
$ENV{TEST_SHOW_NO_DIFFS} = 1;
}
package Test::Base::Handle;
sub TIEHANDLE() {
my $class = shift;
bless \ $_[0], $class;
}
sub PRINT {
inc/Test/Base.pm view on Meta::CPAN
sub AUTOLOAD {
return;
}
sub block_accessor() {
my $accessor = shift;
no strict 'refs';
return if defined &$accessor;
*$accessor = sub {
my $self = shift;
view release on metacpan or search on metacpan
lib/App/Ikaros/DSL.pm view on Meta::CPAN
sub get_options {
return option_parser CONFIG->{options};
}
sub hosts($) {
my $conf = shift;
CONFIG->{hosts} = $conf->{hosts};
CONFIG->{default} = $conf->{default};
}
sub plan($) {
my $plan = shift;
CONFIG->{plan} = $plan;
}
1;
view release on metacpan or search on metacpan
use Test2::Bundle::Extended;
use App::Inspect;
sub capture(&) {
my $code = shift;
my $out = "";
my ($ok, $e);
view release on metacpan or search on metacpan
lib/App/InvestSim.pm view on Meta::CPAN
use App::InvestSim::Values;
use Tkx;
our $VERSION = 'v1.0.1';
sub run($) {
my ($res_dir) = @_;
App::InvestSim::Values::init_values();
App::InvestSim::Values::autoload();
App::InvestSim::GUI::build($res_dir);
App::InvestSim::GUI::refresh_all_fields();
view release on metacpan or search on metacpan
script/kgb-bot view on Meta::CPAN
$ENV{PATH} = $oldpath;
return $polygen;
}
sub merge_conf_hash($$);
sub merge_conf_hash($$) {
my ( $dst, $src ) = @_;
while ( my ($k, $v) = each %$src ) {
if ( ref($v) ) {
if ( exists $dst->{$k} ) {
script/kgb-bot view on Meta::CPAN
$dst->{$k} = $v;
}
}
}
sub parse_conf_file($;$);
sub parse_conf_file($;$) {
my $src = shift;
my $met = shift // {};
return {} if $met->{$src}++;
script/kgb-bot view on Meta::CPAN
KGB->debug( JSON::XS->new->convert_blessed(1)->encode($conf) );
return $conf;
}
sub load_conf($) {
my $file = shift;
my $conf = read_conf($file);
# Save globals
$config_file = Cwd::realpath($file);
$config = $conf;
return $conf;
}
sub reload_conf() {
my $new_conf = eval { KGB::read_conf($config_file) };
if ($@) {
KGB->out("Error in configuration file: $@");
return -1;
}
script/kgb-bot view on Meta::CPAN
use Text::Glob qw(match_glob);
sub colorize { KGB::SOAP::colorize( @_ ) };
sub colorize_change { KGB::SOAP::colorize_change( @_ ) };
sub webhook_error(\@$;$$) {
my $env = shift;
my $message = shift;
my $code = shift // HTTP::Status::HTTP_BAD_REQUEST;
my $content = shift // $message;
script/kgb-bot view on Meta::CPAN
KGB->count('URLs_shortened');
return $short_url;
}
sub trim_lines(\@$@) {
my ( $chanids, $repoid, @strings ) = @_;
# Standard says 512 (minus \r\n), anyway that's further trimmed when
# resending to clients because of prefix.
# Let's trim on 400, to be safe
my $MAGIC_MAX_LINE = ( 400 - length("PRIVMSG ")
view release on metacpan or search on metacpan
inc/Test/More.pm view on Meta::CPAN
return $tb->unlike(@_);
}
#line 476
sub cmp_ok($$$;$) {
my $tb = Test::More->builder;
return $tb->cmp_ok(@_);
}
view release on metacpan or search on metacpan
lib/App/LXC/Container.pm view on Meta::CPAN
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub setup($)
{
defined $ENV{ALC_DEBUG} and $ENV{ALC_DEBUG} =~ m/^[0-9]+$/ and
debug($ENV{ALC_DEBUG});
my $container = App::LXC::Container::Setup->new(shift);
$container->main();
lib/App/LXC/Container.pm view on Meta::CPAN
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub update(@)
{
defined $ENV{ALC_DEBUG} and $ENV{ALC_DEBUG} =~ m/^[0-9]+$/ and
debug($ENV{ALC_DEBUG});
my $container = App::LXC::Container::Update->new(@_);
$container->main();
lib/App/LXC/Container.pm view on Meta::CPAN
=cut
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
sub run(@)
{
my ($user, $dir) = ('root', '/');
while (2 < @_ and $_[0] =~ m/^(?:-[du]|--(?:dir|directory|user))$/)
{
if ($_[0] =~ m/^(-u|--user)$/)
view release on metacpan or search on metacpan
inc/Test/More.pm view on Meta::CPAN
return $tb->unlike(@_);
}
#line 423
sub cmp_ok($$$;$) {
my $tb = Test::More->builder;
return $tb->cmp_ok(@_);
}
view release on metacpan or search on metacpan
lib/App/MaMGal/Entry/Dir.pm view on Meta::CPAN
ref($r) or App::MaMGal::SystemException->throw(message => '%s: montage failed: %s', objects => [$montage_path, $r]);
$r = App::MaMGal::Entry::Picture->scale_into($montage, $m_x, $m_y) and App::MaMGal::SystemException->throw(message => '%s: scaling failed: %s', objects => [$montage_path, $r]);
$r = $montage->Write($montage_path) and App::MaMGal::SystemException->throw(message => '%s: writing montage failed: %s', objects => [$montage_path, $r]);
}
sub _ignorable_name($)
{
my $self = shift;
my $name = shift;
# ignore hidden files
return 1 if substr($_, 0, 1) eq '.';
view release on metacpan or search on metacpan
inc/Test/More.pm view on Meta::CPAN
return $tb->unlike(@_);
}
#line 471
sub cmp_ok($$$;$) {
my $tb = Test::More->builder;
return $tb->cmp_ok(@_);
}
inc/Test/More.pm view on Meta::CPAN
return $obj;
}
#line 719
sub subtest($&) {
my ($name, $subtests) = @_;
my $tb = Test::More->builder;
return $tb->subtest(@_);
}
view release on metacpan or search on metacpan
$verbose=0;
$unix_path = (eval { File::Spec->tmpdir } || "/tmp")."/installtracer_socket$$~";
sub slog($@) {
(print STDERR "APPMAN: ",@_,"\n") if $verbose => shift;
}
my $sizeof_int = length pack "i",0;
my $unix; # unix listening socket
my $fh; # the filehandle
my $change_cb; # call before every change
sub xread($) {
my $len=shift;
my $buff;
while ($len) {
my $read = sysread $fh,$buff,$len,length($buff);
redo if !$read && $! == EAGAIN;
$len -= $read;
}
$buff;
}
sub get_char() { xread 1 }
sub get_int() { unpack "i", xread $sizeof_int }
sub get_str() { xread get_int }
# read cwd, pathname and canonicalize it
sub get_abspath() {
my $path = File::Spec->catdir(get_str,get_str);
my($base,$dir)=fileparse($path);
$abspath{$dir} = Cwd::abs_path($dir) unless defined $abspath{$dir};
File::Spec->canonpath("$abspath{$dir}/$base$suffix");
1;
}
END { unlink $unix_path }
sub init_tracer() {
$unix = new IO::Socket::UNIX Local => $unix_path, Listen => 1;
$unix or die "Unable to create unix domain socket '$unix_path' for listening: $!\n";
-x LIBTRACER_SO
or die "FATAL: tracer helper object '".LIBTRACER_SO."' not executable!\n";
}
sub stop_tracer() {
unlink $unix_path; undef $unix_path;
}
sub run_tracer() {
my($rm,$r,$handles);
vec($rm,fileno($unix),1)=1;
while(!$server_quit) {
}
}
}
# launch a single program and update %before hashes.
sub trace_program($@) {
$change_cb = shift;
init_tracer;
$server_quit = 0;
$self->{version}=$VERSION;
$self->dirty;
$self;
}
sub xlstat($) {
my @stat = lstat $_[0];
@stat ?
{
path => $_[0],
dev => $stat[ 0],
{
path => $_[0],
}
}
sub ci($$) {
my $self=shift;
my $stat=xlstat shift;
my $gen = $self->{genfile}++;
$stat->{id} = $gen;
}
}
$self->dirty;
}
sub optimize($$) {
my $self=shift;
my $level=shift;
slog 1,"checking for differences between database and filesystem";
for my $stat (values (%{$self->{storage}})) {
my $msg;
sub storage {
my $self=shift;
$self->{storage};
}
sub remove($) {
my $path=shift;
lstat $path;
if (-e _) {
if (-d _) {
rmdir $path
or die "Unable to remove existing object '$path': $!\n";
}
}
}
sub recreate($) {
my $stat = shift;
if (defined $stat->{mode}) {
if (S_ISREG $stat->{mode}) {
if (exists $stat->{savepath}) {
remove $stat->{path};
view release on metacpan or search on metacpan
t/integration/blast.t view on Meta::CPAN
is $mech->status, 400, 'input error if no program is selected' or diag $mech->content;
{
sub test_blast_hits() {
$mech->get_ok('/');
$mech->submit_form_ok({
form_name => 'main_input_form',
fields => {
mimosa_sequence_set_ids => 1,
t/integration/blast.t view on Meta::CPAN
# do it again to exercise cached codepaths
test_blast_hits();
}
sub test_composite_blast_hits() {
my $mech = Mech->new;
$mech->get_ok('/');
$mech->submit_form_ok({
form_name => 'main_input_form',
fields => {
view release on metacpan or search on metacpan
return wantarray ? %{$this->{groups}} : $this->{groups};
}
# }}}
# set_usage_error($&) {{{
sub set_usage_error($&) { ## no critic -- prototypes are bad how again?
my $this = shift;
my $func = shift;
my $pack = caller;
my $name = $pack . "::$func";
my @args = @_;
view release on metacpan or search on metacpan
lib/App/MtAws/ConfigEngine.pm view on Meta::CPAN
# TODOS
#refactor messages %option a% vs %option option%
#options_encoding_error specify source of problem
sub message($;$%)
{
my ($message, $format, %opts) = @_;
$format = $message unless defined $format;
confess "message $message already defined" if defined $context->{messages}->{$message} and !$context->{messages}->{$message}->{allow_redefine};
$context->{messages}->{$message} = { %opts, format => $format };
lib/App/MtAws/ConfigEngine.pm view on Meta::CPAN
$_;
}
} @{$err};
}
sub arrayref_or_undef($)
{
my ($ref) = @_;
defined($ref) && @$ref > 0 ? $ref : undef;
}
sub define($&)
{
my ($self, $block) = @_;
local $context = $self; # TODO: create wrapper like 'localize sub ..'
$block->();
}
lib/App/MtAws/ConfigEngine.pm view on Meta::CPAN
}
sub assert_option { $context->{options}->{$_} or confess "undeclared option $_"; }
sub option($;%) {
my ($name, %opts) = @_;
confess "option already declared" if $context->{options}->{$name};
if (%opts) {
if (defined $opts{alias}) {
lib/App/MtAws/ConfigEngine.pm view on Meta::CPAN
}
$context->{options}->{$name} = { %opts, name => $name } unless $context->{options}->{$name};
return $name;
};
sub positional($;%)
{
option shift, @_, positional => 1;
}
sub options(@) {
map {
confess "option already declared $_" if $context->{options}->{$_};
$context->{options}->{$_} = { name => $_ };
$_
} @_;
};
sub validation(@)
{
my ($name, $message, $cb, %opts) = (shift, shift, pop @_, @_);
confess "undeclared option" unless defined $context->{options}->{$name};
push @{ $context->{options}->{$name}->{validations} }, { %opts, 'message' => $message, cb => $cb }
unless $context->{override_validations} && exists($context->{override_validations}->{$name});
$name;
}
sub command($@)
{
my ($name, $cb, %opts) = (shift, pop, @_); # firs arg is name, last is cb, optional middle is opt
confess "command $name already declared" if defined $context->{commands}->{$name};
confess "alias $name already declared" if defined $context->{aliasmap}->{$name};
lib/App/MtAws/ConfigEngine.pm view on Meta::CPAN
}
$context->{commands}->{$name} = { cb => $cb, %opts };
return;
};
sub _real_option_name($)
{
my ($opt) = @_;
defined($opt->{original_option}) ? $opt->{original_option} : $opt->{name};
}
lib/App/MtAws/ConfigEngine.pm view on Meta::CPAN
}
}
$o;
}
sub mandatory(@) {
return map {
my $opt = assert_option;
unless ($opt->{seen}) {
seen;
confess "mandatory positional argument goes after optional one"
lib/App/MtAws/ConfigEngine.pm view on Meta::CPAN
}
$_;
} @_;
};
sub optional(@)
{
return map {
seen;
$context->{positional_level} = 'optional' if ($context->{options}->{$_}->{positional});
$_;
} @_;
};
sub deprecated(@)
{
return map {
assert_option;
my $opt = $context->{options}->{ seen() };
confess "positional options can't be deprecated" if $opt->{positional};
lib/App/MtAws/ConfigEngine.pm view on Meta::CPAN
undef $opt->{value};
}
$_;
} @_;
};
sub validate(@)
{
return map {
my $opt = $context->{options}->{seen()};
if (defined($opt->{value}) && !$opt->{validated}) {
$opt->{validated} = $opt->{valid} = 1;
lib/App/MtAws/ConfigEngine.pm view on Meta::CPAN
};
$_;
} @_;
};
sub scope($@)
{
my $scopename = shift;
return map {
assert_option;
unshift @{$context->{options}->{$_}->{scope}}, $scopename;
$_;
} @_;
};
sub present(@) # TODO: test that it works with arrays
{
my $name = @_ ? shift : $_;
assert_option for $name;
return defined($context->{options}->{$name}->{value})
};
# TODO: test
sub explicit(@) # TODO: test that it works with arrays
{
my $name = @_ ? shift : $_;
return present($name) && $context->{options}->{$name}->{source} eq 'option'
};
sub valid($)
{
my ($name) = @_;
assert_option for $name;
confess "validation not performed yet" unless $context->{options}->{$name}->{validated};
return $context->{options}->{$name}->{valid};
};
sub value($)
{
my ($name) = @_;
assert_option for $name;
confess "option not present" unless defined($context->{options}->{$name}->{value});
return $context->{options}->{$name}->{value};
};
sub impose(@)
{
my ($name, $value) = @_;
assert_option for $name;
my $opt = $context->{options}->{$name};
$opt->{source} = 'impose';
$opt->{value} = $value;
return $name;
};
sub lists(@)
{
my @a = @_;
grep { my $o = $_; first { $_ eq $o->{name} } @a; } @{$context->{option_list}};
}
sub raw_option($)
{
my ($name) = @_;
assert_option for $name;
confess "option not present" unless defined($context->{options}->{$name}->{value});
return $context->{options}->{$name};
};
sub custom($$)
{
my ($name, $value) = @_;
confess if ($context->{options}->{$name});
$context->{options}->{$name} = {source => 'set', value => $value, name => $name, seen => 1 };
return $name;
};
sub error($;%)
{
my ($name, %data) = @_;
push @{$context->{errors}},
defined($context->{messages}->{$name}) ?
{ format => $name, %data } :
(%data ? confess("message '$name' is undefined") : $name);
return;
};
sub warning($;%)
{
my ($name, %data) = @_;
push @{$context->{warnings}},
defined($context->{messages}->{$name}) ?
{ format => $name, %data } :
view release on metacpan or search on metacpan
lib/App/Multigit.pm view on Meta::CPAN
Returns C<.mgconfig>. This is a stub to be later configurable, but also
to stop me typoing it all the time.
=cut
sub mgconfig() {
return '.mgconfig';
}
=head2 mg_parent
lib/App/Multigit.pm view on Meta::CPAN
This will die if the base repository is not on a branch, because if you've asked
for it, giving you a default will more likely be a hindrance than a help.
=cut
sub base_branch() {
my $dir = mg_parent;
my ($stdout) = capture {
system qw(git -C), $dir, qw(branch)
};
view release on metacpan or search on metacpan
lib/ChordPro/Config.pm view on Meta::CPAN
}
}
# Reverse of config_expand_font_shortcuts.
sub simplify_fonts( $cfg ) {
return $cfg unless $cfg->{pdf}->{fonts};
foreach my $font ( keys %{$cfg->{pdf}->{fonts}} ) {
for ( $cfg->{pdf}->{fonts}->{$font} ) {
lib/ChordPro/Config.pm view on Meta::CPAN
warn("M $path $self\n") if DEBUG;
return 'M';
}
sub hmerge( $left, $right, $path = "" ) {
# Merge hashes. Right takes precedence.
# Based on Hash::Merge::Simple by Robert Krimen.
my %res = %$left;
view release on metacpan or search on metacpan
lib/App/Music/PlayTab.pm view on Meta::CPAN
our @EXPORT = qw(run);
################ Command line parameters ################
use Getopt::Long;
sub app_options();
my $output;
my $generate;
my $preamble;
my $gxpose = 0; # global xpose value
lib/App/Music/PlayTab.pm view on Meta::CPAN
}
################ Command Line Options ################
sub app_ident;
sub app_usage($);
sub app_options() {
my $help = 0; # handled locally
my $ident = 0; # handled locally
# Process options, if any.
# Make sure defaults are set before returning!
lib/App/Music/PlayTab.pm view on Meta::CPAN
sub app_ident {
print STDERR ("This is $my_package [$my_name $my_version]\n");
}
sub app_usage($) {
my ($exit) = @_;
app_ident;
print STDERR <<EndOfUsage;
Usage: $0 [options] [file ...]
--output XXX output file name
view release on metacpan or search on metacpan
bin/atonal-util view on Meta::CPAN
#
# SUBROUTINES
# TODO move back to List::MoreUtils if that module is fixed up or some
# replacement with fewer open critical bugs is written.
sub all(&@) {
my $test = shift;
for (@_) {
return 0 unless &$test;
}
return 1;
view release on metacpan or search on metacpan
lib/App/NDTools/Slurp.pm view on Meta::CPAN
use constant {
TRUE => JSON::true,
FALSE => JSON::false,
};
sub _decode_yaml($) {
require YAML::XS;
my $data = YAML::XS::Load($_[0]);
# YAML::XS decode boolean vals as PL_sv_yes and PL_sv_no, both - read only
lib/App/NDTools/Slurp.pm view on Meta::CPAN
}
return $data;
}
sub _encode_yaml($) {
require YAML::XS;
my $modern_yaml_xs = eval { YAML::XS->VERSION(0.67) };
# replace booleans for YAML::XS (accepts only boolean and JSON::PP::Boolean
# since 0.67 and PL_sv_yes/no in earlier versions). No roundtrip for
lib/App/NDTools/Slurp.pm view on Meta::CPAN
}
return YAML::XS::Dump($_[0]);
}
sub s_decode($$;$) {
my ($data, $fmt, $opts) = @_;
my $format = uc($fmt);
if ($format eq 'JSON') {
my $o = { %{$FORMATS{JSON}}, %{$opts || {}} };
lib/App/NDTools/Slurp.pm view on Meta::CPAN
die_fatal "Failed to decode '$fmt': " . $@, 4 if $@;
return $data;
}
sub s_dump(@) {
my ($uri, $fmt, $opts) = splice @_, 0, 3;
$uri = \*STDOUT if ($uri eq '-');
$fmt = s_fmt_by_uri($uri) unless (defined $fmt);
lib/App/NDTools/Slurp.pm view on Meta::CPAN
} else {
s_dump_file($uri, $data);
}
}
sub s_dump_file($$) {
my ($file, $data) = @_;
open(my $fh, '>', $file) or die_fatal "Failed to open '$file' ($!)", 2;
print $fh $data;
close($fh);
}
sub s_encode($$;$) {
my ($data, $fmt, $opts) = @_;
my $format = uc($fmt);
if ($format eq 'JSON' or $format eq 'RAW' and ref $data) {
my $o = { %{$FORMATS{JSON}}, %{$opts || {}} };
lib/App/NDTools/Slurp.pm view on Meta::CPAN
die_fatal "Failed to encode structure to $fmt: " . $@, 4 if $@;
return $data;
}
sub s_fmt_by_uri($) {
my @names = split(/\./, basename(shift));
if (@names and @names > 1) {
my $ext = uc($names[-1]);
return 'YAML' if ($ext eq 'YML' or $ext eq 'YAML');
}
return 'JSON'; # by default
}
sub s_load($$;@) {
my ($uri, $fmt, %opts) = @_;
$uri = \*STDIN if ($uri eq '-');
my $data = s_load_uri($uri);
$fmt = s_fmt_by_uri($uri) unless (defined $fmt);
return s_decode($data, $fmt);
}
sub s_load_uri($) {
my $uri = shift;
my $data;
if (ref $uri eq 'GLOB') {
$data = do { local $/; <$uri> };
view release on metacpan or search on metacpan
inc/Test/More.pm view on Meta::CPAN
return $tb->unlike(@_);
}
#line 471
sub cmp_ok($$$;$) {
my $tb = Test::More->builder;
return $tb->cmp_ok(@_);
}
view release on metacpan or search on metacpan
lib/App/PAIA/Tester.pm view on Meta::CPAN
my $json = shift;
$json =~ s/^#.*$//mg;
JSON::PP::decode_json($json)
}
sub stdout_json() { decode_json($RESULT->stdout) }
sub stderr_json() { decode_json($RESULT->stderr) }
sub output_json() { decode_json($RESULT->output) }
## no critic
eval "sub $_() { \$RESULT->$_ }" for qw(stdout stderr output error exit_code);
our $HTTP_TINY_REQUEST = \&HTTP::Tiny::request;
lib/App/PAIA/Tester.pm view on Meta::CPAN
headers => { @{$psgi->[1]} },
content => join "", @{$psgi->[2]},
};
};
sub paia_live() {
no warnings;
*HTTP::Tiny::request = $HTTP_TINY_REQUEST;
}
sub new_paia_test(@) { ## no critic
chdir tempdir;
paia_live;
}
sub paia_response(@) { ## no critic
$PSGI_RESPONSE = $DEFAULT_PSGI;
if (ref $_[0] and reftype $_[0] eq 'ARRAY') {
$PSGI_RESPONSE = shift;
} else {
$PSGI_RESPONSE = $DEFAULT_PSGI;
lib/App/PAIA/Tester.pm view on Meta::CPAN
no warnings;
*HTTP::Tiny::request = \&mock_http;
}
sub paia(@) { ## no critic
$RESULT = test_app('App::PAIA' => [@_]);
}
sub PAIA($) { ## no critic
my @args = split /\s+/, shift;
say join ' ', '# paia', @args;
paia(@args);
}
sub done_paia_test() {
chdir $CWD;
done_testing;
}
sub debug {
view release on metacpan or search on metacpan
Makefile.PL view on Meta::CPAN
use strict;
use warnings;
use ExtUtils::MakeMaker;
sub ls($)
{
my $d = shift;
opendir D, $d or die $!;
map { "$d/$_" } grep { -f "$d/$_" } readdir D;
}
view release on metacpan or search on metacpan
lib/App/PS1.pm view on Meta::CPAN
}
return $self;
}
sub sum(@) { ## no critic
my $i = 0;
$i += $_ || 0 for (@_);
return $i;
}
view release on metacpan or search on metacpan
# Copyright (c) 2003-2009 David Caldwell -*- cperl -*-
use strict;
use warnings;
sub revstr($) { join "", reverse split //, $_[0] } # Reverse the characters in a string.
sub comma($$) { revstr join(",", unpack("(A$_[1])*", revstr($_[0]))) }
sub compute ($) {
$_[0] =~ s/\b([\d.]+)([kmgtpezyKMGTPEZY])[bB]?/($1*1024**(index("kmgtpezy",lc "$2")+1))/g;
my $a = eval($_[0]); die unless defined $a;
my $i = eval("use bigint; $_[0];"); $i = $a unless defined $i;
view release on metacpan or search on metacpan
bin/__perlbrewutils-probe view on Meta::CPAN
use Config;
use Data::Dumper;
# MODIFIED FROM PERLANCAR::Module::List 0.003005
sub list_modules($$) {
my($prefix, $options) = @_;
my $trivial_syntax = $options->{trivial_syntax};
my($root_leaf_rx, $root_notleaf_rx);
my($notroot_leaf_rx, $notroot_notleaf_rx);
if($trivial_syntax) {
view release on metacpan or search on metacpan
lib/App/Pfind.pm view on Meta::CPAN
sub prune {
die "The prune command cannot be used when --depth-first is set.\n" if $options{depth_first};
$File::Find::prune = 1;
}
# The prototype means that $_ will be used if nothing else is passed.
sub mkdir(_;@) {
my $err;
make_path(@_, { error => \$err });
# make_path sets $! on success (as it test the existance of the file).
undef $!;
$! = join(', ', @$err) if @$err;
}
sub rmdir(_;@) {
for my $d (@_) {
CORE::rmdir($d);
}
}
# A safe 'rm' that does not recurse into directories.
sub rm(_;@) {
for my $f (@_) {
if (-d $f) {
CORE::rmdir($f);
return if $!;
} else {
lib/App/Pfind.pm view on Meta::CPAN
undef $!;
$! = join(', ', @$err) if @$err;
}
}
}
sub rmtree(_;@) {
my $err;
remove_tree(@_, { error => \$err });
undef $!;
$! = join(', ', @$err) if @$err;
}