The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
package Template::Flute::UriAdjust;

use strict;
use warnings;

use URI;
use URI::Escape;
use URI::Escape (qw/uri_unescape/);

use Moo;

=head1 NAME

Template::Flute::UriAdjust - URI adjust class for Template::Flute

=head1 SYNOPSIS

    $new_path = Template::Flute::UriAdjust->new(
                   uri => 'test',
                   adjust => '/t/',
                );

=head1 DESCRIPTION

Adjusts relative URIs to a base path.

=head1 ATTRIBUTES

=head2 adjust

Base path.

=cut

has adjust => (
    is => 'rw',
    required => 1,
);

=head2 uri

URI to be adjusted.

=cut

has uri => (
    is => 'rw',
    required => 1,
);

=head2 scheme

URI scheme (defaults to C<http>).

=cut

has scheme => (
    is => 'rw',
    default => 'http',
);

=head1 METHODS

=head2 result

Returns new URI if it has adjusted. Otherwise it returns undef.

=cut

sub result {
    my ($self) = @_;
    my $uri = URI->new($self->uri);

    # set scheme if necessary
    if (! $uri->scheme) {
        $uri->scheme($self->scheme);
    }

    my $result = $uri->clone;

    if (! $uri->host) {
        # add prefix to link
        my $adjust = $self->adjust;

        if ($uri->path =~ m%^/%) {
            $adjust =~ s%/$%%;
        }
        elsif ($adjust !~ m%/$%) {
            $adjust .= '/';
        }

        $result->path($adjust . $uri->path);

        # unescape the resulting path
        $result = uri_unescape($result->path);

        if ($uri->fragment) {
            $result .= "#" . uri_unescape($uri->fragment);
        }

        return $result;
    }

    return;
};

=head1 AUTHOR

Stefan Hornburg (Racke), <racke@linuxia.de>

=head1 LICENSE AND COPYRIGHT

Copyright 2014 Stefan Hornburg (Racke) <racke@linuxia.de>.

This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.

See http://dev.perl.org/licenses/ for more information.

=cut

1;