Perl Blog Archive

into · second

<a href="/">Home</a> |
<a href="/contact">Contact</a> |
[etc.]

/something/deeper
/
uri_for()
uri_for
<a href="<% uri_for('/') %>">Home</a> |
<a href="<% uri_for('contact') %>">Contact</a> |
[etc.]

http://localhost:3000/
http://localhost:3000/contact

Dancer::before_template has been deprecated since version 1.3080. use hooks!
But use hook 'before_template' => sub {} now instead.
hook 'before_template' => sub {
    my $tokens = shift;
    $tokens->{uri_for} = \&uri_for;
};

my $new_path = '/accessories/' .
   Vend::Tags->filter({body => (join '%2f' => (grep { /\D/ } @path)),
       op => 'urlencode', }) .
   '.html';

@x = (1, 1, 1);  # @x is a list of three 1s
# vs.
$x = (1, 1, 1);  # $x is "3", the list size

my $hr = {
  KEY1 => $value1,
  KEY2 => $value2,
  KEY_TROUBLE => (defined($foo) ? mysub($foo) : 1),
  KEY3 => $value3,
};

1 => (2, 3, 4)

1, 2, 3, 4

use strict;
use Data::Dumper;

my($value1,$value2,$value3,$foo) = qw(value1 value2 value3 foo);

my $hr = {
  KEY1 => $value1,
  KEY2 => $value2,
  KEY_TROUBLE => (defined($foo) ? mysub($foo) : 1),
  KEY3 => $value3,
};

print Data::Dumper->Dumper($hr);

sub mysub {
  return qw(junk extrajunk);
}

$VAR1 = 'Data::Dumper';
$VAR2 = {
          'extrajunk' => 'KEY3',
          'KEY2' => 'value2',
          'KEY1' => 'value1',
          'value3' => undef,
          'KEY_TROUBLE' => 'junk'
        };

sub is_yes {
   return( defined($_[0]) && ($_[0] =~ /^[yYtT1]/));
}

ERROR: cannot allocate multiple Perl 
interpreters on this platform
$ perl -V | grep multi
 useithreads=define, usemultiplicity=define

$ perl -V | grep multi
 useithreads=undef, usemultiplicity=undef

postgres=# \c test postgres
You are now connected to database "test" as user "postgres".

test=# create language plperl;
CREATE LANGUAGE

test=# create language plperlu;
CREATE LANGUAGE

test=# create or replace function test_perlver()
test-# returns text
test-# language plperl
test-# AS $$ return "Running test_perlver on Perl $^V"; $$;
CREATE FUNCTION

test=# create or replace function test_perlverU()
test-# returns text
test-# language plperlU
test-# AS $$ return "Running test_perlverU on Perl $^V"; $$;
ERROR:  cannot allocate multiple Perl interpreters on this platform
CONTEXT:  compilation of PL/Perl function "test_perlveru"

test=# \c test postgres
You are now connected to database "test" as user "postgres".

test=# create or replace function test_perlverU()
test-# returns text
test-# language plperlU
test-# AS $$ return "Running test_perlverU on Perl $^V"; $$;
CREATE FUNCTION

test=# \c test postgres
You are now connected to database "test" as user "postgres".

test=# select test_perlver();
             test_perlver
--------------------------------------
 Running test_perlver on Perl v5.10.0

test=# select test_perlverU();
ERROR:  cannot allocate multiple Perl interpreters on this platform
CONTEXT:  compilation of PL/Perl function "test_perlveru"

test=# \c test postgres
You are now connected to database "test" as user "postgres".

test=# select test_perlverU();
             test_perlveru
---------------------------------------
 Running test_perlverU on Perl v5.10.0

test=# select test_perlver();
ERROR:  cannot allocate multiple Perl interpreters on this platform
CONTEXT:  compilation of PL/Perl function "test_perlver"

postgres=# create database test;
CREATE DATABASE

postgres=# \c test postgres
You are now connected to database "test" as user "postgres".

test=# create language plperl;
CREATE LANGUAGE

test=# create or replace function foo()
test-# returns text
test-# language plperl
test-# security invoker
test-# AS $$ return "Running as security invoker"; $$;
CREATE FUNCTION

test=# create or replace function bar()
test-# returns text
test-# language plperl
test-# security definer
test-# AS $$ return "Running as security definer"; $$;
CREATE FUNCTION

test=# \c test postgres
You are now connected to database "test" as user "postgres".

test=# SELECT foo();
           foo
-----------------------------
 Running as security invoker
(1 row)

test=# SELECT bar();
           bar
-----------------------------
 Running as security definer
(1 row)

test=# \c test greg
You are now connected to database "test" as user "greg".

test=# SELECT foo();
           foo
-----------------------------
 Running as security invoker
(1 row)

test=# SELECT bar();
ERROR:  cannot allocate multiple Perl interpreters on this platform
CONTEXT:  compilation of PL/Perl function "bar"

test=# \c test greg
You are now connected to database "test" as user "greg".

test=# SELECT bar();
           bar
-----------------------------
 Running as security definer
(1 row)

test=# SELECT foo();
ERROR:  cannot allocate multiple Perl interpreters on this platform
CONTEXT:  compilation of PL/Perl function "foo"

ulimit
/etc/security/limits.conf
@sorted = sort {(
        ($a->{flag} xor ($a->{quantity} > 0 xor $delta > 0))
        <=>
        ($b->{flag} xor ($b->{quantity} > 0 xor $delta > 0))
) || abs($a->{quantity} <=> abs($b->{quantity})} @items;
my $string = q{Your transaction could not be} .
   q{ processed due to a charge} .
   q{ card error.};
return $string;

$ git grep 'could not be processed'
$ git grep 'charge card error'
$ git grep -e 'transaction.*charge.*error'
$ alsdkjgalkghkf

my $string = <<'MSG';
Your transaction could not be processed due to a charge card error.
MSG
return $string;

## English: "sorry, too many clients already"
## Japanese: "現在クライアント数が多すぎます"
## French expected: "désolé, trop de clients sont déjà connectés"
## French actual: "d�sol�, trop de clients sont d�j� connect�s"
#!perl

use strict;
use warnings;
use utf8;

my $msg = 'This is a micro symbol: µ';

print "print = $msg\n";
warn "warn = $msg\n";
die "die = $msg\n";
print = This is a micro symbol: �
warn = This is a micro symbol: µ
die = This is a micro symbol: µ
#!perl

use strict;
use warnings;
use utf8;

my $msg = 'This is a micro symbol: µ';
my $alert = 'The radioactive snowmen come in peace: ☢ ☃☃☃ ☮';

print STDOUT "print to STDOUT = $msg\n";
print STDOUT "print to STDOUT = $alert\n";

print STDERR "print to STDERR = $msg\n";
print STDERR "print to STDERR = $alert\n";

warn "warn = $msg\n";
warn "warn = $alert\n";

print to STDOUT = This is a micro symbol: �
Wide character in print at utf12 line 11.
print to STDOUT = The radioactive snowmen come in peace: ☢ ☃☃☃ ☮
print to STDERR = This is a micro symbol: �
Wide character in print at utf12 line 14.
print to STDERR = The radioactive snowmen come in peace: ☢ ☃☃☃ ☮
warn = This is a micro symbol: µ
warn = The radioactive snowmen come in peace: ☢ ☃☃☃ ☮
binmode STDOUT, ':utf8';
print to STDOUT = This is a micro symbol: µ
print to STDOUT = The radioactive snowmen come in peace: ☢ ☃☃☃ ☮
print to STDERR = This is a micro symbol: �
Wide character in print at utf12 line 16.
print to STDERR = The radioactive snowmen come in peace: ☢ ☃☃☃ ☮
warn = This is a micro symbol: µ
warn = The radioactive snowmen come in peace: ☢ ☃☃☃ ☮
my %hash = (aaa => 1, bbb => 2);
    use Hash::Util qw(lock_keys);
    lock_keys(%hash);
    $hash{ccc};
    Attempt to access disallowed key 'ccc' in a restricted hash
    my %hash;
    lock_keys(%hash, qw(aaa bbb ccc));
    if ($hash{record_type} eq 'A') {
        # validate %hash for aaa, bbb, ccc
    }
    else {
        # validate %hash for aaa, bbb, ddd; ccc should not appear
    }
    my %hash;
    lock_keys(%hash, qw(record_type aaa bbb ccc));
    # …
    unlock_keys(%hash);
    if ($hash{record_type} eq 'A') {
        lock_keys(%hash, qw(record_type aaa bbb ccc));
    }
    else {
        lock_keys(%hash, qw(record_type aaa bbb ddd));
    }
    lock_keys_plus(%hash, qw(ddd));
    lock_keys_plus(%hash, (legal_keys(%hash), qw(more keys here)));
    lock_ref_keys($hr);
    unlock_ref_keys($hr);
    lock_ref_keys_plus($hr, (legal_ref_keys($hr), qw(other keys)));
    if ($opt->{order_status})
BEGIN;

SELECT weapon_details('BFG 9000'); -- also inserts to an audit table

ROLLBACK;                          -- inserts to the audit table are now gone!

postgres=> CREATE USER alice;
CREATE ROLE

postgres=> CREATE TYPE classification AS ENUM (
 'unclassified',
 'restricted',
 'confidential',
 'secret',
 'top secret'
);
CREATE TYPE

postgres=> CREATE TABLE weapon (
  id              SERIAL          PRIMARY KEY,
  name            TEXT            NOT NULL,
  cost            TEXT            NOT NULL,
  security_level  CLASSIFICATION  NOT NULL,
  description     TEXT            NOT NULL DEFAULT 'a fine weapon'
);
NOTICE:  CREATE TABLE will create implicit sequence "weapon_id_seq" for serial column "weapon.id"
NOTICE:  CREATE TABLE / PRIMARY KEY will create implicit index "weapon_pkey" for table "weapon"
CREATE TABLE

postgres=> INSERT INTO weapon (name,cost,security_level) VALUES
 ('Crowbar',  10,  'unclassified'),
 ('M9',  200,  'restricted'),
 ('M16A2',  300,  'restricted'),
 ('M4A1',  400,  'restricted'),
 ('FGM-148 Javelin',  700,  'confidential'),
 ('Pulse Rifle',  50000,  'secret'),
 ('Zero Point Energy Field Manipulator',  'unknown',  'top secret');
INSERT 0 7

postgres=> \dp weapon
                          Access privileges
 Schema |  Name  | Type  | Access privileges | Column access privileges 
--------+--------+-------+-------------------+--------------------------
 public | weapon | table |                   | 

postgres=> REVOKE ALL ON TABLE weapon FROM public;
REVOKE

postgres=> \dp weapon
                               Access privileges
 Schema |  Name  | Type  |     Access privileges     | Column access privileges 
--------+--------+-------+---------------------------+--------------------------
 public | weapon | table | postgres=arwdDxt/postgres | 

postgres=> \c postgres alice
You are now connected to database "postgres" as user "alice".
postgres=> postgres=> SELECT * FROM weapon;
ERROR:  permission denied for relation weapon
postgres=> postgres=> UPDATE weapon SET id = id;
ERROR:  permission denied for relation weapon

postgres=> CREATE LANGUAGE plperlu;
CREATE LANGUAGE

postgres=> CREATE OR REPLACE FUNCTION weapon_details(TEXT)
RETURNS TABLE (name TEXT, cost TEXT, description TEXT)
LANGUAGE plperlu
SECURITY DEFINER
AS $bc$

use strict;
use warnings;

## The item they are looking for
my $name = shift;
## We will be nice and ignore the case and any whitespace
$name =~ s{^\s*(\S+)\s*$}{lc $1}e;

## What is the maximum security_level that people who are 
## calling this function can view?
my $seclevel = 'confidential';

## Query the table and pull back the matching row
## We need to differentiate between "not found" and "not allowed",
## by comparing a passed-in level to the security_level for that row.
my $SQL = q{
SELECT name,cost,description,
  CASE WHEN security_level <= $1 THEN 1 ELSE 0 END AS allowed
FROM weapon
WHERE LOWER(name) = $2};

## Run the query, pull back the first row, as well as the allowed column value
my $sth = spi_prepare($SQL, 'CLASSIFICATION', 'TEXT');
my $rv = spi_exec_prepared($sth, $seclevel, $name);
my $row = $rv->{rows}[0];
my $allowed = delete $row->{allowed};

## Did we find anything? If not, simply return undef
if (! $rv->{processed}) {
   return undef;
}

## Throw an exception if we are not allowed to view this row
if (! $allowed) {
   die qq{Sorry, you are not allowed to view information on that weapon!\n};
}

## Return the requested data
return_next($row);

$bc$;
CREATE FUNCTION

postgres=> \c postgres alice
You are now connected to database "postgres" as user "alice".

postgres=> SELECT * FROM weapon_details('crowbar');
  name   | cost |  description  
---------+------+---------------
 Crowbar | 10   | a fine weapon
(1 row)

postgres=> SELECT * FROM weapon_details('anvil');
 name | cost | description 
------+------+-------------
(0 rows)

postgres=> SELECT * FROM weapon_details('pulse rifle');
ERROR:  Sorry, you are not allowed to view information on that weapon!
CONTEXT:  PL/Perl function "weapon_details"

postgres=> CREATE TABLE data_audit (
  tablename TEXT         NOT NULL,
  arguments TEXT             NULL,
  results   INTEGER          NULL,
  status    TEXT         NOT NULL  DEFAULT 'normal',
  username  TEXT         NOT NULL  DEFAULT session_user,
  txntime   TIMESTAMPTZ  NOT NULL  DEFAULT now(),
  realtime  TIMESTAMPTZ  NOT NULL  DEFAULT clock_timestamp()
);
CREATE TABLE

postgres=> CREATE OR REPLACE FUNCTION weapon_details(TEXT)
RETURNS TABLE (name TEXT, cost TEXT, description TEXT)
LANGUAGE plperlu
SECURITY DEFINER
AS $bc$

use strict;
use warnings;

## The item they are looking for
my $name = shift;
## We will be nice and ignore the case and any whitespace
$name =~ s{^\s*(\S+)\s*$}{lc $1}e;

## What is the maximum security_level that people who are 
## calling this function can view?
my $seclevel = 'confidential';

## Query the table and pull back the matching row
## We need to differentiate between "not found" and "not allowed",
## by comparing a passed-in level to the security_level for that row.
my $SQL = q{
SELECT name,cost,description,
  CASE WHEN security_level <= $1 THEN 1 ELSE 0 END AS allowed
FROM weapon
WHERE LOWER(name) = $2};

## Run the query, pull back the first row, as well as the allowed column value
my $sth = spi_prepare($SQL, 'CLASSIFICATION', 'TEXT');
my $rv = spi_exec_prepared($sth, $seclevel, $name);
my $row = $rv->{rows}[0];
my $allowed = delete $row->{allowed};

## Log this request
$SQL = 'INSERT INTO data_audit(tablename,arguments,results,status)
  VALUES ($1,$2,$3,$4)';
my $status = $rv->{rows}[0] ? $allowed ? 'normal' : 'forbidden' : 'na';
$sth = spi_prepare($SQL, 'TEXT', 'TEXT', 'INTEGER', 'TEXT');
spi_exec_prepared($sth, 'weapon', $name, $rv->{processed}, $status);

## Did we find anything? If not, simply return undef
if (! $rv->{processed}) {
   return undef;
}

## Throw an exception if we are not allowed to view this row
if (! $allowed) {
   die qq{Sorry, you are not allowed to view information on that weapon!\n};
}

## Return the requested data
return_next($row);

$bc$;

postgres=> \c postgres alice
You are now connected to database "postgres" as user "alice".

postgres=> SELECT * FROM weapon_details('crowbar');
  name   | cost |  description  
---------+------+---------------
 Crowbar | 10   | a fine weapon
(1 row)

postgres=> SELECT * FROM weapon_details('pulse rifle');
ERROR:  Sorry, you are not allowed to view information on that weapon!
CONTEXT:  PL/Perl function "weapon_details"

postgres=> BEGIN;
BEGIN
postgres=> SELECT * FROM weapon_details('m9');
 name | cost |  description  
------+------+---------------
 M9   | 200  | a fine weapon
(1 row)
postgres=> ROLLBACK;
ROLLBACK

postgres=> \c postgres postgres
You are now connected to database "postgres" as user "postgres".
postgres=> SELECT * FROM data_audit \x \g
Expanded display is on.
-[ RECORD 1 ]----------------------------
tablename | weapon
arguments | crowbar
results   | 1
status    | normal
username  | alice
txntime   | 2012-01-30 17:37:39.497491-05
realtime  | 2012-01-30 17:37:39.545891-05

postgres=> CREATE OR REPLACE FUNCTION weapon_details(TEXT)
RETURNS TABLE (name TEXT, cost TEXT, description TEXT)
LANGUAGE plperlu
SECURITY DEFINER
VOLATILE
AS $bc$

use strict;
use warnings;
>use DBI;

## The item they are looking for
my $name = shift;
## We will be nice and ignore the case and any whitespace
$name =~ s{^\s*(\S+)\s*$}{lc $1}e;

## What is the maximum security_level that people who are 
## calling this function can view?
my $seclevel = 'confidential';

## Query the table and pull back the matching row
## We need to differentiate between "not found" and "not allowed",
## by comparing a passed-in level to the security_level for that row.
my $SQL = q{
SELECT name,cost,description,
  CASE WHEN security_level <= $1 THEN 1 ELSE 0 END AS allowed
FROM weapon
WHERE LOWER(name) = $2};

## Run the query, pull back the first row, as well as the allowed column value
my $sth = spi_prepare($SQL, 'CLASSIFICATION', 'TEXT');
my $rv = spi_exec_prepared($sth, $seclevel, $name);
my $row = $rv->{rows}[0];
my $allowed = defined $row ? delete $row->{allowed} : 1;

## Log this request
$SQL = 'INSERT INTO data_audit(username,tablename,arguments,results,status)
  VALUES (?,?,?,?,?)';
my $status = $rv->{rows}[0] ? $allowed ? 'normal' : 'forbidden' : 'na';
my $dbh = DBI->connect('dbi:Pg:service=auditor', '', '',
  {AutoCommit=>0, RaiseError=>1, PrintError=>0});
$sth = $dbh->prepare($SQL);
my $user = spi_exec_query('SELECT session_user')->{rows}[0]{session_user};
$sth->execute($user, 'weapon', $name, $rv->{processed}, $status);
$dbh->commit();

## Did we find anything? If not, simply return undef
if (! $rv->{processed}) {
   return undef;
}

## Throw an exception if we are not allowed to view this row
if (! $allowed) {
   die qq{Sorry, you are not allowed to view information on that weapon!\n};
}

## Return the requested data
return_next($row);

$bc$;
CREATE FUNCTION

postgres=> \c postgres postgres
You are now connected to database "postgres" as user "postgres".
Expanded display is on.
-[ RECORD 1 ]----------------------------
tablename | weapon
arguments | crowbar
results   | 1
status    | normal
username  | alice
txntime   | 2012-01-30 17:56:01.544557-05
realtime  | 2012-01-30 17:56:01.54569-05
-[ RECORD 2 ]----------------------------
tablename | weapon
arguments | pulse rifle
results   | 1
status    | forbidden
username  | alice
txntime   | 2012-01-30 17:56:01.559532-05
realtime  | 2012-01-30 17:56:01.561225-05
-[ RECORD 3 ]----------------------------
tablename | weapon
arguments | m9
results   | 1
status    | normal
username  | alice
txntime   | 2012-01-30 17:56:01.573335-05
realtime  | 2012-01-30 17:56:01.574989-05

postgres=>  \c postgres alice
You are now connected to database "postgres" as user "alice".

postgres=> CREATE FUNCTION showplatform()
RETURNS TEXT
LANGUAGE plperlu
AS $bc$
  return $^O;
$bc$;
ERROR:  permission denied for language plperlu

my $results = $dbh->selectall_arrayref(
  q{
    SELECT
      sku,
      description,
      price,
      thumb,
      category, 
      prod_group
    FROM
      products
    WHERE
      category = ?},
  { Slice => {} }, 
  $category
);
$::Tag->tmpn("product_list", $results);
<table cellpadding=0 cellspacing=2 border=1>
<tr>
  <th>Image</th>
  <th>Description</th>
  <th>Product Group</th>
  <th>Category</th>
  <th>Price</th>
</tr>
[loop object.mv_results=`$Scratch->{product_list}` prefix=plist]
[list]
<tr>
  <td><a href="/cgi-bin/vlink/[plist-param sku].html"><img src="[plist-param thumb]"></a></td>
  <td>[plist-param description]</td>
  <td>[plist-param prod_group]</td>
  <td>[plist-param category]</td>
  <td>[plist-param price]</td>
</tr>
[/list]
[/loop]
</table>
30 10 * * * cp -f conf/postgresql.conf.1 /etc/postgresql.conf; /etc/init.d/postgresql reload
50 10 * * * cp -f conf/postgresql.conf.2 /etc/postgresql.conf; /etc/init.d/postgresql reload

./modify_postgres_conf.pl --pgconf /etc/postgresql/9.0/main/postgresql.conf --change random_page_cost=2

diff -r1.1 postgresql.conf
499c499
< random_page_cost = 4
---
> random_page_cost = 2 ## changed by modify_postgres_conf.pl on Wed Aug 10 13:31:34 2011

$ ./modify_postgres_conf.pl --pgconf /etc/postgresql/9.0/main/postgresql.conf --change random_page_cost=2
114991 /var/log/postgres/postgres-2011-08-10.log

$ ./modify_postgres_conf.pl --pgconf /etc/postgresql/9.0/main/postgresql.conf --change random_page_cost=2
No change made: value of "random_page_cost" is already 2

$ ./modify_postgres_conf.pl --pgconf /etc/postgresql/9.0/main/postgresql.conf \
> --change random_page_cost=2 \
> --change log_statement=ddl \
> --change log_min_duration_statement=100

No change made: value of "random_page_cost" is already 2
118459 /var/log/postgres/postgres-2011-08-10.log

$ ./modify_postgres_conf.pl --pgconf /etc/postgresql/9.0/main/postgresql.conf \
> --change default_statitics_target=200 --no-comment
There is no Postgres variable named "default_statitics_target"!

$ ./modify_postgres_conf.pl --pgconf /etc/postgresql/9.0/main/postgresql.conf \
> --change default_statistics_target=200 --no-comment
123396 /var/log/postgres/postgres-2011-08-10.log

git clone git://git@github.com:bucardo/modify_postgres_config.git

  my $dsn = 'dbi:Pg:dbname=foobar';
  my $dbh = DBI->connect($dsn, $dbuser, $dbpass,
    { AutoCommit => 0,
      RaiseError => 0,
      PrintError => 0,
      pg_utf8_strings => 0,
    }
  );

git clone git://bucardo.org/dbdpg.git

sudo aptitude install postgresql-server \
perl-DBIx-Safe \
perl-DBD-Pg \
postgresql-contrib

aptitude install mongodb

$  mkdir /tmp/mongodata
$  mongod --dbpath=/tmp/mongodata --fork --logpath=/tmp/mongo.log
all output going to: /tmp/mongo.log
forked process: 428

$  mongo
MongoDB shell version: 1.8.1
Fri Jun 10 12:45:00
connecting to: test
> quit()
$ 

$  sudo cpan MongoDB

$ git clone git://bucardo.org/bucardo.git
Initialized empty Git repository...

$ cd bucardo
$ perl Makefile.PL
Checking if your kit is complete...
Looks good
Writing Makefile for Bucardo
$ make
cp bucardo.schema blib/share/bucardo.schema
cp Bucardo.pm blib/lib/Bucardo.pm
cp bucardo blib/script/bucardo
/usr/bin/perl -MExtUtils::MY -e 'MY->fixin(shift)' -- blib/script/bucardo
Manifying blib/man1/bucardo.1pm
Manifying blib/man3/Bucardo.3pm
$ sudo make install
Installing /usr/local/lib/perl5/site_perl/5.10.0/Bucardo.pm
Installing /usr/local/share/bucardo/bucardo.schema
Installing /usr/local/bin/bucardo
Installing /usr/local/share/man/man1/bucardo.1pm
Installing /usr/local/share/man/man3/Bucardo.3pm
Appending installation info to /usr/lib/perl5/5.10.0/i386-linux-thread-multi/perllocal.pod
$ sudo mkdir /var/run/bucardo
$ sudo chown $USER /var/run/bucardo
$ bucardo install
This will install the bucardo database into an existing Postgres cluster.
...
Installation is now complete.

$ psql -c 'create database btest1'
CREATE DATABASE
$ pgbench -i btest1
NOTICE:  table "pgbench_branches" does not exist, skipping
...
creating tables...
10000 tuples done.
20000 tuples done.
...
100000 tuples done.
$ psql -c 'create database btest2 template btest1'
CREATE DATABASE
$ psql -c 'create database btest3 template btest1'
CREATE DATABASE
$ psql btest3 -c 'truncate table pgbench_accounts'
TRUNCATE TABLE

$ bucardo add db t1 dbname=btest1
Added database "t1"
$ bucardo add db t2 dbname=btest2
Added database "t2"
$ bucardo add db t3 dbname=btest3
Added database "t3"
$ bucardo list dbs
Database: t1  Status: active  Conn: psql -p 5432 -U bucardo -d btest1
Database: t2  Status: active  Conn: psql -p 5432 -U bucardo -d btest2
Database: t3  Status: active  Conn: psql -p 5432 -U bucardo -d btest3

$ bucardo add tables pgbench_accounts pgbench_branches pgbench_tellers herd=therd
Created herd "therd"
Added table "public.pgbench_accounts"
Added table "public.pgbench_branches"
Added table "public.pgbench_tellers"

$ bucardo list tables
Table: public.pgbench_accounts  DB: t1  PK: aid (int4)
Table: public.pgbench_branches  DB: t1  PK: bid (int4)
Table: public.pgbench_tellers   DB: t1  PK: tid (int4)

$  bucardo add db m1 dbname=btest1 type=mongo
Added database "m1"
$  bucardo list dbs
Database: m1  Type: mongo     Status: active  
Database: t1  Type: postgres  Status: active  Conn: psql -p 5432 -U bucardo -d btest1
Database: t2  Type: postgres  Status: active  Conn: psql -p 5432 -U bucardo -d btest2
Database: t3  Type: postgres  Status: active  Conn: psql -p 5432 -U bucardo -d btest3

$  bucardo add dbgroup tgroup  t1:source  t2:source  t3:target  m1:target
Created database group "tgroup"
Added database "t1" to group "tgroup" as source
Added database "t2" to group "tgroup" as source
Added database "t3" to group "tgroup" as target
Added database "m1" to group "tgroup" as target

$  bucardo add dbgroup tgroup t1:source  t2  t3  m1

$  bucardo add sync mongotest  herd=therd  dbs=tgroup  ping=false
Added sync "mongotest"

$  bucardo start
Checking for existing processes
Starting Bucardo

$  pgbench -t 10000 btest1
starting vacuum...end.
transaction type: TPC-B (sort of)
number of transactions actually processed: 10000/10000
...
tps = 503.300595 (excluding connections establishing)
$  pgbench -t 10000 btest2
number of transactions actually processed: 10000/10000
...
tps = 408.059368 (excluding connections establishing)
$  bucardo kick mongotest

$  bucardo status
PID of Bucardo MCP: 3317
 Name        State    Last good    Time    Last I/D/C    Last bad    Time  
===========+========+============+=======+=============+===========+=======
 mongotest | Good   | 21:57:47   | 11s   | 6/36234/898 | none      |

$  psql btest1 -c 'SELECT count(*) FROM pgbench_accounts'
100000
$  psql btest2 -c 'SELECT count(*) FROM pgbench_accounts'
100000
$  psql btest3 -c 'SELECT count(*) FROM pgbench_accounts'
18106
$  psql btest1 -qc 'SELECT min(abalance),max(abalance) FROM pgbench_accounts'
-12071 | 13010
$  psql btest2 -qc 'SELECT min(abalance),max(abalance) FROM pgbench_accounts'
-12071 | 13010
$  psql btest3 -qc 'SELECT min(abalance),max(abalance) FROM pgbench_accounts'
-12071 | 13010

$  mongo btest1
MongoDB shell version: 1.8.1
Fri Jun 10 12:46:00
connecting to: btest1
> show collections
bucardo_status
pgbench_accounts
pgbench_branches
pgbench_tellers
system.indexes
>  db.pgbench_accounts.count()
18106
>  db.pgbench_accounts.find().sort({abalance:1}).limit(1).next()
{
  "_id" : ObjectId("4df39bcb8795839660001de5"),
  "abalance" : -12071,
  "aid" : 84733,
  "bid" : 1,
  "filler" : "               "
}
> db.pgbench_accounts.find().sort({abalance:-1}).limit(1).next()
{
  "_id" : ObjectId("4df39bd08795839660002fb0"),
  "abalance" : 13010,
  "aid" : 45500,
  "bid" : 1,
  "filler" : "               "
}

$ psql btest1 -c 'UPDATE pgbench_accounts SET aid=aid'
UPDATE 100000
$ bucardo kick mongotest
Kicked sync mongotest
$ echo 'db.pgbench_accounts.count()' | mongo btest1
MongoDB shell version: 1.8.1
Fri Jun 10 12:47:00
connecting to: btest1
> 100000
> bye

aptitude install postgresql-server \
perl-DBIx-Safe \
perl-DBD-Pg \
postgresql-contrib

git clone git://bucardo.org/bucardo.git

cd bucardo
perl Makefile.PL
make
sudo make install

sudo mkdir /var/run/bucardo
sudo chown $USER /var/run/bucardo
bucardo install

psql -c 'CREATE DATABASE btest1'
pgbench -i btest1
psql -c 'CREATE DATABASE btest2 TEMPLATE btest1'
psql -c 'CREATE DATABASE btest3 TEMPLATE btest1'
psql -c 'CREATE DATABASE btest4 TEMPLATE btest1'
psql -c 'CREATE DATABASE btest5 TEMPLATE btest1'

bucardo add db t1 dbname=btest1
bucardo add db t2 dbname=btest2
bucardo add db t3 dbname=btest3
bucardo add db t4 dbname=btest4
bucardo add db t5 dbname=btest5
bucardo list dbs

bucardo add table pgbench_accounts pgbench_branches pgbench_tellers herd=therd
bucardo list tables

bucardo add dbgroup tgroup t1:source t2:source t3:source t4:source t5:target

bucardo add sync foobar herd=therd dbs=tgroup ping=false

bucardo start

pgbench -t 10000 btest1
pgbench -t 10000 btest2
pgbench -t 10000 btest3
pgbench -t 10000 btest4

bucardo kick foobar

bucardo status

bucardo stop

bucardo status
Name     State    Last good    Time    Last I/D/C           Last bad    Time
========+========+============+=======+====================+===========+=======
foobar | Good   | 17:58:37   | 3m2s  | 131836/131836/4785 | none      |

bucardo status foobar
Last good                       : Jun 02, 2011 17:57:47 (time to run: 42s)
Rows deleted/inserted/conflicts : 131,836 / 131,836 / 4,785
Sync name                       : foobar
Current state                   : Good
Source herd/database            : therd / t1
Tables in sync                  : 3
Status                          : active
Check time                      : none
Overdue time                    : 00:00:00
Expired time                    : 00:00:00
Stayalive/Kidsalive             : yes / yes
Rebuild index                   : 0
Ping                            : no
Onetimecopy                     : 0
Post-copy analyze               : Yes
Last error:                     :

## Prepare the source
my $srccmd = "COPY (SELECT * FROM $S.$T WHERE $pkcols IN ($pkvals)) TO STDOUT";
$fromdbh->do($srccmd);

## Prepare each target
for my $t (@$todb) {
    my $tgtcmd = "COPY $S.$T FROM STDIN";
    $t->{dbh}->do($tgtcmd);
}

## Pull a row from the source, and push it to each target
while ($fromdbh->pg_getcopydata($buffer) >= 0) {
    for my $t (@$todb) {
        $t->{dbh}->pg_putcopydata($buffer);
    }
}

## Tell each target we are done with COPYing
for my $t (@$todb) {
    $t->{dbh}->pg_putcopyend();
}

## Later on, run an asynchronous command on the source database
$sth{track}{$dbname}{$g} = $fromdbh->prepare($SQL, {pg_async => PG_ASYNC});
$sth{track}{$dbname}{$g}->execute();

...
## Tell each target we are done with COPYing
for my $t (@$todb) {
    $t->{dbh}->pg_putcopyend();
    $t->{dbh}->do('SELECT 123');
}

## Later on, run an asynchronous command on the source database
$fromdbh->do('SELECT 123');
$sth{track}{$dbname}{$g} = $fromdbh->prepare($SQL, {pg_async => PG_ASYNC});
$sth{track}{$dbname}{$g}->execute();

    /*
     * Silently discard any prior query result that application didn't eat.
     * This is probably poor design, but it's here for backward compatibility.
     */
    while ((result = PQgetResult(conn)) != NULL)

my @options;
for my $obj (@$things) {
    push @options, {
        value => $obj->{a},
        label => $obj->{b}
    };        
}
return \@options;

return [ map {
    {
        value => $_->{a},
        label => $_->{b}
    }
} @$things ];

#!/usr/bin/perl

use Benchmark;

my $count = 1000000;
my $things = [
    {'a' => 123, 'b' => 456, 'c' => 789 },
    {'a' => 456, 'b' => 789, 'c' => 123 }
];

#Test definitions as methods to mimic use in application
my $test1 = sub {
    my @options;
    for my $obj (@$things) {
        push @options, {
            value => $obj->{a},
            label => $obj->{b} 
        };
    }
    return \@options;
};
my $test2 = sub {
    return [ map {
        { 
            value => $_->{a},
            label => $_->{b}
        }
    } @$things ];
};

#Benchmark tests & results.
$t0 = Benchmark->new;
$test1->() for(1..$count);
$t1 = Benchmark->new;
$td = timediff($t1, $t0);
print "the code for test 1 took:",timestr($td),"\n";

$t0 = Benchmark->new;
$test2->() for(1..$count);
$t1 = Benchmark->new;
$td = timediff($t1, $t0);

print "the code for test 2 took:",timestr($td),"\n";

http://bucardo.org/wiki/DBIx-Cache
git clone git://bucardo.org/dbixcache.git/
https://github.com/bucardo/dbixcache
use strict;
use warnings;
use Data::Dumper;
use DBIx::Cache;
use Cache::Memcached::Fast;

## Connect to an existing memcached server, 
## and establish a default namespace
my $mc = Cache::Memcached::Fast->new(
  {
    servers   => [ { address => 'localhost:11211' } ],
    namespace => 'joy',
  });

## Rather than DBI->connect, use DBIx->connect
## Tell it what to use as our caching source
## (the memcached server above)
my $dbh = DBIx::Cache->connect('', '', '',
  { RaiseError => 1,
    dxc_cachehandle => $mc
});

## This is an expensive query, that takes 30 seconds to run:
my $SQL = 'SELECT * FROM analyze_sales_data()';

## Prepare this query
my $sth = $dbh->prepare($SQL);

## Run it ten times in a row.
## The first time takes 30 seconds, the other nine return instantly.
for (1..10) {
    my $count = $sth->execute();
 my $info = $sth->fetchall_arrayref({});
    print Dumper $info;
} 

    $string =~ s{&(?:[a-z/;&])+}{}gis;
    $string =~ s/[^a-z]//gis;
    $string =~ s/^\s+//;
    $string =~ s/\s+$//;
    $string =~ s/\s+/ /gis;

  ## We are connecting to two servers and running expensive 
  ## queries on both. We kick both off right away, then wait 
  ## for them both to finish. Our total wait time is thus
  ## max(server1,server2) rather than sum(server1,server2)

  use strict;
  use warnings;
  use DBI;
  use DBD::Pg qw{ :async };

  my $dsn1 = 'dbi:Pg:dbname=sales;host=example1.com';
  my $dsn2 = 'dbi:Pg:dbname=sales;host=example2.com';

  my $dbh1 = DBI->connect($dsn1, '', '', {AutoCommit=>0, RaiseError=>1});
  my $dbh2 = DBI->connect($dsn2, '', '', {AutoCommit=>0, RaiseError=>1});

  my $SQL = 'SELECT gather_yearly_sales_data()';
  print "Kicking off a long, expensive query on database one\n";
  ## Normally, a do() will not return until the query is complete
  ## However, the async flag causes it to return immediately
  $dbh1->do($SQL, {pg_async => PG_ASYNC});

  print "Kicking off a long, expensive query on database two\n";
  $dbh2->do($SQL, {pg_async => PG_ASYNC});

  ## Both queries are running in the 'background'
  ## We have to wait for both, so it doesn't matter which one we wait for here
  ## However, if it's been over 2 minutes, we'll cancel both and quit
  my $time = 0;
  while ( ! $dbh1->pg_ready() ) {
    sleep 1;
    if ($time++ > 120) {
      print "Taking too long, let's cancel the queries\n";
      $dbh1->pg_cancel();
      $dbh2->pg_cancel();
      $dbh1->rollback();
      $dbh2->rollback();
      die "No sales data was retrieved\n";
    }
  }

  ## We know that database 1 has finished, so we read in the results
  my $rows1 = $dbh1->pg_result();
  ## We then grab results from database 2
  ## This will block until done, which is okay
  my $rows2 = $dbh2->pg_result();
  ## We are running a series of queries against a database, but if
  ## the whole thing is taking over 30 seconds, we want to cancel
  ## the currently running query and move on to something else.

  use strict;
  use warnings;
  use DBI;
  use DBD::Pg qw{ :async };

  my $dsn = 'dbi:Pg:dbname=dq';

  my $dbh = DBI->connect($dsn, '', '', {AutoCommit=>0, RaiseError=>1});

  ## Setup all the POSIX alarm plumbing
  my $mask = POSIX::SigSet->new(SIGALRM);
  my $action = POSIX::SigAction->new(
    sub { die "TIMEOUT\n" },
    $mask,
  );
  my $oldaction = POSIX::SigAction->new();
  sigaction( SIGALRM, $action, $oldaction );

  ## Prepare the queries
  my $upd = $dbh->prepare('UPDATE foobar SET x=? WHERE y=?');
  my $inv = $dbh->prepare('SELECT refresh_inventory(?)');

  ## Yes, a double eval. Async is looking better all the time :)
  eval {
    eval {
          alarm 30;
          for my $y (12,24,48) {
              print "Adjusting widget #$y\n";
              $upd->execute(555,$y);
              print "Recalculating inventory\n";
              $inv->execute($y);
          }
        };
        alarm 0; ## Turn off our alarm
        die "$@\n" if $@; ## Bubble the error to the outer eval
    };
    if ($@) { ## Something went wrong
      if ($@ =~ /TIMEOUT/) {
        print "Queries are taking too long! Cancelling\n";
        ## We don't know which one is still running, and don't care
        ## It's safe to cancel a non-active statement handle
        $upd->cancel() or die qq{Failed to cancel the query!\n};
        $inv->cancel() or die qq{Failed to cancel the query!\n};
        $dbh->rollback();
        die "Who has time to wait 30 seconds anymore?";
      }
      ## Some other non-alarm error, so we simply:
      die $@;
    }

    print "Updates are complete\n";
    $dbh->commit();
    exit;
$HOME
$HOME
$ curl -L http://xrl.us/perlbrewinstall | bash

PERLBREW_ROOT
$ curl -LO http://xrl.us/perlbrew
$ chmod +x perlbrew
$ PERLBREW_ROOT=/mnt/perlbrew ./perlbrew install

~/perl5/perlbrew/bin
$PATH
perlbrew init
perlbrew mirror
$ perlbrew init
$ perlbrew mirror

$ perlbrew list
* /usr/bin/perl (5.10.1)

$ perlbrew install 5.12.3

$ perlbrew list
* /usr/bin/perl (5.10.1)
perl-5.12.3

$ perlbrew switch perl-5.12.3

$ perlbrew list
/usr/bin/perl (5.10.1)
* perl-5.12.3

$ perl -v

This is perl 5, version 12, subversion 3 (v5.12.3) built for x86_64-linux

Copyright 1987-2010, Larry Wall

Perl may be copied only under the terms of either the Artistic License or the
GNU General Public License, which may be found in the Perl 5 source kit.

Complete documentation for Perl, including FAQ lists, should be found on
this system using "man perl" or "perldoc perl".  If you have access to the
Internet, point your browser at http://www.perl.org/, the Perl Home Page.

perlbrew use
switch
use
$ perlbrew use system

$ perlbrew list
* /usr/bin/perl (5.10.1)
perl-5.12.3

$ ls -l ~/perl5/perlbrew/
total 2680
-rw-r--r--  1 testy  users      408 Feb 10 23:58 Conf.pm
drwxr-xr-x  2 testy  users      512 Feb 10 23:46 bin
drwxr-xr-x  4 testy  users      512 Feb 11 09:59 build
-rw-r--r--  1 testy  users  1333196 Feb 11 10:33 build.log
drwxr-xr-x  2 testy  users      512 Feb 11 09:59 dists
drwxr-xr-x  2 testy  users      512 Feb 10 23:47 etc
drwxr-xr-x  4 testy  users      512 Feb 11 10:32 perls

$ ls -l ~/perl5/perlbrew/perls/
total 8
drwxr-xr-x  5 testy  users  512 Feb 11 00:38 perl-5.12.3
drwxr-xr-x  5 testy  users  512 Feb 11 10:32 perl-5.13.6

#!/usr/bin/env perl

use JSON;

my $json = JSON->new;
undef $/;
while (<>) {
    print $json->pretty->encode($json->decode($_));
}

{"glossary":{"title":"example glossary","GlossDiv":{"title":"S","GlossList":
{"GlossEntry":{"ID":"SGML","SortAs":"SGML","GlossTerm":"Standard Generalized Markup Language",
"Acronym":"SGML","Abbrev":"ISO 8879:1986","GlossDef":{"para":
"A meta-markup language,used to create markup languages such as DocBook.",
"GlossSeeAlso":["GML","XML"]},"GlossSee":"markup"}}}}}
{
   "glossary" : {
      "GlossDiv" : {
         "GlossList" : {
            "GlossEntry" : {
               "GlossDef" : {
                  "para" : "A meta-markup language,used to create markup languages such as DocBook.",
                  "GlossSeeAlso" : [
                     "GML",
                     "XML"
                  ]
               },
               "GlossTerm" : "Standard Generalized Markup Language",
               "ID" : "SGML",
               "SortAs" : "SGML",
               "Acronym" : "SGML",
               "Abbrev" : "ISO 8879:1986",
               "GlossSee" : "markup"
            }
         },
         "title" : "S"
      },
      "title" : "example glossary"
   }
}
json_xs
python -mjson.tool
prettify_json.rb
Encode::decode_utf8()
HTML::Entities::encode_entities_numeric()
`iconv -f utf8 -t utf8 output.log >/dev/null`
U+20AC
encode_entities_numeric()
0x80
&#xE2;&#x82;&#xAC;
HTML::Entities
$ perl -MHTML::Entities+encode_entities_numeric -MEncode -e '$c=qq{\xE2\x82\xAC}; print encode_entities_numeric(decode_utf8($c))'
--> &#x20AC;

:utf8
:encoding
Encode::decode_utf8()
Encode::decode('utf8')
decode_utf8
decode('utf8')
decode_utf8()
decode('utf8')
decode()
decode_utf8
decode('utf8')
decode_utf8()
utf8::upgrade
$ perl -l -MHTML::Entities+encode_entities_numeric -MEncode -Mutf8 -e '$c=qq{\xE2\x82\xAC}; utf8::upgrade($c); print encode_entities_numeric(decode_utf8($c))'
--> &#xE2;&#x82;&#xAC;

latin-1
for ref in $(git tag);
do
    echo -n $ref;
    diff -w <(git show $ref:/path/to/versioned/file 2>/dev/null) modified_file | wc -l;
done | sort -k2 -n

diff
-w
git diff rev1 rev2 -- path/to/content
package YourMagic;
use strict;

sub do_something {
    my ($opt) = @_;

    # some code

    my $dbh = ::database_exists_ref($opt->{table})->dbh
        or return undef;

    # ... more code
    return $output;
}

1;

use lib '/home/user/interchange/custom/lib';
use Test::More tests => 2;
use DBI;

# Here are the methods to provide proper reference to our database handle
################################
sub ::database_exists_ref {
    my $table = shift;
    return undef if !$table;

    # return an object with a dbh method
    return bless({}, __PACKAGE__);
}

sub dbh {
    # define a dbh method
    my $db = DBI->connect('dsn, 'user', 'pass');

    return $db;
}
##################################

use YourMagic;

is(
    YourMagic::do_something(),
    undef,
    'do_something() returns undef when called with no arguments',
);

is(
    YourMagic::do_something(\%opt),
    undef,
    'do_something() returns ...',
);

#!/usr/bin/env perl

use strict;
use warnings;
use Data::Dumper;
use Test::More tests => 356;
use TestOverride;

sub some_function {
       my $arr = [];
       push @$arr => 4,9;
       return [$arr];
}

my $t = q{Function some_function() returns correct value when called with 'foo'};
my $value = some_function('foo');
my $res = [[3],[5]];
is_deeply( $value, $res, $t);

...

$t = q{Value of baz is 123};
is ($baz, 123, $t);
...

TestOverride
...
use Data::Dumper;
$Data::Dumper::Indent = 1;
$Data::Dumper::Terse = 1;
$Data::Dumper::Pad = '|';

use base 'Exporter';
our @EXPORT = qw{ is_deeply like pass is isa_ok ok };

my $bail_on_error = $ENV{TESTBAIL} || 0;

my $total_errors = 0;

sub is_deeply {

   # Return right away if the test passes
   my $rv = Test::More::is_deeply(@_);
   return $rv if $rv;

   if ($bail_on_error and ++$total_errors >= $bail_on_error) {
       my ($file,$line) = (caller)[1,2];
       Test::More::diag("GOT: ".Dumper $_[0]);
       Test::More::diag("EXPECTED: ".Dumper $_[1]);
       Test::More::BAIL_OUT "Stopping on a failed 'is_deeply' test from line $line of $file.";
   }

   return;

} ## end of is_deeply

sub is {
   my $rv = Test::More::is(@_);
   return $rv if $rv;
   if ($bail_on_error and ++$total_errors >= $bail_on_error) {
       my ($file,$line) = (caller)[1,2];
       Test::More::BAIL_OUT "Stopping on a failed 'is' test from line $line of $file.";
   }
   return;
} ## end of is

1..356
not ok 1 - Function some_function() returns correct value when called with 'foo'
#   Failed test 'Function some_function() returns correct value when called with 'foo''
#   at test1.t line 18.
#     Structures begin differing at:
#          $got->[0] = '4'
#     $expected->[0] = '3'
# Looks like you planned 356 tests but ran 1.
# Looks like you failed 1 test of 1 run.

1..356
not ok 1 - Function some_function() returns correct value when called with 'foo'
#   Failed test 'Function some_function() returns correct value when called with 'foo''
#   at TestOverride.pm line 23.
#     Structures begin differing at:
#          $got->[0] = '4'
#     $expected->[0] = '3'
# GOT: |[
# |  4,
# |  [
# |    9
# |  ]
# |]
# EXPECTED: |[
# |  3
# |]
Bail out!  Stopping on a failed 'is_deeply' test from line 17 of test1.t.

log_line_prefix = '%t [%p] %u@%d '

2010-08-06 09:24:57.714 EDT [7229] joy@joymail LOG: execute dbdpg_p7228_5: SELECT count(id) FROM joymail WHERE folder = $1
2010-08-06 09:24:57.714 EDT [7229] joy@joymail DETAIL:  parameters: $1 = '4'

(\d\d\d\d\-\d\d\-\d\d \d\d:\d\d:\d\d).+?(\d+)

log_line_prefix = '%t [%p] %u@%d '

Date: Fri Aug  6 11:01:03 2010 UTC                                                        
Host: whale.example.com
Unique items: 7
Total matches: 85
Matches from [A] /var/log/pg_log/postgresql-2010-08-05.log: 61
Matches from [B] /var/log/pg_log/postgresql-2010-08-06.log: 24

[1] From files A to B (between lines 14,205 of A and 527 of B, occurs 64 times)
First: [A] 2010-08-05 16:52:11 UTC [1602]  postgres@mydb
Last:  [B] 2010-08-06 01:18:14 UTC [20981] postgres@mydb
ERROR: syntax error at or near ")" 
STATEMENT: INSERT INTO mytable (id, foo, bar) VALUES (?,?,?))
-
ERROR: syntax error at or near ")"
STATEMENT: INSERT INTO mytable (id, foo, bar) VALUES (123,'chocolate','donut'));

[2] From file A (line 12,172)                                                                                                
2010-08-05 12:27:48 UTC [2906] bob@otherdb
ERROR: invalid input syntax for type date: "May" 
STATEMENT: UPDATE personnel SET birthdate='May' WHERE id = 1234;

(plus five other entries)

use strict;
use warnings;

eval {
    print "Some stuff\n";
    eval {
        die 'Oops. Bad inner eval';
    };

    printf '$@ in outer eval: %s', $@;
};

printf '$@ after outer eval: %s', $@;
print $/;

[mark@sokt ~]$ perl demo.pl 
Some stuff
$@ in outer eval: Oops. Bad inner eval at demo.pl line 7.
$@ after outer eval: 
[mark@sokt ~]$ 

use strict;
use warnings;

eval {
    print "Some stuff\n";
    eval {
        die 'Oops. Bad inner eval';
    };

    printf '$@ in outer eval: %s', $@;
    die 'Uh oh. Bad outer eval, too';
};

printf '$@ after outer eval: %s', $@;
print $/;

[mark@sokt ~]$ perl demo.pl 
Some stuff
$@ in outer eval: Oops. Bad inner eval at demo.pl line 7.
$@ after outer eval: Uh oh. Bad outer eval, too at demo.pl line 11.

[mark@sokt ~]$ 

use strict;
use warnings;

package Obj;

sub DESTROY {
    eval { die 'in DESTROY' };
}

package main;

eval {
    my $obj = {};

    bless $obj, 'Obj';
    die 'in main eval';

    print "Super important stuff that must finish or we really need to know about it!\n";

    return 1;
};

if ($@) {
    printf '$@ comes from code %s', $@;
}
else {
    print "Happy days! Our eval code ran to completion. Woot!\n";
}

[mark@sokt ~]$ perl test1.pl 
$@ comes from code in DESTROY at test1.pl line 7.
[mark@sokt ~]$ 

use strict;
use warnings;

package Obj;

sub DESTROY {
    eval { 1 };
}

package main;

eval {
    my $obj = {};

    bless $obj, 'Obj';
    die 'in main eval';

    print "Super important stuff that must finish or we really need to know about it!\n";

    return 1;
};

if ($@) {
    printf '$@ comes from code %s', $@;
}
else {
    print "Happy days! Our eval code ran to completion. Woot!\n";
}

[mark@sokt ~]$ perl test2.pl 
Happy days! Our eval code ran to completion. Woot!
[mark@sokt ~]$ 

use strict;
use warnings;

package Obj;

sub DESTROY {
    eval { die 'in DESTROY' };
}

package main;

eval {
    my $obj = {};

    bless $obj, 'Obj';

    print "Super important stuff that must finish or we really need to know about it!\n";

    return 1;
};

if ($@) {
    printf '$@ comes from code %s', $@;
}
else {
    print "Happy days! Our eval code ran to completion. Woot!\n";
}

[mark@sokt ~]$ perl test3.pl 
Super important stuff that must finish or we really need to know about it!
Happy days! Our eval code ran to completion. Woot!
[mark@sokt ~]$ 

use strict;
use warnings;

package Obj;

sub DESTROY {
    local $@;
    eval { die 'in DESTROY' };
}

package main;

eval {
    my $obj = {};

    bless $obj, 'Obj';
    die 'in main eval';

    print "Super important stuff that must finish or we really need to know about it!\n";

    return 1;
};

if ($@) {
    printf '$@ comes from code %s', $@;
}
else {
    print "Happy days! Our eval code ran to completion. Woot!\n";
}

[mark@sokt ~]$ perl test1.pl 
$@ comes from code in main eval at test1.pl line 17.
[mark@sokt ~]$ 

use strict;
use warnings;

package Obj;

sub DESTROY {
    local $@;
    eval { 1 };
}

package main;

eval {
    my $obj = {};

    bless $obj, 'Obj';
    die 'in main eval';

    print "Super important stuff that must finish or we really need to know about it!\n";

    return 1;
};

if ($@) {
    printf '$@ comes from code %s', $@;
}
else {
    print "Happy days! Our eval code ran to completion. Woot!\n";
}

[mark@sokt ~]$ perl test2.pl 
$@ comes from code in main eval at test2.pl line 17.
[mark@sokt ~]$ 

{
  local *Base::Shipping::Package::weight = \&test_weight
  my $shipment = $class->create_shipment($shipment);
  my $result = $class->process_shipment($shipment);
  test $result;
}

sub test_weight { 4.0 }

Test #	Before (For Loop)	After (Map)
1	5 sec	4 sec
2	5 sec	4 sec
3	5 sec	5 sec
4	5 sec	5 sec
5	6 sec	4 sec
6	6 sec	4 sec
7	6 sec	4 sec
8	5 sec	5 sec
9	5 sec	4 sec
10	5 sec	4 sec
Average	5.3 sec	4.3 sec

Perl Blog Archive

Locking hash keys with Hash::Util

Multi-master support

Ease of use

Performance

Improved logging

Different targets

I. Download all prerequisites

II. Grab the latest Bucardo

III. Install the program

IV. Setup an instance of Bucardo

V. Use the pgbench program to create some test tables

VI. Tell Bucardo about the databases and tables you are going to use

VII. Group the databases together and set their roles

VII. Create the Bucardo sync

VIII. Start up Bucardo

IX. Make a bunch of changes on all the source databases.

X. Kick off the sync and watch the fun.