view release on metacpan or search on metacpan
lib/App/MiseEnPlace.pm view on Meta::CPAN
my( $self , $opt , $args ) = @_;
$self->usage_error( "No args needed" ) if @$args;
if ( $opt->{version} ) {
say $App::MiseEnPlace::VERSION;
exit;
}
$self->config_file( $opt->{config} ) if $opt->{config};
$self->verbose( $opt->{verbose} ) if $opt->{verbose};
lib/App/MiseEnPlace.pm view on Meta::CPAN
}
my $home = $self->homedir();
if ( $msg ) {
$dir =~ s/^$home/~/;
say "[ DIR] $msg $dir";
}
}
sub _create_link {
my( $self , $linkpair ) = @_;
lib/App/MiseEnPlace.pm view on Meta::CPAN
my $home = $self->homedir();
if ( $msg ) {
$src =~ s/^$home/~/;
$target =~ s/^$home/~/;
say "[LINK] $msg $src -> $target";
}
}
sub _load_configs {
my( $self ) = shift;
unless ( -e $self->config_file() ) {
say "Whoops, it looks like you don't have a " . $self->config_file() . " file yet.";
say "Please review the documentation, create one, and try again.";
exit;
}
my $base_config = _load_config_file( $self->config_file() );
lib/App/MiseEnPlace.pm view on Meta::CPAN
my $config;
try { $config = LoadFile( glob($file) ) }
catch {
say "Failed to parse config file $file:\n\t$_";
exit;
};
return $config;
}
lib/App/MiseEnPlace.pm view on Meta::CPAN
$target = $self->bindir() if $target =~ m'BIN$';
$target = path($target, $src_base)->stringify()
if path($target)->is_dir() and ! path( $src )->is_dir();
if (exists $link_targets{$target} ) {
say "ERROR: Attempting to create multiple links to the same target:";
printf "%s -> %s\n%s -> %s\n" ,
$link_targets{$target} , $target , $src , $target;
}
$link_targets{$target} = $src;
lib/App/MiseEnPlace.pm view on Meta::CPAN
next unless -l $path;
$path->remove();
say colored('UNLINK' , 'bright_red' ) , " ~/bin/$_"
if $opt->{verbose};
}
closedir( $dh );
}
view release on metacpan or search on metacpan
t/modules/Helloworld.mom view on Meta::CPAN
return "Printer";
};
sub sayhello {
my ($self) = shift;
$self->modularizer()->mlog(99, "Helloworld will say hello now");
$self->modularizer()->module('Printer')->
printer("Hello, World!\n");
return;
};
view release on metacpan or search on metacpan
lib/App/ModuleBuildTiny.pm view on Meta::CPAN
insert_options(\%opts, $config);
my $dist = App::ModuleBuildTiny::Dist->new(%opts, regenerate => \%files);
my @generated = grep { $files{$_} } $dist->files;
for my $filename (@generated) {
say "Updating $filename" if $opts{verbose};
write_binary($filename, $dist->get_file($filename)) if !$opts{dry_run};
}
if ($opts{commit}) {
require Git::Wrapper;
lib/App/ModuleBuildTiny.pm view on Meta::CPAN
my @changes = $dist->get_changes;
my $version = 'v' . $dist->version;
my $message = $opts{message} || ($opts{bump} ? join '', $version, "\n\n", @changes : 'Regenerate');
$git->commit({ m => $message }, @dirty);
} else {
say "No modifications to commit";
}
}
}
my %prompt_for = (
lib/App/ModuleBuildTiny.pm view on Meta::CPAN
my $reqs = $prereqs->merged_requirements(\@phases);
$reqs->clear_requirement('perl');
my @modules = sort { lc $a cmp lc $b } $reqs->required_modules;
if ($opts{versions}) {
say "$_ = ", $reqs->requirements_for_module($_) for @modules;
}
else {
say for @modules;
}
}
else {
print JSON::MaybeXS->new->ascii->canonical->pretty->encode($prereqs->as_string_hash);
}
lib/App/ModuleBuildTiny.pm view on Meta::CPAN
elsif ($mode eq 'get') {
my ($key, $value) = @arguments;
my ($item) = grep { $_->[0] eq $key } @config_items;
die "No such known key $key" if not $item;
my (undef, $description, $type, $default) = @{$item};
say show_item($config, $key, $type);
}
elsif ($mode eq 'set') {
my ($key, $value) = @arguments;
my $item = grep { $_->[0] eq lc $key } @config_items;
die "No such known key $key" if not $item;
lib/App/ModuleBuildTiny.pm view on Meta::CPAN
write_json($config_file, $config);
}
elsif ($mode eq 'list') {
for my $item (@config_items) {
my ($key, $description, $type, $default) = @{$item};
say "$key: " . show_item($config, $key, $type);
}
}
elsif ($mode eq 'reset') {
return not unlink $config_file;
}
lib/App/ModuleBuildTiny.pm view on Meta::CPAN
elsif ($mode eq 'get') {
my ($key, $value) = @arguments;
my ($item) = grep { $_->[0] eq $key } @config_items;
die "No such known key $key" if not $item;
my (undef, $description, $type, $default) = @{$item};
say show_item($config, $key, $type);
}
elsif ($mode eq 'set') {
my ($key, $value) = @arguments;
my $item = grep { $_->[0] eq lc $key } @config_items;
die "No such known key $key" if not $item;
lib/App/ModuleBuildTiny.pm view on Meta::CPAN
write_json($config_file, $config);
}
elsif ($mode eq 'list') {
for my $item (@items) {
my ($key, $description, $type, $default) = @{$item};
say "$key: " . show_item($config, $key, $type);
}
}
elsif ($mode eq 'reset') {
return not unlink $config_file;
}
lib/App/ModuleBuildTiny.pm view on Meta::CPAN
}
return 0;
},
version => sub {
say $VERSION;
},
);
sub modulebuildtiny {
my ($action, @arguments) = @_;
view release on metacpan or search on metacpan
lib/App/MonM/Notifier/Monotifier.pm view on Meta::CPAN
my $self = shift;
return $self->{store};
}
sub raise {
my $self = shift;
say STDERR red(@_);
return 0;
}
__PACKAGE__->register_handler(
handler => "info",
lib/App/MonM/Notifier/Monotifier.pm view on Meta::CPAN
$tbl->row("Attempt", $info{attempt}) if $info{attempt};
$tbl->row("Errcode", $info{errcode} // 0);
$tbl->row("Errmsg", encode( locale => $info{errmsg} // '' ));
$tbl->hr;
$tbl->row("SUMMARY", ($exp < time) ? "EXPIRED" : $info{status} // '');
say $tbl->draw();
# Show attributes (dump)
if ($self->verbosemode) {
say "Attributes of channel:";
print(explain($info{attributes}));
print "\n";
# Show message
printf("%s BEGIN MESSAGE ~~~\n", "~" x (SCREENWIDTH()-18));
say encode( locale => $info{message} // '' );
printf("%s END MESSAGE ~~~\n", "~" x (SCREENWIDTH()-16));
}
} else {
my @table = $store->getAll(ROWS_LIMIT);
return $self->raise($store->error) if $store->error;
lib/App/MonM/Notifier/Monotifier.pm view on Meta::CPAN
$rec->[11] // '', # status
$rec->[12] // 0, # errcode
);
push @errors, $rec->[13] if $rec->[12];
}
say $tbl->draw();
if ($self->verbosemode && @errors) {
foreach my $err (@errors) {
say magenta($err);
}
}
}
return 1;
view release on metacpan or search on metacpan
lib/App/MonM.pm view on Meta::CPAN
=cut
use vars qw/ $VERSION /;
$VERSION = '1.09';
use feature qw/ say /;
use Text::SimpleTable;
use File::Spec;
use File::stat qw//;
use Text::ParseWords qw/shellwords quotewords/;
lib/App/MonM.pm view on Meta::CPAN
return $self; # CTK requires!
}
sub raise {
my $self = shift;
say STDERR red(@_);
$self->log_error(sprintf(shift, @_));
return 0;
}
sub store {
my $self = shift;
lib/App/MonM.pm view on Meta::CPAN
},
-debug => $self->verbosemode,
);
printf("Installing configuration to \"%s\"...\n", $dir);
if ($skel->build("config")) {
say green("Done. Configuration has been installed");
} else {
return $self->raise("Can't install configuration");
}
return 1;
lib/App/MonM.pm view on Meta::CPAN
print $result ? green(MARKER_OK) : red(MARKER_FAIL);
printf(" %s (%s >>> %s)\n", $name, $checker->source, $checker->message);
if ($self->verbosemode) {
printf "%sStatus=%s; Code=%s\n", TAB9,
$checker->status || 0, $checker->code // '';
say TAB9, $checker->note;
if (defined($checker->content) && length($checker->content)) {
$Text::Wrap::columns = SCREENWIDTH - 10;
say TAB9, "-----BEGIN CONTENT-----";
say wrap(TAB9, TAB9, lf_normalize($checker->content));
say TAB9, "-----END CONTENT-----";
}
}
if ($result && !$checker->status) {
wow("%s", $checker->error);
} elsif (!$result) {
lib/App/MonM.pm view on Meta::CPAN
$ostat ? $ostat > 0 ? 'PASSED' : 'UNKNOWN' : 'FAILED',
);
unless ($ostat) {
push @errors, sprintf("%s (%s >>> %s)", $name, $info->{source} || '', $info->{message} || ''), "";
}
#say(explain($info));
}
$tbl->hr;
}
$tbl->row('SUMMARY', "", "", $noc ? $status ? 'PASSED' : 'FAILED' : 'UNKNOWN');
lib/App/MonM.pm view on Meta::CPAN
);
}
$tbl->hr;
$tbl->row('SUMMARY', "", "", "", "", "", $status ? 'PASSED' : 'FAILED');
say $tbl->draw();
return $status;
});
sub trigger {
lib/App/MonM.pm view on Meta::CPAN
my $exe_out = execute($cmd, undef, \$exe_err);
my $exe_stt = ($? >> 8) ? 0 : 1;
if ($exe_stt) {
my $msg = sprintf("# %s", $cmd);
print cyan MARKER_INFO;
say " ", $msg;
$self->log_info($msg);
if (defined($exe_out) && length($exe_out) && $self->verbosemode) {
say $exe_out if IS_TTY;
$self->log_info($exe_out);
}
} else {
my $msg = sprintf("Can't execute trigger %s", $cmd);
print red MARKER_FAIL;
say " ", $msg;
$self->log_error($msg);
push @errs, $msg;
if ($exe_err) {
chomp($exe_err);
nope($exe_err);
lib/App/MonM.pm view on Meta::CPAN
my $sendto = $args{sendto} || [];
my $subject = $args{subject};
my @errors;
my $errs = $args{errors};
push @errors, @$errs if is_array($errs);
#say(explain(\%args));
# Header
my @header;
push @header, (
["Checkit", $name], # Checkit name
lib/App/MonM.pm view on Meta::CPAN
my $msg = $this->channel->error
? sprintf("Message was not sent to %s: %s", $message->recipient, $this->channel->error)
: sprintf("Message has been sent to %s", $message->recipient);
if ($this->channel->error) { print red MARKER_FAIL }
else { print cyan MARKER_INFO }
say " ", $msg;
$self->log_debug($msg);
} else {
my $err = sprintf("Message was not sent to %s: %s", $message->recipient, $this->channel->error || "unknown error");
print red MARKER_FAIL;
print " ";
view release on metacpan or search on metacpan
</div>
Each menu item looks like this: [% item label1 some_text %]. If it is called as
[% menu label1 %] it will produce some_text, and all double curly brackets {{ }}
are simply stripped, but the text between them remains.
If it is called with a different name, say [% menu label2 %] the curly brackets
and the text between them are stripped.
SYNTAX HILIGHTING
If you have both the Perl module Text::VimColor and Vim installed, you can use
view release on metacpan or search on metacpan
#### # $this->std_msg($host, $cmdno, 0, RED.'-- error: unexpected child exit --');
# NOTE: though, the exit value may indicate an actual error.
if( (my $exit = $_[ARG2]) != 0 ) {
# XXX: I'd like to do more here but I'm waiting to see what Paul
# Fenwick has to say about it.
$exit >>= 8;
my $reset = RESET;
my $black = BOLD.BLACK;
my $red = RESET.RED;
view release on metacpan or search on metacpan
use Data::Dumper;
use P9Y::ProcessTable;
my @process_table = P9Y::ProcessTable->table;
say Dumper \@process_table;
https://metacpan.org/pod/P9Y::ProcessTable
bless( {
view release on metacpan or search on metacpan
lib/App/Multigit.pm view on Meta::CPAN
my @result = $future->get;
my $natatime = List::MoreUtils::natatime(10, @result);
while (my %data = $natatime->()) {
say $data{stdout};
}
However, the C<%data> hashes do not contain repository information; just the
output. It is expected that if repository information is required, the closure
form is used.
view release on metacpan or search on metacpan
lib/ChordPro/lib/SVGPDF/Element.pm view on Meta::CPAN
method _paintsub () {
if ( $style->{stroke}
&& $style->{stroke} ne 'none'
&& $style->{stroke} ne 'transparent'
# Hmm. Saw a note somewhere that it defaults to 0 but other notes
# say that it should be 1px...
&& $style->{'stroke-width'}//1 != 0
) {
if ( $style->{fill}
&& $style->{fill} ne 'none'
&& $style->{fill} ne 'transparent'
view release on metacpan or search on metacpan
bin/atonal-util view on Meta::CPAN
unless @base_input;
$Lyu->chrome('flats') if $Flag_Flat;
for my $bi (@base_input) {
say "PS $bi" if @base_input > 1;
my $ps_base;
if ( $bi =~ m/^\d-/ ) {
$ps_base = $Atu->forte2pcs($bi);
die "unknown Forte Number '$bi'\n" if !defined $ps_base;
bin/atonal-util view on Meta::CPAN
@pitches = $Lyu->p2ly(@pitches) if $Flag_Lyout;
my $s = sprintf "%s\tT(%d)\t%-${ps_width}s%s", $fnum, $i,
join( ',', @pitches ), $tstr;
$s =~ s/\s+$//;
say $s;
}
}
TRANSINV: for my $i ( 0 .. $Atu->scale_degrees - 1 ) {
my %ips;
bin/atonal-util view on Meta::CPAN
@pitches = $Lyu->p2ly(@pitches) if $Flag_Lyout;
my $s = sprintf "%s\tTi(%d)\t%-${ps_width}s%s", $fnum, $i,
join( ',', @pitches ), $tstr;
$s =~ s/\s+$//;
say $s;
}
}
}
sub fnums {
bin/atonal-util view on Meta::CPAN
}
my $s = sprintf "%s\t%-16s\t%-8s%s", $fn, join( ',', @$pset ),
join( '', @$icc ), $tstr;
$s =~ s/\s+$//;
say $s;
}
}
sub forte2pcs {
my (@args) = @_;
view release on metacpan or search on metacpan
public/javascripts/ace/mode-php.js view on Meta::CPAN
"bool openssl_pkcs7_sign(string infile, string outfile, mixed signcert, mixed signkey, array headers [, long flags [, string extracertsfilename]])",
"Signs the MIME message in the file named infile with signcert/signkey and output the result to file name outfile. headers lists plain text headers to exclude from the signed portion of the message, and should include to, from and subject as ...
],
"openssl_pkcs7_verify": [
"bool openssl_pkcs7_verify(string filename, long flags [, string signerscerts [, array cainfo [, string extracerts [, string content]]]])",
"Verifys that the data block is intact, the signer is who they say they are, and returns the CERTs of the signers"
],
"openssl_pkey_export": [
"bool openssl_pkey_export(mixed key, &mixed out [, string passphrase [, array config_args]])",
"Gets an exportable representation of a key into a string or file"
],
view release on metacpan or search on metacpan
lib/App/MyPerl.pm view on Meta::CPAN
# ~/.myperl/defaults/modules
v5.14
# ~/some_scripts/script.pl
say "Hello World"
The syntax for the modules file is,
=over
lib/App/MyPerl.pm view on Meta::CPAN
$ myperl ~/some_scripts/script.pl
will print C<Hello World>.
Let's say you are working on a typical Perl module like,
.myperl/
lib/
t/
bin/
view release on metacpan or search on metacpan
bin/netdisco-deploy view on Meta::CPAN
additional steps might be required!
=cut
print color 'bold cyan';
say 'This is the Netdisco 2 deployment script.';
say '';
say 'Before we continue, the following prerequisites must be in place:';
say ' * Database added to PostgreSQL for Netdisco';
say ' * User added to PostgreSQL with rights to the Netdisco Database';
say ' * "~/environments/deployment.yml" file configured with Database dsn/user/pass';
say ' * A full backup of any existing Netdisco database data';
say ' * Internet access (for OUIs and MIBs)';
say '';
say 'If you are upgrading Netdisco 2 read the release notes:';
say 'https://github.com/netdisco/netdisco/wiki/Release-Notes';
say 'There you will find required and incompatible changes';
say 'which are not covered by this script.';
say '';
say 'You will be asked to confirm all changes to your system.';
say '';
print color 'reset';
my $term = Term::ReadLine->new('netdisco');
my $bool = $term->ask_yn(
prompt => 'So, is all of the above in place?', default => 'n',
);
exit(0) unless $bool;
say '';
$bool = $term->ask_yn(
prompt => 'Would you like to deploy the database schema?', default => 'n',
);
deploy_db() if $bool;
say '';
$bool = $term->ask_yn(
prompt => 'Download and update vendor MAC prefixes (OUI data)?', default => 'n',
);
deploy_oui() if $bool;
say '';
my $default_mibhome = dir($home, 'netdisco-mibs');
if (setting('mibhome') and setting('mibhome') ne $default_mibhome) {
my $mibhome = $term->get_reply(
print_me => "MIB home options:",
prompt => "Download and update MIB files to...?",
bin/netdisco-deploy view on Meta::CPAN
}
sub deploy_db {
system('netdisco-db-deploy') == 0 or die "\n";
print color 'bold blue';
say 'DB schema update complete.';
print color 'reset';
print color 'bold blue';
print 'Updating statistics... ';
App::Netdisco::Util::Statistics::update_stats();
say 'done.';
print color 'reset';
if (not setting('safe_password_store')) {
say '';
print color 'bold red';
say '*** WARNING: Weak password hashes are being stored in the database! ***';
say '*** WARNING: Please add "safe_password_store: true" to your ~/environments/deployment.yml file. ***';
print color 'reset';
}
sub _make_password {
my $pass = (shift || passphrase->generate_random);
bin/netdisco-deploy view on Meta::CPAN
? schema('netdisco')->storage->txn_scope_guard : undef;
# set up initial admin user
my $users = schema('netdisco')->resultset('User');
if ($users->search({-bool => 'admin'})->count == 0) {
say '';
print color 'bold green';
say 'We need to create a user for initial login. This user will be a full Administrator.';
say 'Afterwards, you can go to Admin -> User Management to manage users.';
print color 'reset';
say '';
my ($name, $pass) = get_userpass($term);
$users->create({
username => $name,
password => _make_password($pass),
admin => 'true',
port_control => 'true',
});
print color 'bold blue';
say 'New user created.';
print color 'reset';
}
# set initial dancer web session cookie key
schema('netdisco')->resultset('Session')->find_or_create(
bin/netdisco-deploy view on Meta::CPAN
my $upterm = shift;
my $name = $upterm->get_reply(prompt => 'Username: ');
my $pass = $upterm->get_reply(prompt => 'Password: ');
unless ($name and $pass) {
say 'username and password cannot be empty, please try again.';
($name, $pass) = get_userpass($upterm);
}
return ($name, $pass);
}
bin/netdisco-deploy view on Meta::CPAN
if ($resp->{success}) {
#Â by loading App::Netdisco, Configuration has set necessary psql env vars
system("psql -X -v ON_ERROR_STOP=0 -v ON_ERROR_ROLLBACK=on -q -f ${file}");
unlink $file;
say 'done.';
}
else {
print color 'bold red';
say 'SQL download failed!';
}
print color 'reset';
}
bin/netdisco-deploy view on Meta::CPAN
}
else { ++$fail }
if ($fail) {
print color 'bold red';
say 'MIB download failed!';
}
else {
print color 'bold blue';
say 'MIBs update complete.';
if (schema('netdisco')->resultset('SNMPObject')->count) {
print 'Updating SNMP Browser... ';
system('netdisco-do loadmibs --quiet');
say 'done.';
}
}
print color 'reset';
}
view release on metacpan or search on metacpan
lib/App/Netsync.pm view on Meta::CPAN
$node->{'session'} = $session;
$node->{'info'} = $info;
}
else { # Otherwise, consider it inactive.
note ($config{'NodeLog'},node_string ($node).' inactive');
say node_string ($node).' inactive' if $config{'Verbose'};
next;
}
# Retrieve the serials of devices at the node.
my $serial2if2ifName = device_interfaces ($node->{'info'}->vendor,$node->{'session'});
lib/App/Netsync.pm view on Meta::CPAN
node_initialize ($node,$serial2if2ifName);
$serial_count += @serials;
}
else { # Otherwise, consider the device unrecognized.
note ($config{'NodeLog'},node_string ($node).' unrecognized');
say node_string ($node).' unrecognized' if $config{'Verbose'};
next;
}
# Show the user what's been found if necessary.
node_dump $node if $config{'Verbose'};
lib/App/Netsync.pm view on Meta::CPAN
$fields .= ','.join (',',sort @{$config{'InfoFields'}});
my %inputs = (
'DB' => sub {
my %drivers = DBI->installed_drivers;
say $_ foreach values %drivers; exit; #XXX debug
unless (defined $config{'DB'}) {
warn 'A database has not been configured.';
return undef;
}
lib/App/Netsync.pm view on Meta::CPAN
else { # Log a failed update.
note ($config{'UpdateLog'},$note.' error: '.$error);
++$failed_update_count;
if ($config{'Verbose'}) {
say interface_string ($interface).' failed';
say ((' 'x$config{'Indent'}).$error);
}
}
}
}
}
view release on metacpan or search on metacpan
lib/App/Nopaste/Service/PastebinComAPI.pm view on Meta::CPAN
pastebin.com API key, C<YOUR_PASTEBIN_LOGIN_HERE> to your pastebin.com
login, and C<YOUR_PASTEBIN_PASSWORD_HERE> to your pastebin.com password:
perl -MWWW::Pastebin::PastebinCom::API -wle "print WWW::Pastebin::PastebinCom::API->new( api_key => q|YOUR_API_KEY_HERE|)->get_user_key(qw/YOUR_PASTEBIN_LOGIN_HERE YOUR_PASTEBIN_PASSWORD_HERE/);"
Note: pastebin.com/api has this to say about the user key:
C<if an invalid api_user_key or no key is used, the paste will be
created as a guest>.
=head1 SEE ALSO
view release on metacpan or search on metacpan
0.06 2008-12-03 21:50:36
Silence the "exiting eval via next" warning
0.05 2008-08-29 15:03:10
Allow specific pastebins to say "I don't want to be picked by default"
Apply this to Mathbin
0.04 2008-06-11 00:48:53
Add Mathbin courtesy of doy
Add an "available" method to services which checks Perl dependencies
view release on metacpan or search on metacpan
my ( $c ) = @_;
my $cmd = $c->cmd;
if($c->is_command($cmd) and not $cmd ~~ [qw( help init list show sync )]) {
sync( $c, push_only => 1 ) if auto_sync();
}
say $c->output if $c->output;
}
sub invalid {
my ( $c ) = @_;
my $cmd = $c->cmd;
my $dir = notes_dir();
my $repo = $ARGV[0];
my $output = capture {
if( $repo ) {
say "Initializing notes from $repo...";
Git::Repository->run( clone => $repo, $dir->stringify );
} else {
say "Initializing notes ($dir)...";
print Git::Repository->run( init => $dir->stringify );
}
}
}
sub list {
my ( $c ) = @_;
my $search = @ARGV > 0 ? join ' ', @ARGV : undef;
my $notes = find_notes( $c, search => get_filename( $search ) );
say $_->basename for @$notes;
return;
}
sub rename {
my ( $c ) = @_;
view release on metacpan or search on metacpan
lib/App/OCD.pm view on Meta::CPAN
decided to release them as separate modules. This will also allow me
to add new demos and evolve them without requiring pointless version
updates to the original module.
For the most part, the demos in this name space will be focused on
I<multicast> applications, which is to say that one machine will be
sending data (eg, a data structure or a file) over a network, where it
may be received by multiple receivers at once. Using multicast to send
to multiple receivers like this is very efficient since it only
requires slightly more bandwidth than the equivalent unicast (single
sender, single reciever) file transfers would take.
view release on metacpan or search on metacpan
use lib "$FindBin::Bin/../lib";
use App::OS::Detect::MachineCores;
say App::OS::Detect::MachineCores->new_with_options->cores;
=begin wikidoc
= SYNOPSIS
view release on metacpan or search on metacpan
lib/App/Office/CMS/Database.pm view on Meta::CPAN
eval {
$dbh->do('insert into non_extistent_table values(1)')
};
if (my $e = Exception::Class->caught('Exception::Class::DBI')) {
say $e->err;
say $e->errstr;
} else {
# Check for other exceptions as required
}
=cut
view release on metacpan or search on metacpan
lib/App/Office/Contacts/Import/vCards/Controller/Import.pm view on Meta::CPAN
my($status);
if ($result -> success)
{
# The output from report_add() is too complex to display without further work,
# so we rig the output to say OK.
$status = $self -> param('view') -> person -> report_add($self -> param('user_id'), $result);
$status = 'OK';
}
else
view release on metacpan or search on metacpan
scripts/check.org.cgi.fields.pl view on Meta::CPAN
}
@form_list = map{s/organization/org/; $_} @form_list;
my($compare) = List::Compare -> new(\@add_list, \@form_list);
say 'Report for add_org logic:';
say 'Items in the add list only:';
say map{"$_\n"} $compare -> get_unique;
say 'Items in the form list only:';
say map{"$_\n"} $compare -> get_complement;
say '-' x 50;
$compare = List::Compare -> new(\@update_list, \@form_list);
say 'Report for update_org logic:';
say 'Items in the update list only:';
say map{"$_\n"} $compare -> get_unique;
say 'Items in the form list only:';
say map{"$_\n"} $compare -> get_complement;
say '-' x 50;
view release on metacpan or search on metacpan
eg/workflows/cpan-sample-workflow/get-config.pl view on Meta::CPAN
if ( $OPT{nosleep} ) {
INFO "Skipping sleep ...";
}
else {
#
# A sleep might increase randomization of some settings, if lets say you
# are collecting some database node addresses from a service which can
# shuffle result sets based on the load it detects.
#
# This can especially be useful for jobs creating too many fork paths
# and calling this program to collect configuration, which might lead to
view release on metacpan or search on metacpan
lib/App/OperaUtils.pm view on Meta::CPAN
summary => "Check whether Opera is running",
description => <<'_',
Opera is defined as running if there are some Opera processes that are *not*
in 'stop' state. In other words, if Opera has been started but is currently
paused, we do not say that it's running. If you want to check if Opera process
exists, you can use `ps_opera`.
_
args => {
%App::BrowserUtils::args_common,
lib/App/OperaUtils.pm view on Meta::CPAN
Check whether Opera is running.
Opera is defined as running if there are some Opera processes that are I<not>
in 'stop' state. In other words, if Opera has been started but is currently
paused, we do not say that it's running. If you want to check if Opera process
exists, you can use C<ps_opera>.
This function is not exported.
Arguments ('*' denotes required arguments):
view release on metacpan or search on metacpan
lib/App/Options.pm view on Meta::CPAN
sub file_is_secure {
my ($file) = @_;
my ($secure, $dir);
my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks);
if ($^O =~ /MSWin32/) {
$secure = 1; # say it is without really checking
}
else {
$secure = $path_is_secure{$file};
if (!defined $secure) {
($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = stat($file);
view release on metacpan or search on metacpan
script/count-done-org-todos view on Meta::CPAN
sub {
my $el = shift;
$n++ if $el->isa('Org::Element::Headline') && $el->is_done;
});
say $n;
# ABSTRACT: Count todos which are done in Org document
# PODNAME: count-done-org-todos
__END__
view release on metacpan or search on metacpan
lib/App/PAIA/Agent.pm view on Meta::CPAN
};
}
sub dump {
my ($self, $msg) = @_;
# say ":$msg";
$self->{dumper}->($msg);
}
sub dump_request {
my ($self, $method, $url, $headers, $content) = @_;
view release on metacpan or search on metacpan
lib/App/PDRUtils/DistIniCmd/sort_prereqs.pm view on Meta::CPAN
}
$iod->_discard_cache;
my $new_content = $iod->as_string;
#say $new_content;
my $modified = $old_content ne $new_content;
if ($modified) {
return [200, "Sorted prereqs", $iod];
} else {
view release on metacpan or search on metacpan
lib/App/PFT/Util.pm view on Meta::CPAN
my($from, $to, $verbose) = @_;
my $ok;
-e $to && remove_tree $to, {verbose => $verbose};
make_path dirname $to;
$verbose and say STDERR "Linking $from to $to";
$ok = link($from, $to);
$ok and return 1;
$verbose and say STDERR "Could not hardlink: $!. Symlinking";
$ok = eval { symlink($from, $to) };
$ok and return 1;
$verbose and say STDERR "Could not symlink: $@$!. Copying";
remove_tree $to, {verbose => $verbose};
$ok = dircopy $from, $to;
$ok and return 1;
$verbose and say STDERR "Everything failed";
return '';
}
1;