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