Johannes Plunien

Github Meets CPAN

2011-07-22T12:13:00.006+04:00

When Olaf Alders was writing about expanding your MetaCPAN profile he suggested to build something interesting on top of the MetaCPAN API. When I started writing Pithub I did not have any use case in mind at all. I just wrote it because I was bored and because there was no Perl support yet for the v3 of the Github API. When I read Olaf's article, I got an idea: Connect the CPAN authors listed by the MetaCPAN API to their Github data, in case they have their Github account set. And there it was: The first use case for Pithub.
The page is up and running on dotCloud and you can check it out here: http://www.github-meets-cpan.com/
The whole thing was kind of boring until Olaf had yet another great idea: Add some ranking there and sort the users by it, instead of sorting them just alphabetically. Currently the rank is calculated by this formula:

  (count of your followers)
+ (sum of watchers of all of your repositories)
+ (sum of forks of all of your repositories)
= rank

It's also available on Github: https://github.com/plu/github-meets-cpan

Pithub: How to commit a new file via the Github v3 API

2011-07-19T18:04:00.004+04:00

In my last article I was demonstrating how to create a new download using Pithub. Today I will show you how to commit a new file to a repository. Github provides a low level API, which can be used to work directly with git objects like blobs, trees and commits. Committing a file needs several steps:

create a new blob with the content of the file
get the SHA the current master branch points to
fetch the tree this SHA belongs to
create a new tree object with the new blob, based on the old tree
create a new commit object using the new tree and point its parent to the current master
finally update the heads/master reference to point to the new commit

You can also read up the explanation in different words on the Github API documentation. If you want to read more about the git internals and how everything works together, please check the Pro Git book, Chapter 9: Git Internals. Ready? One note before: I'm skipping some validation code here, just to make it easier to read. In the full example script the validation code is present. Let's take a look at step 1: create a new blob with the content of the file:

#!/usr/bin/env perl
use strict;
use warnings;
use File::Slurp;
use Pithub::GitData;

my $git = Pithub::GitData->new(
    repo  => 'Pithub',
    token => 'your secret token',
    user  => 'plu',
);

my $content = File::Slurp::read_file(__FILE__);

# the encoding can also be 'base64', if necessary
my $blob = $git->blobs->create(
    data => {
        content  => $content,
        encoding => 'utf-8',
    }
);

That was easy. We just used File::Slurp to read the content of the current file and create a new blob with that content. The encoding is set to utf-8 because the whole content can be represented in utf-8 without loosing any information. If you want to create a binary file, you need to encode the content in base64 and set the encoding accordingly. The next steps are to get the SHA the current master branch points to and the tree this SHA belongs to:

my $master = $git->references->get( ref => 'heads/master' );

my $base_commit = $git->commits->get( sha => $master->content->{object}{sha} );

So $base_commit represents the last commit in the master branch. It also has the information (SHA) to which tree this commit belongs to. This SHA is necessary to create a new tree object (see the base_tree key):

my $tree = $git->trees->create(
    data => {
        base_tree => $base_commit->content->{tree}{sha},
        tree      => [
            {
                path => 'examples/gitdata_commit.pl',
                mode => '100755',
                type => 'blob',
                sha  => $blob->content->{sha},
            }
        ],
    }
);

Once the new tree has been created, we can finally create a new commit and point the master branch (or better: the heads/master reference) to it:

my $commit = $git->commits->create(
    data => {
        message => 'Add examples/gitdata_commit.pl.',
        parents => [ $master->content->{object}{sha} ],
        tree    => $tree->content->{sha},
    }
);

my $reference = $git->references->update(
    ref  => 'heads/master',
    data => { sha => $commit->content->{sha} }
);

This example gitdata_commit.pl really committed itself. In the current version you'll notice a few small differences, because I have changed it since then.

Pithub: How to create a new download via the Github v3 API

2011-07-16T08:17:00.003+04:00

Uploading a file to Github is a two step process: First you need to create a download resource. After that you can actually upload the file (to Amazon S3). All that is handled for you by Pithub. If you create new TRIAL release using Dist::Zilla, you can use Pithub to provide that file in the download section of your repository at Github. It would be handy to have this as a Dist::Zilla plugin. The following script makes three assumptions: First: You created that file Pithub-0.01005-TRIAL.tar.gz already via Dist::Zilla, the script does not do that for you. Second: The script needs to be in the same folder as the tar.gz archive. You have an OAuth access token.

#!/usr/bin/env perl
use strict;
use warnings;
use Pithub::Repos::Downloads;

my $download = Pithub::Repos::Downloads->new(
    repo  => 'Pithub',
    token => 'my secret token',
    user  => 'plu',
);

my $result = $download->create(
    data => {
        name         => 'Pithub-0.01005-TRIAL.tar.gz',
        size         => ( stat('Pithub-0.01005-TRIAL.tar.gz') )[7],
        description  => 'Pithub v0.01005 TRIAL',
        content_type => 'application/x-gzip',
    },
);

if ( $result->success ) {
    my $upload = $download->upload(
        result => $result,
        file   => 'Pithub-0.01005-TRIAL.tar.gz',
    );
    if ( $upload->is_success ) {
        printf "The file has been uploaded succesfully and is now available at: %s\n", $result->content->{html_url};
    }
}

Here are some links that might help you:

Github v3 API: Pithub

2011-07-15T14:54:00.008+04:00

Almost one month ago Github released a new version of their API: The Github v3 API. I've checked the CPAN and found Net::Github there, which supports v2 and v1 of the API so far. From my understanding, the Net:: modules family should be somehow lightweight, please correct me if I'm wrong. They should not do more than providing an interface to the API, which is exactly what Net::Github does in a very good way. But I was looking for something else, something that does more than this and something that supports the new v3 API. That's why I wrote Pithub (also available on Github). The API should be almost stable now. There are two kind of test suites included: One is not sending any requests to the Github API at all. It is just verifying that the methods are generating correct HTTP requests. Then there's the second test suite: It's sending real requests to the live Github API. It's covering around 90% of all available API calls, just heading to reach the 100% in the next weeks. Running on the live API can generate a lot of activity in your (and especially your contacts) newsfeed. So if you're eager to contribute to this project and you want to run the live tests, I highly recommend that you setup a test account for that. By default the live testsuite is disabled, via environment variables. The absolute maximum of entries, that are returned per API call, is limited to 100 (the default is 30). If you want to list all repositories of a user, who has more than 100 repositories, you need more than one API call for that. Instead of doing this manually, you can tell Pithub to take care of that by using its auto pagination feature:

#!/usr/bin/env perl

use strict;
use warnings;
use Pithub::Repos;

my $r = Pithub::Repos->new(
    per_page        => 100,
    auto_pagination => 1,
);
my $result = $r->list( user => 'rjbs' );

unless ( $result->success ) {
    printf "something is fishy: %s\n", $result->response->status_line;
    exit 1;
}

while ( my $row = $result->next ) {
    printf "%s: %s\n", $row->{name}, $row->{description} || 'no description';
}

Right now in the second I'm writing this blog post, rjbs++ has 318 public repositories. Running the script listed above will make four requests to the Github API:

Probably nobody else except me is going to use this library, because there's Net::Github already and I bet it's going to support v3 of the API any time soon as well. Even though it was (and is) just fun for me writing it :). I'll write some more about it in the coming days/weeks...

local::lib magic

2011-07-06T20:08:00.006+04:00

plu@localhost ~[master]$ cd ~/Development/Private/Pithub/
Setting local::lib to: /Volumes/perlbrew/locallib/pithub-v5.12.4

plu@localhost ~/Development/Private/Pithub[master]$ cd ~/Development/Private/metacpan-web/
Setting local::lib to: /Volumes/perlbrew/locallib/metacpanweb-v5.12.4


plu@localhost ~[master]$ cat ~/Development/Private/Pithub/.llrc
/Volumes/perlbrew/locallib/pithub

plu@localhost ~[master]$ cat ~/Development/Private/metacpan-web/.llrc 
/Volumes/perlbrew/locallib/metacpanweb

Yes, you can trust your eyes, the local::lib path is set automatically after the directory has been changed. A similar magic is already built into the Ruby Version Manager. They just override/wrap the Bash builtin "cd" with a custom function that checks for the existence of a .rvmrc file in the current directory. Why not do the same for local::lib? Unfortunately the RVM script is not very careful and it just sets the cd function, no matter if there was any defined before or not. I'm trying to be more careful in my script. So if you're using RVM, make sure to load my script after the one provided by RVM. I'm quite sure my script is not perfect, so feel free to improve or modify it!

if [ "$(type -t cd)" == "builtin" ]; then
    local func="_perl_locallib_orig_cd() { builtin cd \"\$@\"; }"
else
    local func="$(declare -f cd)"
    local func="_perl_locallib_orig_cd${func#cd}"
fi
eval $func

_perl_locallib_custom_cd() {
    local cwd=$(pwd)
    if [[ "$HOME" != "$cwd" && -f "$cwd/.llrc" ]] ; then
        local ll=$(cat $cwd/.llrc)-$(perl -e 'print $^V')
        local OLD_PATH=$PERL_LOCAL_LIB_ROOT
        eval $(perl -Mlocal::lib='--deactivate-all' 2>/dev/null)
        eval $(perl -Mlocal::lib=$ll 2>/dev/null)
        if [ "$?" -eq "0" ] && [ "$ll" != "$OLD_PATH" ] && [ -n "$PERL_LOCAL_LIB_ROOT" ]; then
            echo "Setting local::lib to: $ll"
        fi
    else
        if [[ -f "$HOME/.llrc" ]] ; then
            local ll=$(cat $HOME/.llrc)-$(perl -e 'print $^V')
            local OLD_PATH=$PERL_LOCAL_LIB_ROOT
            eval $(perl -Mlocal::lib='--deactivate-all' 2>/dev/null)
            eval $(perl -Mlocal::lib=$ll 2>/dev/null)
            if [ "$?" -eq "0" ] && [ "$ll" != "$OLD_PATH" ] && [ -n "$PERL_LOCAL_LIB_ROOT" ]; then
                echo "Setting local::lib to: $ll"
            fi
        fi
    fi
}

cd() {
    _perl_locallib_orig_cd "$@"
    local result=$?
    if [ "$result" -eq "0" ]; then
        _perl_locallib_custom_cd "$@"
    fi
    return $result
}

Case insensitive filesystems

2011-07-05T20:09:00.004+04:00

On Windows you have no choice, you get a case insensitive filesystem no matter what and on Mac OS you get the case insensitive version of HFS by default. This might get you into trouble if you intend to use File::Stat and File::stat. I had exactly this problem recently on my Mac OS. Of course I could reinstall the whole operating system on the case sensitive version of HFS and get rid of that problem. But some search results on Google told me that's not such a good idea because it might break some Mac OS applications. Another option would be any kind of a virtual machine running Linux for example, but that's just too much for my (anyway slow) Macbook Air. Finally I found an article on how to create a self growing image that can have the case sensitive HFS filesystem. So I've created a 10GB image called perlbrew. Once that was done and mounted I told perlbrew to install itself to /Volumes/perlbrew. Another advantage: I can even share that image via Dropbox between my Macs. Two short bash aliases and I was done and happy:

alias mountpb='hdiutil attach -nobrowse ~/Dropbox/Development/perlbrew.sparseimage'
alias umountpb='diskutil umount /Volumes/perlbrew'

Upgrading Perl from 5.8.7 to 5.12.2

2010-11-28T16:22:00.005+04:00

One of my recent projects at work (xing.com) was to upgrade Perl from version 5.8.7 to the most recent one: 5.12.2 My first attempt was to compile a fresh new Perl on the development environment. Once that was done I generated a list of modules, which were installed on the current Perl 5.8.7 using ExtUtils::Installed:

perl -MExtUtils::Installed -e 'printf "%s\n", $_ for ExtUtils::Installed->new->modules'
Any::Moose
AnyEvent
App::Cache
AppConfig
Archive::Peek
...

This list could be directly piped into the CPAN shell of the Perl 5.12.2 to install all the modules. A few hours later I could finally test the new Perl installation using our software. Unfortunately the software just crashed, spitting out some error like "Wide character in syswrite" (IIRC). After fixing this error, the next one showed up. It was something about Moose. At this point I was thinking the first time that it might not be a good idea to upgrade Perl and install the most recent versions of all modules. The modules used on the Perl 5.8.7 installation are quite old. But instead of doing the right thing (installing the same module versions on 5.12.2 as on 5.8.7) I tried the same thing with 5.10. This attempt failed in the same way as the last one did. Next try: 5.8.7. Result: FAIL. Then I was sure that it's no good idea to use the most recent versions of all modules/dependencies. So I had to find a way to not only install a list of modules, but also to install all of them in certain versions. Unfortunately I could not find any solution which was working out-of-the-box. Though I was sure I'm not the first one doing exactly this task. Basically I just needed an outdated CPAN mirror having all modules in the same version the Perl 5.8.7 installation had. So I used again ExtUtils::Installed to generate a list of modules, this time containing their version:

#!/usr/bin/env perl
use strict;
use warnings;
use ExtUtils::Installed;
my $eui = ExtUtils::Installed->new;
foreach my $m ( $eui->modules ) {
    printf "%s %s\n", $m, $eui->version($m);
}

The 2nd step was using minicpan to create a local CPAN mirror. Some of the modules of the Perl 5.8.7 installation were so old, that I could not find the tar balls on CPAN anymore. I had to write another script using BackPAN::Index to download them from BackPAN:

#!/usr/bin/env perl
use strict;
use warnings;
use BackPAN::Index;
use Data::Dumper;
use ExtUtils::Installed;
use File::Basename qw(basename dirname);
use File::Path qw(make_path);

my $bp_base = 'http://backpan.perl.org';

my $backpan = BackPAN::Index->new;
my $eui     = ExtUtils::Installed->new;

my @notfound = ();

foreach my $m ( $eui->modules ) {
    my $v = sprintf '%s', $eui->version($m);    # force stringify
    my $d = $m;
    $d =~ s/::/-/g;
    my $release = $backpan->release( $d, $v );
    unless ($release) {
        push @notfound, "$m => $v";
        next;
    }
    my $filename = basename( $release->path );
    my $dirname  = dirname( $release->path );
    unlink $filename if -f $filename;
    make_path($dirname) unless -d $dirname;
    printf "Downloading %s/%s to %s/%s\n", $bp_base, $release->path, $dirname, $filename;
    system( sprintf 'wget -P %s -q %s/%s', $dirname, $bp_base, $release->path );
}

if (@notfound) {
    printf "Could not find following distributions:\n%s\nDONE.\n", join "\n", @notfound;
}

Once I got all modules, I had to inject them into my local CPAN mirror using CPAN::Mini::Inject. Finally I just had to add my CPAN mirror to CPAN::Config of the Perl 5.12.2 installation and could pipe the module list of the Perl 5.8.7 installation directly into the CPAN shell. As a result it installed all modules in the same versions. Finally our software was working (almost) fine on the new shiny Perl 5.12.2 installation. A few fixes here and a few fixes there and it went live about 4 weeks ago. You can find all of the scripts I used for this upgrade on my github account.

Outsourcing

2010-11-28T15:50:00.000+04:00

In the past I preferred to host everything myself: eMail, HTTP, git and even DNS. Later I realized that there are providers which do a much better job in hosting this stuff for me. So the first thing I moved was all my eMail stuff to Google Apps. Later I moved all my repositories to github.com, my blog to blogger.com (which is Google as well) and my domains to providerdomain.de. After that there were only three things left on my private server: OpenVPN, irssi and my parents webpage incl. admin backend (plunien.de). OpenVPN could be easily replaced by TeamViewer. The only use case of the VPN was to support my parents once a year fixing a problem on their macs. Their webpage was implemented in Perl/Catalyst which I replaced recently with Django on Google App Engine: https://github.com/plu/plunien-de. So the last but not least irssi could not be replaced. I don't like any other IRC client, neither I do like to run it on my local mac. But at least I could replace that private server with a much less powerful (and much cheaper) vserver from odac.de to run irssi on. So I'd like to thank every of those providers for doing a great job. Especially Google! It was fun to learn Python/Django/GAE.

Gearman::Driver @ XING (GPW2010)

2010-06-10T10:12:00.000+04:00

Yesterday I gave a talk at the German Perl Workshop in Schorndorf about Gearman::Driver @ XING. The slides can be found here as well as the code examples I've used in the slides.

Gearman::Driver

2010-01-30T22:42:00.004+04:00

Gearman was initially developed by Danga. It's a very nice framework to distribute (sometimes long running) tasks across multiple servers. For a more detailed description see gearman.org where you will also find a rewrite of it in C. First let's take a look at it without Gearman::Driver, using a plain Gearman::XS setup:

#!/usr/bin/env perl
use strict;
use warnings;
use Gearman::XS::Worker;
use Gearman::XS qw(:constants);
use Imager;

my $worker = Gearman::XS::Worker->new;
$worker->add_server( 'localhost', 4730 );

$worker->add_function( "convert_to_jpeg", 0, \&convert_to_jpeg, {} );
$worker->add_function( "convert_to_gif",  0, \&convert_to_gif,  {} );

while (1) {
    my $ret = $worker->work();
    if ( $ret != GEARMAN_SUCCESS ) {
        printf( STDERR "%s\n", $worker->error() );
    }
}

sub convert_to_jpeg {
    my ($job) = @_;
    return _convert( $job->workload, 'jpeg' );
}

sub convert_to_gif {
    my ($job) = @_;
    return _convert( $job->workload, 'gif' );
}

sub _convert {
    my ( $in_data, $format ) = @_;
    my $img = Imager->new();
    my $out_data;
    $img->read( data => $in_data ) or die;
    $img->write( data => \$out_data, type => $format ) or die;
    return $out_data;
}

The problem in this design is to have two functions in the same script. If you depend on running convert_to_jpeg and convert_to_gif at the same time you could split up the script:

#!/usr/bin/env perl
use strict;
use warnings;
use Gearman::XS::Worker;
use Gearman::XS qw(:constants);
use Imager;

my $worker = Gearman::XS::Worker->new;
$worker->add_server( 'localhost', 4730 );

$worker->add_function( "convert_to_jpeg", 0, \&convert_to_jpeg, {} );

while (1) {
    my $ret = $worker->work();
    if ( $ret != GEARMAN_SUCCESS ) {
        printf( STDERR "%s\n", $worker->error() );
    }
}

sub convert_to_jpeg {
    my ($job) = @_;
    return _convert( $job->workload, 'jpeg' );
}

sub _convert {
    my ( $in_data, $format ) = @_;
    my $img = Imager->new();
    my $out_data;
    $img->read( data => $in_data ) or die;
    $img->write( data => \$out_data, type => $format ) or die;
    return $out_data;
}

#!/usr/bin/env perl
use strict;
use warnings;
use Gearman::XS::Worker;
use Gearman::XS qw(:constants);
use Imager;

my $worker = Gearman::XS::Worker->new;
$worker->add_server( 'localhost', 4730 );

$worker->add_function( "convert_to_gif", 0, \&convert_to_gif, {} );

while (1) {
    my $ret = $worker->work();
    if ( $ret != GEARMAN_SUCCESS ) {
        printf( STDERR "%s\n", $worker->error() );
    }
}

sub convert_to_gif {
    my ($job) = @_;
    return _convert( $job->workload, 'gif' );
}

sub _convert {
    my ( $in_data, $format ) = @_;
    my $img = Imager->new();
    my $out_data;
    $img->read( data => $in_data ) or die;
    $img->write( data => \$out_data, type => $format ) or die;
    return $out_data;
}

The next problem is about memory: Having many scripts running in separate processes using the same (sometimes heavyweight) library is not very smart. And especially in this example where images are processed those separate processes may consume a lot of ram after a long runtime. So it would be cool to share the memory consumed by libraries as well as freeing up memory from time to time. This is where Gearman::Driver comes in handy. It's not only sharing memory by using the advantages of copy-on-write but it's also having other cool features like restarting worker processes after some idle time to free up memory. Besides that it got some telnet interface to change amount of processes on runtime as well as getting some statistics et cetera. So let's re-implement the example above:

package GDExamples::Convert;

use base qw(Gearman::Driver::Worker);
use Moose;
use Imager;

sub process_name {
    my ( $self, $orig, $job_name ) = @_;
    return "$orig ($job_name)";
}

sub convert_to_jpeg : Job : MinProcesses(0) : MaxProcesses(5) {
    my ( $self, $job, $workload ) = @_;
    return _convert( $workload, 'jpeg' );
}

sub convert_to_gif : Job : MinProcesses(0) : MaxProcesses(5) {
    my ( $self, $job, $workload ) = @_;
    return _convert( $workload, 'gif' );
}

sub _convert {
    my ( $in_data, $format ) = @_;
    my $img = Imager->new();
    my $out_data;
    $img->read( data => $in_data ) or die;
    $img->write( data => \$out_data, type => $format ) or die;
    return $out_data;
}

To run that worker you can use the script called gearman_driver.pl which is part of the Gearman::Driver distribution.

usage: gearman_driver.pl [long options...]
--loglevel           Log level (default: INFO)
--lib                Example: --lib ./lib --lib /custom/lib
--max_idle_time      How many seconds a worker may be idle before its killed
--server             Gearman host[:port][,host[:port]]
--logfile            Path to logfile (default: gearman_driver.log)
--console_port       Port of management console (default: 47300)
--interval           Interval in seconds (see Gearman::Driver::Observer)
--loglayout          Log message layout (default: [%d] %p %m%n)
--namespaces         Example: --namespaces My::Workers --namespaces My::OtherWorkers

Run the example: gearman_driver.pl --namespaces GDExamples & You can easily test the workers using the gearman client:

gearman -f GDExamples::Convert::convert_to_jpeg <> cpan.jpg
gearman -f GDExamples::Convert::convert_to_gif <> cpan.gif

Now let's see what we did. First of all you may have noticed the attributes on both methods:

sub convert_to_jpeg : Job : MinProcesses(0) : MaxProcesses(5) {}
sub convert_to_jpeg : Job : MinProcesses(0) : MaxProcesses(5) {}
sub convert_to_jpeg : Job : MinProcesses(0) : MaxProcesses(5) {}

Basically you only need to add the attribute Job to the methods which should be registered with gearmand. All other attributes are optional. Your method will be registered with the full package name:

GDExamples::Convert::convert_to_jpeg
GDExamples::Convert::convert_to_gif

If you don't like that behaviour you can override prefix. By default it's implemented this way:

sub prefix {
    return ref(shift) . '::';
}

There are other predefined methods which can be overridden, like begin or end. Both are called whenever a job function is called, begin before the job method is called and end afterwards (even if the job method died). The other two attributes tell Gearman::Driver how many processes should be forked and work on that function/job. If you set MinProcesses to 0 no process is preforked at all. It's being forked on demand: Gearman::Driver monitors the telnet interface of gearmand for queued jobs to see if it's necessary to fork a new process. If there are many jobs in the queue it will fork even more processes until MaxProcesses is reached. After all jobs are done it will kill all processes again. The default behaviour is to do that immediately, but can be changed by setting max_idle_time to 300 (seconds) for example. Gearman::Driver itself got a telnet interface as well. There's also a client coming with the distribution having readline support. Another feature is to connect to multiple servers at once to send the same commands to all servers. Really handy in a big environment.

gearman_driver_console.pl --server localhost:47300
console> status
localhost:47300> GDExamples::Convert::convert_to_gif   0  5  0  2010-01-30T19:45:43  1970-01-01T00:00:00
localhost:47300> GDExamples::Convert::convert_to_jpeg  0  5  0  2010-01-30T19:45:53  1970-01-01T00:00:00
localhost:47300> .
console> set_processes GDExamples::Convert::convert_to_gif 2 10
localhost:47300> OK
localhost:47300> .
console> status
localhost:47300> GDExamples::Convert::convert_to_gif   2  10  2  2010-01-30T19:45:43  1970-01-01T00:00:00
localhost:47300> GDExamples::Convert::convert_to_jpeg  0   5  0  2010-01-30T19:45:53  1970-01-01T00:00:00
localhost:47300> .

I've just shipped v0.01017 to the CPAN containing the examples in this blog post. If you can't wait for it, you can fetch it from GitHub. Any comments/suggestions/rants will be highly appreciated. Thanks.

Catalyst + DBIC + DAO

2009-05-28T00:39:00.001+04:00

Recently there was a question on the Catalyst mailing list which i've been asked by some teammate too: "How do i create DataAccessObjects with methods i can use in Catalyst as well as in CronJobs or other scripts?" You're too lazy to read the full entry, you just want to see the code? It's available on GitHub: http://github.com/plu/dao-example/tree/master It's quite easy, all you need is custom DBIx::Class ResultSets. I guess you've already setup a model in your Catalyst app:

package DAO::Example::Model::DB;

use strict;
use warnings;
use base 'Catalyst::Model::DBIC::Schema';

1;

...and a config file that might look like:

# rename this file to DAO::Example.yml and put a : in front of "name" if
# you want to use yaml like in old versions of Catalyst
name DAO::Example


    schema_class    DAO::Example::DB
    connect_info    dbi:SQLite:dao_example.db
    connect_info    username
    connect_info    password

To get custom resultsets for all of your result classes setup the schema using load_namespaces:

package DAO::Example::DB;

use strict;
use warnings;
use base qw/DBIx::Class::Schema/;

__PACKAGE__->load_namespaces( default_resultset_class => '+DAO::Example::DB::Base::ResultSet' );

1;

Going that way your result classes will be expected in DAO::Example::DB::Result:: namespace, resultsets in DAO::Example::DB::ResultSet::. If you create a class DAO::Example::DB::Result::Person DBIC will look if DAO::Example::DB::ResultSet::Person exists and inherit all person resultsets from that class. If there's no such class the resultset will be inherited from DAO::Example::DB::Base::ResultSet. Let's add some methods to the person resultset:

package DAO::Example::DB::ResultSet::Person;

use strict;
use warnings;
use base qw/DAO::Example::DB::Base::ResultSet/;

sub by_username {
    my ( $rs, $username ) = @_;
    return $rs->search( { 'me.username' => $username }, { key => 'unique_username' } );
}

sub prefetch_all {
    my ($rs) = @_;
    return $rs->search( {}, { prefetch => [ { personroles => [qw/role/] } ] } );
}

1;

And to the default resultset:

package DAO::Example::DB::Base::ResultSet;

use strict;
use warnings;
use base qw/DBIx::Class::ResultSet::HashRef DAO::Example::DB::Base::Any/;

sub active {
    my ($rs) = @_;
    return $rs->search( { 'me.active' => 1 } );
}

sub inactive {
    my ($rs) = @_;
    return $rs->search( { 'me.active' => { '!=' => 1 } } );
}

1;

In catalyst you would call these methods that way:

package DAO::Example::Controller::Root;

use strict;
use warnings;
use parent 'Catalyst::Controller';
use Data::Dumper;
$Data::Dumper::Sortkeys = 1;

__PACKAGE__->config->{namespace} = '';

sub index : Path : Args(0) {
    my ( $self, $c ) = @_;

    unless ( -e $c->path_to('dao_example.db') ) {
        $c->model('DB')->schema->deploy;
        $c->model('DB')->schema->init;
    }

    $c->res->print('');
    $c->res->print( Dumper $c->config );
    $c->res->print( Dumper $c->model('DB')->resultset('Person')->active->hashref_array );
    $c->res->print( Dumper $c->model('DB')->resultset('Person')->inactive->hashref_array );
    $c->res->print( Dumper $c->model('DB')->resultset('Person')->by_username('plu')->prefetch_all->hashref_array );
    $c->res->print('');
}

The method hashref_array comes from DBIx::Class::ResultSet::HashRef. How would you call that from a CronJob / without Catalyst?

#!/usr/bin/env perl
use strict;
use warnings;
use FindBin;
use lib "$FindBin::Bin/../lib";
use DAO::Example::Utils qw/schema config/;
use Data::Dumper;
$Data::Dumper::Sortkeys = 1;

unless ( -e "$FindBin::Bin/../dao_example.db" ) {
    schema->deploy;
    schema->init;
}

print Dumper config;

print Dumper schema->resultset('Person')->active->hashref_array;

print Dumper schema->resultset('Person')->inactive->hashref_array;

print Dumper schema->resultset('Person')->by_username('plu')->prefetch_all->hashref_array;

The "magic" thing is to instantiate a DBIx::Class::Schema object using your Catalyst config file. I tend to write a small utility class to achieve that:

package DAO::Example::Utils;

use strict;
use warnings;
use base 'Exporter';
use Config::JFDI;
use DAO::Example::DB;

use vars qw/@EXPORT_OK $schema $config/;

@EXPORT_OK = qw/
  schema
  config
  /;

sub config {
    return $config if defined $config;
    $config = Config::JFDI->new( name => "DAO::Example" )->get;
    return $config;
}

sub schema {
    return $schema if defined $schema;
    $schema = DAO::Example::DB->connect( @{ config->{'Model::DB'}{connect_info} || [] } );
    return $schema;
}

1;

irssi: Twitter

2009-02-01T21:44:00.001+04:00

install all dependencies (POE, POE::Loop::Glib, POE::Session::Irssi, Net::Twitter, HTML::Entities, HTTP::Date)
change credentials
/script load /path/to/twitter.pl
/window new hidden
change to the new window and type /window name twitter

use strict;
use warnings;
use Irssi;
use Glib;
use POE qw(Loop::Glib Session::Irssi);
use Net::Twitter;
use HTML::Entities qw( decode_entities );
use HTTP::Date qw( time2str );

my $VERSION = '0.1';
my %IRSSI   = (
    authors => 'Johannes Plunien',
    contact => 'http://www.pqpq.de/contact/',
    name    => 'Twitter',
    license => 'Perl',
);

my %twitter_config = (
    username        => 'plutooth',
    password        => 'secret',
    update_interval => 90,           # seconds
);

POE::Session::Irssi->create(
    irssi_commands => {
        tmsg => sub {
            $_[HEAP]->{twitter}->update( join " ", ( @{ $_[ARG1] } )[0] );
            $_[KERNEL]->delay( update => 5 );
        },
    },
    inline_states => {
        _start => sub {
            my $heap = $_[HEAP];
            $heap->{window} = Irssi::window_find_name('twitter');
            Irssi::print("Create a window named 'twitter'") if !$heap->{window};
            my ( $kernel, $heap ) = @_[ KERNEL, HEAP ];
            $heap->{interval} = delete $twitter_config{update_interval};
            $heap->{twitter}  = Net::Twitter->new(%twitter_config)
              or Irssi::print("Twitter ERROR: $!");
            $kernel->delay( update => 2 );
        },
        update => sub {
            my ( $kernel, $heap ) = @_[ KERNEL, HEAP ];
            my $params = {};
            $params->{since} = $heap->{last_update} if defined $heap->{last_update};
            my $timeline    = $heap->{twitter}->friends_timeline($params);
            my $http_status = $heap->{twitter}->http_code;
            $heap->{window} = Irssi::window_find_name('twitter');
            if (   $http_status == 200
                && $heap->{window} )
            {
                $heap->{last_update} = time2str(time);
                $kernel->yield( display => $timeline ) if scalar @$timeline > 0;
            }
            $kernel->delay( update => $heap->{interval} );
        },
        display => sub {
            my ( $kernel, $heap, $timeline ) = @_[ KERNEL, HEAP, ARG0 ];
            foreach my $row ( reverse @$timeline ) {
                my $screen_name = $row->{user}{screen_name};
                my $text        = $row->{text};
                $text =~ s/\n/\n   /;
                my $cleantext = decode_entities($text);
                my $message   = "<$screen_name> $cleantext";
                $heap->{window}->print( $message, MSGLEVEL_PUBLIC );
            }
        },
    },
);

irssi: Close all queries

2008-10-02T12:01:00.001+04:00

This irssi script creates a new command to close all open queries at once. I don't know what else to explain here, i think the script explains itself.

use strict;
use warnings;
use Irssi;
use Glib;
use POE qw(Loop::Glib Session::Irssi);

my $VERSION = '0.1';
my %IRSSI   = (
    authors => 'Johannes Plunien',
    contact => 'http://www.pqpq.de/contact/',
    license => 'Perl',
);

POE::Session::Irssi->create(
    irssi_commands => {
        qc => sub {
            foreach my $w ( Irssi::windows() ) {
                my $act = $w->{active};
                next unless defined $act->{type};
                $w->command("window close") if $act->{type} eq 'QUERY';
            }
        },
    },
);

Firebug debugging fallback

2008-07-29T11:12:00.001+04:00

Firebug is the best tool for debugging heavyweight javascript web applications. You can put console.log(arguments) here and console.debug(foo) there, but ... YOU SHOULD NEVER FORGET TO REMOVE IT! If you forget it, your application stops working in any browser that doesn't know those methods. To avoid this, just include this snippet:

if(!window.console || !window.console.firebug) {
  window.console = {
    debug: function(){},
    log: function(){}
  };
}

/Edit: I just found http://getfirebug.com/firebug/firebugx.js which is more complete:

if (!window.console || !console.firebug)
{
    var names = ["log", "debug", "info", "warn", "error", "assert", "dir", "dirxml",
    "group", "groupEnd", "time", "timeEnd", "count", "trace", "profile", "profileEnd"];

    window.console = {};
    for (var i = 0; i < names.length; ++i)
        window.console[names[i]] = function() {}
}

Remote form validation

2008-07-26T15:17:00.001+04:00

Catalyst and ExtJS are my favourite frameworks for developing web applications. ExtJS provides a lot features to validate form data before the form is being submitted to the server. Everybody knows that you never should trust those values even if it was validated in the browser by ExtJS. Here is a comfortable way to validate form values remotely using Catalyst::Plugin::FormValidator::Simple. The full example can be found on github: git clone git://github.com/plu/rfv-example.git

Create an ExtJS FormPanel:

var win = new Ext.Window({
    .....
    ,items:[
        new Ext.FormPanel({
            ,url:'[% Catalyst.uri_for('/save') %]'
            ,id: 'fp'
            .....
            ,items: [{
                fieldLabel: 'First name',
                name: 'first',
                anchor:'100%'
            },{
                fieldLabel: 'Last name',
                name: 'last',
                anchor:'100%'
            },{
                fieldLabel: 'Company',
                name: 'company',
                anchor:'100%'
            },{
                fieldLabel: 'eMail',
                name: 'email',
                anchor:'100%'
            }]
            ,buttons: [{
                text: 'Save',
                handler: function() {
                    win.findById('fp').getForm().submit();
                }
            }]
        })
    ]
});

Read validation results and modify form fields:

var fp = win.findById('fp');
fp.on('actioncomplete', function(a, fp) {
    var r = fp.result;
    for (var field in r.error) {
        fp.form.findField(field).markInvalid(
            r.error[field].join("<br/>")
        );
    }
});

Validate form values:

sub save : Global {
    my ( $self, $c ) = @_;

    $c->form(
        first   => [ qw/NOT_BLANK ASCII/ => [qw/LENGTH 2 20/] ],
        last    => [ qw/NOT_BLANK ASCII/ => [qw/LENGTH 2 20/] ],
        company => [ qw/NOT_BLANK ASCII/ => [qw/LENGTH 2 20/] ],
        email   => [qw/NOT_BLANK EMAIL_LOOSE/],
    );

    my $json : Stashed = { error => $c->form->field_messages('save'), };
}

MojoMojo - make it private

2008-07-17T10:38:00.002+04:00

MojoMojo is a wiki written in Catalyst and DBIx::Class. It was the best choice to replace my private MediaWiki. The installation is straight forward:

svn co http://code2.0beta.co.uk/mojomojo/svn/trunk/ MojoMojo
cd MojoMojo
perl Makefile.PL
make

The standard way to install MojoMojo is through CPAN. You can find the distribution for it here, or you can install it from the command line like this:

sudo cpan MojoMojo

After successful installation MojoMojo needs to be configured using its mojomojo.conf. Generally you can just edit this file directly, but if you're using the svn checkout and probably want to contribute some changes later you better go for a new mojomojo_local.conf. So you can have your database credentials in that file and you don't have to worry about committing it by accident.

<Model::DBIC>
    connect_info   dbi:mysql:mojomojo
    connect_info   mojomojo
    connect_info   sTrOnGpAsSwOrD
</Model::DBIC>

Create database tables:

./script/mojomojo_spawn_db.pl

Done. Now you can deploy MojoMojo using mod_perl, FastCGI or just run it using Catalysts development webserver:

./script/mojomojo_server -p 3000

My previous MediaWiki installation was only accessible by username and password. So i needed to get my head around the authorization implementation in MojoMojo. First of all you need to add some lines to the config:

<permissions>
check_permission_on_view    1
cache_permission_data       1
create_allowed              0
delete_allowed              0
edit_allowed                0
view_allowed                0
attachment_allowed          0
</permissions>

Additionally there are a few database changes necessary:

-- add a new role
insert into role values (null, 'user', 1);

-- add this role to the standard admin user
insert into role_member values (1, 2, 1);

-- allow everything to that new role
insert into path_permissions values
('/', 1, 'no', 'yes', 'yes', 'yes', 'yes', 'yes');
insert into path_permissions values
('/', 1, 'yes', 'yes', 'yes', 'yes', 'yes', 'yes');

How does it look like now?

mysql> select * from role;
+----+------+--------+
| id | name | active |
+----+------+--------+
|  1 | user |      1 |
+----+------+--------+

mysql> select * from role_member;
+------+--------+-------+
| role | person | admin |
+------+--------+-------+
|    1 |      2 |     1 |
+------+--------+-------+

mysql> select * from path_permissions\G
*************************** 1. row ***************************
path: /
role: 1
apply_to_subpages: no
create_allowed: yes
delete_allowed: yes
edit_allowed: yes
view_allowed: yes
attachment_allowed: yes
*************************** 2. row ***************************
path: /
role: 1
apply_to_subpages: yes
create_allowed: yes
delete_allowed: yes
edit_allowed: yes
view_allowed: yes
attachment_allowed: yes

To get this working please make sure to use at least version 0.999018 or revision 927 of MojoMojo. In next release of MojoMojo there will be also a new flag to enforce login:

<permissions>
    enforce_login 1
</permissions>