lib/Catalyst/Engine.pm

   1 package Catalyst::Engine;
   2
   3 use strict;
   4 use base qw/Class::Data::Inheritable Class::Accessor::Fast/;
   5 use UNIVERSAL::require;
   6 use Data::Dumper;
   7 use HTML::Entities;
   8 use HTTP::Headers;
   9 use Memoize;
  10 use Time::HiRes qw/gettimeofday tv_interval/;
  11 use Tree::Simple;
  12 use Tree::Simple::Visitor::FindByPath;
  13 use Catalyst::Request;
  14 use Catalyst::Response;
  15
  16 require Module::Pluggable::Fast;
  17
  18 $Data::Dumper::Terse = 1;
  19
  20 __PACKAGE__->mk_classdata($_) for qw/actions components tree/;
  21 __PACKAGE__->mk_accessors(qw/request response state/);
  22
  23 __PACKAGE__->actions(
  24     { plain => {}, private => {}, regex => {}, compiled => {}, reverse => {} }
  25 );
  26 __PACKAGE__->tree( Tree::Simple->new( 0, Tree::Simple->ROOT ) );
  27
  28 *comp = \&component;
  29 *req  = \&request;
  30 *res  = \&response;
  31
  32 our $COUNT = 1;
  33 our $START = time;
  34
  35 memoize('_class2prefix');
  36
  37 =head1 NAME
  38
  39 Catalyst::Engine - The Catalyst Engine
  40
  41 =head1 SYNOPSIS
  42
  43 See L<Catalyst>.
  44
  45 =head1 DESCRIPTION
  46
  47 =head1 METHODS
  48
  49 =over 4
  50
  51 =item $c->action( $name => $coderef, ... )
  52
  53 Add one or more actions.
  54
  55     $c->action( '!foo' => sub { $_[1]->res->output('Foo!') } );
  56
  57 It also automatically calls setup() if needed.
  58
  59 See L<Catalyst::Manual::Intro> for more informations about actions.
  60
  61 =cut
  62
  63 sub action {
  64     my $self = shift;
  65     $self->setup unless $self->components;
  66     $self->actions( {} ) unless $self->actions;
  67     my $action;
  68     $_[1] ? ( $action = {@_} ) : ( $action = shift );
  69     if ( ref $action eq 'HASH' ) {
  70         while ( my ( $name, $code ) = each %$action ) {
  71             $self->set_action( $name, $code, caller(0) );
  72         }
  73     }
  74     return 1;
  75 }
  76
  77 =item $c->get_action( $action, $namespace )
  78
  79 Get an action in a given namespace.
  80
  81 =cut
  82
  83 sub get_action {
  84     my ( $c, $action, $namespace ) = @_;
  85     $namespace ||= '';
  86     if ( $action =~ /^\!(.*)/ ) {
  87         $action = $1;
  88         my $parent = $c->tree;
  89         my @results;
  90         my $result = $c->actions->{private}->{ $parent->getUID }->{$action};
  91         push @results, [$result] if $result;
  92         my $visitor = Tree::Simple::Visitor::FindByPath->new;
  93         for my $part ( split '/', $namespace ) {
  94             $visitor->setSearchPath($part);
  95             $parent->accept($visitor);
  96             my $child = $visitor->getResult;
  97             my $uid   = $child->getUID if $child;
  98             my $match = $c->actions->{private}->{$uid}->{$action} if $uid;
  99             push @results, [$match] if $match;
 100             $parent = $child if $child;
 101         }
 102         return \@results;
 103     }
 104     elsif ( my $p = $c->actions->{plain}->{$action} ) { return [ [$p] ] }
 105     elsif ( my $r = $c->actions->{regex}->{$action} ) { return [ [$r] ] }
 106     else {
 107         for my $regex ( keys %{ $c->actions->{compiled} } ) {
 108             my $name = $c->actions->{compiled}->{$regex};
 109             if ( $action =~ $regex ) {
 110                 my @snippets;
 111                 for my $i ( 1 .. 9 ) {
 112                     no strict 'refs';
 113                     last unless ${$i};
 114                     push @snippets, ${$i};
 115                 }
 116                 return [ [ $c->actions->{regex}->{$name}, $name, \@snippets ] ];
 117             }
 118         }
 119     }
 120     return [];
 121 }
 122
 123 =item $c->set_action( $action, $code, $namespace )
 124
 125 Set an action in a given namespace.
 126
 127 =cut
 128
 129 sub set_action {
 130     my ( $c, $action, $code, $namespace ) = @_;
 131
 132     my $prefix = '';
 133     if ( $action =~ /^\?(.*)$/ ) {
 134         my $prefix = $1 || '';
 135         $action = $2;
 136         $action = $prefix . _prefix( $namespace, $action );
 137         $c->actions->{plain}->{$action} = [ $namespace, $code ];
 138     }
 139     if ( $action =~ /^\/(.*)\/$/ ) {
 140         my $regex = $1;
 141         $c->actions->{compiled}->{qr#$regex#} = $action;
 142         $c->actions->{regex}->{$action} = [ $namespace, $code ];
 143     }
 144     elsif ( $action =~ /^\!(.*)$/ ) {
 145         $action = $1;
 146         my $parent  = $c->tree;
 147         my $visitor = Tree::Simple::Visitor::FindByPath->new;
 148         $prefix = _class2prefix($namespace);
 149         for my $part ( split '/', $prefix ) {
 150             $visitor->setSearchPath($part);
 151             $parent->accept($visitor);
 152             my $child = $visitor->getResult;
 153             unless ($child) {
 154                 $child = $parent->addChild( Tree::Simple->new($part) );
 155                 $visitor->setSearchPath($part);
 156                 $parent->accept($visitor);
 157                 $child = $visitor->getResult;
 158             }
 159             $parent = $child;
 160         }
 161         my $uid = $parent->getUID;
 162         $c->actions->{private}->{$uid}->{$action} = [ $namespace, $code ];
 163         $action = "!$action";
 164     }
 165     else {
 166        $c->actions->{plain}->{$action} = [ $namespace, $code ];
 167     }
 168
 169     my $reverse = $prefix ? "$action ($prefix)" : $action;
 170     $c->actions->{reverse}->{"$code"} = $reverse;
 171
 172     $c->log->debug(qq/"$namespace" defined "$action" as "$code"/)
 173       if $c->debug;
 174 }
 175
 176 =item $c->benchmark($coderef)
 177
 178 Takes a coderef with arguments and returns elapsed time as float.
 179
 180     my ( $elapsed, $status ) = $c->benchmark( sub { return 1 } );
 181     $c->log->info( sprintf "Processing took %f seconds", $elapsed );
 182
 183 =cut
 184
 185 sub benchmark {
 186     my $c       = shift;
 187     my $code    = shift;
 188     my $time    = [gettimeofday];
 189     my @return  = &$code(@_);
 190     my $elapsed = tv_interval $time;
 191     return wantarray ? ( $elapsed, @return ) : $elapsed;
 192 }
 193
 194 =item $c->comp($name)
 195
 196 =item $c->component($name)
 197
 198 Get a component object by name.
 199
 200     $c->comp('MyApp::Model::MyModel')->do_stuff;
 201
 202 Regex search for a component.
 203
 204     $c->comp('mymodel')->do_stuff;
 205
 206 =cut
 207
 208 sub component {
 209     my ( $c, $name ) = @_;
 210     if ( my $component = $c->components->{$name} ) {
 211         return $component;
 212     }
 213     else {
 214         for my $component ( keys %{ $c->components } ) {
 215             return $c->components->{$component} if $component =~ /$name/i;
 216         }
 217     }
 218 }
 219
 220 =item $c->errors
 221
 222 =item $c->errors($error, ...)
 223
 224 =item $c->errors($arrayref)
 225
 226 Returns an arrayref containing errors messages.
 227
 228     my @errors = @{ $c->errors };
 229
 230 Add a new error.
 231
 232     $c->errors('Something bad happened');
 233
 234 =cut
 235
 236 sub errors {
 237     my $c = shift;
 238     my $errors = ref $_[0] eq 'ARRAY' ? $_[0] : [@_];
 239     push @{ $c->{errors} }, @$errors;
 240     return $c->{errors};
 241 }
 242
 243 =item $c->finalize
 244
 245 Finalize request.
 246
 247 =cut
 248
 249 sub finalize {
 250     my $c = shift;
 251
 252     if ( my $location = $c->res->redirect ) {
 253         $c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
 254         $c->res->headers->header( Location => $location );
 255         $c->res->status(302);
 256     }
 257
 258     if ( !$c->res->output || $#{ $c->errors } >= 0 ) {
 259         $c->res->headers->content_type('text/html');
 260         my $name = $c->config->{name} || 'Catalyst Application';
 261         my ( $title, $errors, $infos );
 262         if ( $c->debug ) {
 263             $errors = join '<br/>', @{ $c->errors };
 264             $errors ||= 'No output';
 265             $title = $name = "$name on Catalyst $Catalyst::VERSION";
 266             my $req   = encode_entities Dumper $c->req;
 267             my $res   = encode_entities Dumper $c->res;
 268             my $stash = encode_entities Dumper $c->stash;
 269             $infos = <<"";
 270 <br/>
 271 <b><u>Request</u></b><br/>
 272 <pre>$req</pre>
 273 <b><u>Response</u></b><br/>
 274 <pre>$res</pre>
 275 <b><u>Stash</u></b><br/>
 276 <pre>$stash</pre>
 277
 278         }
 279         else {
 280             $title  = $name;
 281             $errors = '';
 282             $infos  = <<"";
 283 <pre>
 284 (en) Please come back later
 285 (de) Bitte versuchen sie es spaeter nocheinmal
 286 (nl) Gelieve te komen later terug
 287 (no) Vennligst prov igjen senere
 288 (fr) Veuillez revenir plus tard
 289 (es) Vuelto por favor mas adelante
 290 (pt) Voltado por favor mais tarde
 291 (it) Ritornato prego più successivamente
 292 </pre>
 293
 294             $name = '';
 295         }
 296         $c->res->{output} = <<"";
 297 <html>
 298     <head>
 299         <title>$title</title>
 300         <style type="text/css">
 301             body {
 302                 font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
 303                              Tahoma, Arial, helvetica, sans-serif;
 304                 color: #ddd;
 305                 background-color: #eee;
 306                 margin: 0px;
 307                 padding: 0px;
 308             }
 309             div.box {
 310                 background-color: #ccc;
 311                 border: 1px solid #aaa;
 312                 padding: 4px;
 313                 margin: 10px;
 314                 -moz-border-radius: 10px;
 315             }
 316             div.errors {
 317                 background-color: #977;
 318                 border: 1px solid #755;
 319                 padding: 8px;
 320                 margin: 4px;
 321                 margin-bottom: 10px;
 322                 -moz-border-radius: 10px;
 323             }
 324             div.infos {
 325                 background-color: #797;
 326                 border: 1px solid #575;
 327                 padding: 8px;
 328                 margin: 4px;
 329                 margin-bottom: 10px;
 330                 -moz-border-radius: 10px;
 331             }
 332             div.name {
 333                 background-color: #779;
 334                 border: 1px solid #557;
 335                 padding: 8px;
 336                 margin: 4px;
 337                 -moz-border-radius: 10px;
 338             }
 339         </style>
 340     </head>
 341     <body>
 342         <div class="box">
 343             <div class="errors">$errors</div>
 344             <div class="infos">$infos</div>
 345             <div class="name">$name</div>
 346         </div>
 347     </body>
 348 </html>
 349
 350     }
 351     $c->res->headers->content_length( length $c->res->output );
 352     my $status = $c->finalize_headers;
 353     $c->finalize_output;
 354     return $status;
 355 }
 356
 357 =item $c->finalize_headers
 358
 359 Finalize headers.
 360
 361 =cut
 362
 363 sub finalize_headers { }
 364
 365 =item $c->finalize_output
 366
 367 Finalize output.
 368
 369 =cut
 370
 371 sub finalize_output { }
 372
 373 =item $c->forward($command)
 374
 375 Forward processing to a private/public action or a method from a class.
 376 If you define a class without method it will default to process().
 377
 378     $c->forward('!foo');
 379     $c->forward('index.html');
 380     $c->forward(qw/MyApp::Model::CDBI::Foo do_stuff/);
 381     $c->forward('MyApp::View::TT');
 382
 383 =cut
 384
 385 sub forward {
 386     my $c       = shift;
 387     my $command = shift;
 388     unless ($command) {
 389         $c->log->debug('Nothing to forward to') if $c->debug;
 390         return 0;
 391     }
 392     my $caller = caller(0);
 393     if ( $command =~ /^\?(.*)$/ ) {
 394         $command = $1;
 395         $command = _prefix( $caller, $command );
 396     }
 397     my $namespace = '';
 398     if ( $command =~ /^\!/ ) {
 399         $namespace = _class2prefix($caller);
 400     }
 401     if ( my $results = $c->get_action( $command, $namespace ) ) {
 402         if ( $command =~ /^\!/ ) {
 403             for my $result ( @{$results} ) {
 404                 my ( $class, $code ) = @{ $result->[0] };
 405                 $c->state( $c->process( $class, $code ) );
 406             }
 407         }
 408         else {
 409             return 0 unless my $result = $results->[0];
 410             if ( $result->[2] ) {
 411                 $c->log->debug(qq/Couldn't forward "$command" to regex action/)
 412                   if $c->debug;
 413                 return 0;
 414             }
 415             my ( $class, $code ) = @{ $result->[0] };
 416             $class = $c->components->{$class} || $class;
 417             $c->state( $c->process( $class, $code ) );
 418         }
 419     }
 420     else {
 421         my $class = $command;
 422         if ( $class =~ /[^\w\:]/ ) {
 423             $c->log->debug(qq/Couldn't forward to "$class"/) if $c->debug;
 424             return 0;
 425         }
 426         my $method = shift || 'process';
 427         if ( my $code = $class->can($method) ) {
 428             $c->actions->{reverse}->{"$code"} = "$class->$method";
 429             $c->state( $c->process( $class, $code ) );
 430         }
 431         else {
 432             $c->log->debug(qq/Couldn't forward to "$class->$method"/)
 433               if $c->debug;
 434             return 0;
 435         }
 436     }
 437     return $c->state;
 438 }
 439
 440 =item $c->handler($r)
 441
 442 Handles the request.
 443
 444 =cut
 445
 446 sub handler {
 447     my ( $class, $r ) = @_;
 448
 449     # Always expect worst case!
 450     my $status = -1;
 451     eval {
 452         my $handler = sub {
 453             my $c         = $class->prepare($r);
 454             my $action    = $c->req->action;
 455             my $namespace = '';
 456             $namespace = join '/', @{ $c->req->args } if $action eq '!default';
 457             unless ($namespace) {
 458                 if ( my $result = $c->get_action($action) ) {
 459                     $namespace = _class2prefix( $result->[0]->[0]->[0] );
 460                 }
 461             }
 462             my $results = $c->get_action( $action, $namespace );
 463             if ( @{$results} ) {
 464                 for my $begin ( @{ $c->get_action( '!begin', $namespace ) } ) {
 465                     $c->state( $c->process( @{ $begin->[0] } ) );
 466                 }
 467                 for my $result ( @{ $c->get_action( $action, $namespace ) } ) {
 468                     $c->state( $c->process( @{ $result->[0] } ) );
 469                 }
 470                 for my $end ( @{ $c->get_action( '!end', $namespace ) } ) {
 471                     $c->state( $c->process( @{ $end->[0] } ) );
 472                 }
 473             }
 474             else {
 475                 my $path  = $c->req->path;
 476                 my $error = $path
 477                   ? qq/Unknown resource "$path"/
 478                   : "No default action defined";
 479                 $c->log->error($error) if $c->debug;
 480                 $c->errors($error);
 481             }
 482             return $c->finalize;
 483         };
 484         if ( $class->debug ) {
 485             my $elapsed;
 486             ( $elapsed, $status ) = $class->benchmark($handler);
 487             $elapsed = sprintf '%f', $elapsed;
 488             my $av = sprintf '%.3f', 1 / $elapsed;
 489             $class->log->info( "Request took $elapsed" . "s ($av/s)" );
 490         }
 491         else { $status = &$handler }
 492     };
 493     if ( my $error = $@ ) {
 494         chomp $error;
 495         $class->log->error(qq/Caught exception in engine "$error"/);
 496     }
 497     $COUNT++;
 498     return $status;
 499 }
 500
 501 =item $c->prepare($r)
 502
 503 Turns the engine-specific request (Apache, CGI...) into a Catalyst context.
 504
 505 =cut
 506
 507 sub prepare {
 508     my ( $class, $r ) = @_;
 509     my $c = bless {
 510         request => Catalyst::Request->new(
 511             {
 512                 arguments  => [],
 513                 cookies    => {},
 514                 headers    => HTTP::Headers->new,
 515                 parameters => {},
 516                 snippets   => [],
 517                 uploads    => {}
 518             }
 519         ),
 520         response => Catalyst::Response->new(
 521             { cookies => {}, headers => HTTP::Headers->new, status => 200 }
 522         ),
 523         stash => {},
 524         state => 0
 525     }, $class;
 526     if ( $c->debug ) {
 527         my $secs = time - $START || 1;
 528         my $av = sprintf '%.3f', $COUNT / $secs;
 529         $c->log->debug('********************************');
 530         $c->log->debug("* Request $COUNT ($av/s) [$$]");
 531         $c->log->debug('********************************');
 532         $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
 533     }
 534     $c->prepare_request($r);
 535     $c->prepare_path;
 536     $c->prepare_cookies;
 537     $c->prepare_headers;
 538     $c->prepare_connection;
 539     my $method   = $c->req->method   || '';
 540     my $path     = $c->req->path     || '';
 541     my $hostname = $c->req->hostname || '';
 542     my $address  = $c->req->address  || '';
 543     $c->log->debug(qq/"$method" request for "$path" from $hostname($address)/)
 544       if $c->debug;
 545     $c->prepare_action;
 546     $c->prepare_parameters;
 547
 548     if ( $c->debug && keys %{ $c->req->params } ) {
 549         my @params;
 550         for my $key ( keys %{ $c->req->params } ) {
 551             my $value = $c->req->params->{$key} || '';
 552             push @params, "$key=$value";
 553         }
 554         $c->log->debug( 'Parameters are "' . join( ' ', @params ) . '"' );
 555     }
 556     $c->prepare_uploads;
 557     return $c;
 558 }
 559
 560 =item $c->prepare_action
 561
 562 Prepare action.
 563
 564 =cut
 565
 566 sub prepare_action {
 567     my $c    = shift;
 568     my $path = $c->req->path;
 569     my @path = split /\//, $c->req->path;
 570     $c->req->args( \my @args );
 571     while (@path) {
 572         $path = join '/', @path;
 573         if ( my $result = ${ $c->get_action($path) }[0] ) {
 574
 575             # It's a regex
 576             if ($#$result) {
 577                 my $match    = $result->[1];
 578                 my @snippets = @{ $result->[2] };
 579                 $c->log->debug(qq/Requested action "$path" matched "$match"/)
 580                   if $c->debug;
 581                 $c->log->debug(
 582                     'Snippets are "' . join( ' ', @snippets ) . '"' )
 583                   if ( $c->debug && @snippets );
 584                 $c->req->action($match);
 585                 $c->req->snippets( \@snippets );
 586             }
 587             else {
 588                 $c->req->action($path);
 589                 $c->log->debug(qq/Requested action "$path"/) if $c->debug;
 590             }
 591             $c->req->match($path);
 592             last;
 593         }
 594         unshift @args, pop @path;
 595     }
 596     unless ( $c->req->action ) {
 597         $c->req->action('!default');
 598         $c->req->match('');
 599     }
 600     $c->log->debug( 'Arguments are "' . join( '/', @args ) . '"' )
 601       if ( $c->debug && @args );
 602 }
 603
 604 =item $c->prepare_connection
 605
 606 Prepare connection.
 607
 608 =cut
 609
 610 sub prepare_connection { }
 611
 612 =item $c->prepare_cookies
 613
 614 Prepare cookies.
 615
 616 =cut
 617
 618 sub prepare_cookies { }
 619
 620 =item $c->prepare_headers
 621
 622 Prepare headers.
 623
 624 =cut
 625
 626 sub prepare_headers { }
 627
 628 =item $c->prepare_parameters
 629
 630 Prepare parameters.
 631
 632 =cut
 633
 634 sub prepare_parameters { }
 635
 636 =item $c->prepare_path
 637
 638 Prepare path and base.
 639
 640 =cut
 641
 642 sub prepare_path { }
 643
 644 =item $c->prepare_request
 645
 646 Prepare the engine request.
 647
 648 =cut
 649
 650 sub prepare_request { }
 651
 652 =item $c->prepare_uploads
 653
 654 Prepare uploads.
 655
 656 =cut
 657
 658 sub prepare_uploads { }
 659
 660 =item $c->process($class, $coderef)
 661
 662 Process a coderef in given class and catch exceptions.
 663 Errors are available via $c->errors.
 664
 665 =cut
 666
 667 sub process {
 668     my ( $c, $class, $code ) = @_;
 669     my $status;
 670     eval {
 671         if ( $c->debug )
 672         {
 673             my $action = $c->actions->{reverse}->{"$code"} || "$code";
 674             my $elapsed;
 675             ( $elapsed, $status ) =
 676               $c->benchmark( $code, $class, $c, @{ $c->req->args } );
 677             $c->log->info( sprintf qq/Processing "$action" took %fs/, $elapsed )
 678               if $c->debug;
 679         }
 680         else { $status = &$code( $class, $c, @{ $c->req->args } ) }
 681     };
 682     if ( my $error = $@ ) {
 683         chomp $error;
 684         $error = qq/Caught exception "$error"/;
 685         $c->log->error($error);
 686         $c->errors($error) if $c->debug;
 687         return 0;
 688     }
 689     return $status;
 690 }
 691
 692 =item $c->run
 693
 694 Starts the engine.
 695
 696 =cut
 697
 698 sub run { }
 699
 700 =item $c->request
 701
 702 =item $c->req
 703
 704 Returns a C<Catalyst::Request> object.
 705
 706     my $req = $c->req;
 707
 708 =item $c->response
 709
 710 =item $c->res
 711
 712 Returns a C<Catalyst::Response> object.
 713
 714     my $res = $c->res;
 715
 716 =item $class->setup
 717
 718 Setup.
 719
 720     MyApp->setup;
 721
 722 =cut
 723
 724 sub setup {
 725     my $self = shift;
 726     $self->setup_components;
 727     if ( $self->debug ) {
 728         my $name = $self->config->{name} || 'Application';
 729         $self->log->info("$name powered by Catalyst $Catalyst::VERSION");
 730     }
 731 }
 732
 733 =item $class->setup_components
 734
 735 Setup components.
 736
 737 =cut
 738
 739 sub setup_components {
 740     my $self = shift;
 741
 742     # Components
 743     my $class = ref $self || $self;
 744     eval <<"";
 745         package $class;
 746         import Module::Pluggable::Fast
 747           name   => '_components',
 748           search => [
 749             '$class\::Controller', '$class\::C',
 750             '$class\::Model',      '$class\::M',
 751             '$class\::View',       '$class\::V'
 752           ];
 753
 754     if ( my $error = $@ ) {
 755         chomp $error;
 756         $self->log->error(
 757             qq/Couldn't initialize "Module::Pluggable::Fast", "$error"/);
 758     }
 759     $self->components( {} );
 760     for my $component ( $self->_components($self) ) {
 761         $self->components->{ ref $component } = $component;
 762     }
 763     $self->log->debug( 'Initialized components "'
 764           . join( ' ', keys %{ $self->components } )
 765           . '"' )
 766       if $self->debug;
 767 }
 768
 769 =item $c->stash
 770
 771 Returns a hashref containing all your data.
 772
 773     $c->stash->{foo} ||= 'yada';
 774     print $c->stash->{foo};
 775
 776 =cut
 777
 778 sub stash {
 779     my $self = shift;
 780     if ( $_[0] ) {
 781         my $stash = $_[1] ? {@_} : $_[0];
 782         while ( my ( $key, $val ) = each %$stash ) {
 783             $self->{stash}->{$key} = $val;
 784         }
 785     }
 786     return $self->{stash};
 787 }
 788
 789 sub _prefix {
 790     my ( $class, $name ) = @_;
 791     my $prefix = _class2prefix($class);
 792     $name = "$prefix/$name" if $prefix;
 793     return $name;
 794 }
 795
 796 sub _class2prefix {
 797     my $class = shift || '';
 798     $class =~ /^.*::([MVC]|Model|View|Controller)?::(.*)$/;
 799     my $prefix = lc $2 || '';
 800     $prefix =~ s/\:\:/\//g;
 801     return $prefix;
 802 }
 803
 804 =back
 805
 806 =head1 AUTHOR
 807
 808 Sebastian Riedel, C<sri@cpan.org>
 809
 810 =head1 COPYRIGHT
 811
 812 This program is free software, you can redistribute it and/or modify it under
 813 the same terms as Perl itself.
 814
 815 =cut
 816
 817 1;