package CGI::Prototype::PathInfo;
use strict;

use base qw( CGI::Prototype::Hidden );

=head1 NAME

CGI::Prototype::PathInfo -- Create a CGI application by subclassing -- path info

=head1 SYNOPSIS

  # in My/App.pm
  package My::App;
  use base qw( CGI::Prototype::PathInfo );

  # in /some/cgi-bin/myapp
  use lib qw( /location );
  use My::App;
  My::App->activate;

=head1 DESCRIPTION

L<CGI::Prototype::PathInfo> extends L<CGI::Prototype::Hidden> and replaces the
hidden field mechanism for state and dispatching with ones based on path info.
In other words, it works just like L<CGI::Prototype::Hidden>, except for when
it does not.

=head2 CONFIGURATION SLOTS

There are few things that work differently from L<CGI::Prototype::Hidden> here.

=over 4

=item config_state_param

This is now just a vestige from L<CGI::Prototype::Hidden>. Setting it won't
have any effect.

=item config_valid_pages

A list of valid page names. By default just C<welcome>.

=cut

sub config_valid_pages { qw( welcome ) }

=item config_default_page

The initial page, if the state is missing. Defaults to the first value from
C<config_valid_pages>.

=cut

sub config_default_page { ( shift->config_valid_pages )[ 0 ] }

=back

=head2 ENVIRONMENT INFORMATION SLOTS

=over 4

=item resource_type

FIXME

=item resource_id

FIXME

=back

=cut

sub prototype_enter {
	my $self = shift;

	$self->SUPER::prototype_enter();

	my ( $resource, $id ) = $self->parse_path( $self->CGI->path_info() );
	$self->reflect->addSlot( resource_type => $resource, resource_id => $id );
}

=head2 MANAGEMENT SLOTS

This is where the real changes over L<CGI::Prototype::Hidden> lie.

=over 4

=item name_to_page

Called with a page name, translates it to a package name, and returns a page
object. Will also autoload the package.

This module expects page names to look like relative URLs and will translate to
package names like you'd expect, ie assuming the default
C<config_class_prefix>, C<foo/bar> will translate to C<My::App::foo::bar>.

=cut

sub name_to_page {
	my $self = shift;
	my ( $name ) = @_;

	my $pkg = join '::', (
		$self->config_class_prefix,
		split( m{/}, $self->validate_name( $name ) ),
	);

	if( do { no strict 'refs'; not defined ${ $pkg . '::' } } ) {
		eval "require $pkg";
		die $@ if $@;
	}

	return $pkg->reflect->object;
}

=item dispatch

Overridden from L<CGI::Prototype::Hidden>. Selects either the page named
corresponding to the given resource type or the default page, and returns
the page object.

=cut

sub dispatch {
	my $self = shift;

	my $prefixes = join '|', map quotemeta, $self->config_valid_pages;

	return $self->name_to_page( $self->resource_type || $self->config_default_page );
}

=item render_enter

Overridden from L<CGI::Prototype::Hidden> to not force the hidden state param.

=cut

sub render_enter {
	my $self = shift;
	$self->render_enter_per_page;
}

=item validate_name

Called with a page name, validates it by checking it against the
C<config_valid_pages> list. Returns the default page name if the given name is
not valid.

=cut

sub validate_name {
	my $self = shift;
	my ( $name ) = @_;
	my ( $valid_name ) = (
		grep( $name eq $_, $self->config_valid_pages ),
		$self->config_default_page,
	);
	return $valid_name;
}

=item parse_path

Called with a relative URL path such as that returned by C<CGI::path_info>,
parses the string into a page name from the C<config_valid_pages> list and an
additional resource identifier.

That is, if the application is called as

	http://example.org/myapp.cgi/thread/13712

and C<thread> is a valid page name, it returns C<( 'thread', '13712' )>.

=cut

sub parse_path {
	my $self = shift;
	my ( $path ) = @_;
	my $prefixes = join '|', map quotemeta, $self->config_valid_pages;
	return $path =~ m{ \A /* ($prefixes) (?: / (.*) )? \z }msx;
}

=back

=head1 SEE ALSO

L<CGI::Prototype::Hidden>, L<CGI::Prototype>, L<Template::Manual>

=head1 BUG REPORTS

Please report any bugs or feature requests to
L<mailto:bug-cgi-prototype-pathinfo@rt.cpan.org>, or through the web interface
at L<http://rt.cpan.org/>. I will be notified, and then you'll automatically
be notified of progress on your bug as I make changes.

=head1 AUTHOR

Aristote Pagaltzis, L<mailto:pagaltzis@gmx.de>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2005 by Aristotle Pagaltzis

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.5 or,
at your option, any later version of Perl 5 you may have available.

=cut

1;