File Coverage

blib/lib/HTML/Breadcrumbs.pm

Criterion	Covered	Total	%
statement	172	178	96.6
branch	83	92	90.2
condition	41	53	77.3
subroutine	20	20	100.0
pod	0	4	0.0
total	316	347	91.0

package HTML::Breadcrumbs;

use 5.000;
use File::Basename;
use Carp;
use strict;
require Exporter;

use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
$VERSION = '0.7';
@ISA = qw(Exporter);
@EXPORT = ();
@EXPORT_OK = qw(breadcrumbs);

my @ARG = qw(path roots indexes omit omit_regex map labels sep format format_last extra);

#
# Initialise
#
sub _init
{
    my $self = shift;
    # Argument defaults
    my %arg = (
        path => $ENV{SCRIPT_NAME},
        roots => [ '/' ],
        indexes => [ 'index.html' ],
        sep => ' > ',
        format => '%s',
        format_last => '%s',
        @_,
    );

    # Check for invalid args
    my %ARG = map { $_ => 1 } @ARG;
    my @bad = grep { ! exists $ARG{$_} } keys %arg;
    croak "[Breadcrumbs::_init] invalid argument(s): " . join(',',@bad) if @bad;
    croak "[Breadcrumbs::_init] 'path' argument must be absolute"
        if $self->{path} && substr($self->{path},0,1) ne '/';

    # Add arguments to $self
    @$self{ @ARG } = @arg{ @ARG };

    return $self;
}

sub new
{
    my $class = shift;
    my $self = {};
    bless $self, $class;
    return $self->_init(@_);
}

# Identify the root element
sub _setup_root
{
    my $self = shift;

    $self->{roots} = [ $self->{roots} ] if $self->{roots} && ! ref $self->{roots};
    my $root = '/';
    for my $r (sort { length($b) <=> length($a) } @{$self->{roots}}) {
        if ($self->{path} =~ m/^$r\b/) {
            $root = $r;
            $root .= '/' if substr($root,-1) ne '/';
            last;
        }
    }
    push @{$self->{elt}}, $root;
    $self->{root} = $root;
}

# Setup omit stuff (omit hash, omit_regex arrayrefs)
sub _setup_omit
{
    my $self = shift;

    $self->{omit_elt} = {};
    $self->{omit_regex_elt} = [];
    $self->{omit_regex_path} = [];

    $self->{omit} = [ $self->{omit} ]
        if $self->{omit} && ! ref $self->{omit};
    # Create a hash from omit elements
    if ($self->{omit} && ref $self->{omit} eq 'ARRAY') {
        for (@{$self->{omit}}) {
            # Omit elements should be either absolute paths or element basenames
            if (substr($_,0,1) eq '/') {
                # Remove any trailing '/'
                $_ = substr($_, 0, -1)  if substr($_,-1) eq '/';
            } elsif (m!/!) {
                warn "omit arguments must be either absolute paths or simple path basenames - skipping $_";
                next;
            }
            $self->{omit_elt}->{$_} = 1;
        }
    }
    my $omit_regex = $self->{omit_regex} || [];
    $omit_regex = [ $omit_regex ] unless ref $omit_regex eq 'ARRAY';
    # Create seperate full-path and element omit_regex arrays
    for my $o (@$omit_regex) {
        if ($o =~ m!/!) {
            $o =~ s!^\^!!;
            $o =~ s!/*(\$)?$!!;  #!
            push @{$self->{omit_regex_path}}, qq(^$o\$);
        }
        else {
            push @{$self->{omit_regex_elt}}, $o;
        }
    }
}

# Add path elements to elt array
sub _add_elements
{
    my $self = shift;
    my $current = $self->{root};
    while ($self->{path} =~ m|^\Q$current\E/*(([^/]+)/?)|) {
        my $final = $2;
        $current .= $1;
        # Remove any trailing '/' from current for testing
        my $current_test = $current;
        $current_test = substr($current_test, 0, -1) if substr($current_test, -1) eq '/';
        # Ignore elements explicitly omitted
        next if $self->{omit_elt}->{$current_test} || $self->{omit_elt}->{$final};
        # Ignore elements matching omit_regex_elt patterns
        next if grep { $final =~ m/$_/ } @{$self->{omit_regex_elt}};
        # Ignore paths matching omit_regex_path patterns
        next if grep { $current_test =~ m/$_/ } @{$self->{omit_regex_path}};
        # Otherwise add to elt array
        push @{$self->{elt}}, $current;
    }
}

# Apply element mappings
sub _map_elements
{
    my $self = shift;
    die "invalid map argument" if ref $self->{map} ne 'HASH';

    $self->{elt_map} = {};
    ELT:
    for my $elt (@{$self->{elt}}) {
        for my $key (sort keys %{$self->{map}}) {
            # Map elements must be either absolute paths or element basenames
            my $key2 = $key;
            if (substr($key2,0,1) eq '/') {
                # Absolute paths must end in '/'
                $key2 .= '/' unless substr($key2,-1) eq '/';
            } elsif ($key2 =~ m!/!) {
                warn "map arguments must be either absolute paths or simple path basenames - skipping $key2";
                next;
            }

            # If the map key matches this element, record map value in elt_map
            my $match = ($key2 =~ m!/!) ? $elt eq $key2 : $elt =~ m,/\Q$key2\E/$,;
            if ($match) {
                $self->{elt_map}->{$elt} = $self->{map}->{$key};
                next ELT;
            }
        }
    }
}

# Check the final element for indexes
sub _check_final_index_element
{
    my $self = shift;

    $self->{indexes} = [ $self->{indexes} ]
        if $self->{indexes} && ! ref $self->{indexes};
    if (ref $self->{indexes} eq 'ARRAY') {
        # Convert indexes to hash
        my %indexes = map { $_ => 1 } @{$self->{indexes}};
        # Check final element
        my $final = basename($self->{elt}->[ $#{$self->{elt}} ]);
        if ($indexes{$final}) {
            pop @{$self->{elt}};
        }
    }
}

#
# Split the path into elements (stored in $self->{elt} arrayref)
#
sub _split
{
    my $self = shift;
    $self->{elt} = [];

    # Identify the root
    $self->_setup_root;

    # Setup omit stuff
    $self->_setup_omit;

    # Add path elements to elt array
    $self->_add_elements;

    # Apply element mappings
    $self->_map_elements if $self->{'map'};

    # Check for final index elements
    $self->_check_final_index_element;

}

#
# Generate a default label for $elt
#
sub _label_default
{
    my $self = shift;
    my ($elt, $last, $extra) = @_;
    my $label = '';

    if ($elt eq '/' || $elt eq '') {
        $label = 'Home';
    }
    else {
        $elt = substr($elt,0,-1) if substr($elt,-1) eq '/';
        $label = basename($elt);
        $label =~ s/\.[^.]*$// if $last;
        $label = ucfirst($label) if lc($label) eq $label && $label =~ m/^\w+$/;
    }

    return $label;
}

#
# Return a label for the given element
#
sub _label
{
    my $self = shift;
    my ($elt, $last, $extra) = @_;
    my $label = '';

    # Check $self->{labels}
    if (ref $self->{labels} eq 'CODE') {
        $elt = substr($elt,0,-1) if substr($elt,-1) eq '/' && $elt ne '/';
        $label = $self->{labels}->($elt, basename($elt), $last, $extra);
    }
    elsif (ref $self->{labels} eq 'HASH') {
        $elt = substr($elt,0,-1) if substr($elt,-1) eq '/' && $elt ne '/';
        $label ||= $self->{labels}->{$elt};
        $label ||= $self->{labels}->{$elt . '/'} unless $elt eq '/' || $last;
        $label ||= $self->{labels}->{basename($elt)};
    }

    # Else use defaults
    $label ||= $self->_label_default($elt, $last, $extra);

    return $label;
}

#
# Render the elt path for URI use, and lookup in elt_map if applicable
#
sub _uri_elt
{
    my $self = shift;
    local $_ = shift;
    $_ = $self->{elt_map}->{$_} if exists $self->{elt_map}->{$_};
    # URI escape - should maybe use URI::Escape here instead
    s/ /%20/g;
    return $_;
}

#
# HTML-format the breadcrumbs
#
sub _format
{
    my $self = shift;

    my $out;
    for (my $i = 0; $i <= $#{$self->{elt}}; $i++) {

        # Format breadcrumb links
        if ($i != $#{$self->{elt}}) {
            # Generate label
            my $label = $self->_label($self->{elt}->[$i], undef, $self->{extra});

            # $self->{format} coderef
            if (ref $self->{format} eq 'CODE') {
                $out .= $self->{format}->($self->_uri_elt($self->{elt}->[$i]),
                    $label, $self->{extra});
            }
            # $self->{format} sprintf pattern
            elsif ($self->{format} && ! ref $self->{format}) {
                $out .= sprintf $self->{format}, $self->_uri_elt($self->{elt}->[$i]),
                    $label;
            }
            # Else croak
            else {
                croak "[Breadcrumbs::format] invalid format $self->{format}";
            }

            # Separator
            $out .= $self->{sep};
        }

        # Format final element breadcrumb label
        else {
            # Generate label
            my $label = $self->_label($self->{elt}->[$i], 'last', $self->{extra});

            # $self->{format_last} coderef
            if (ref $self->{format_last} eq 'CODE') {
                $out .= $self->{format_last}->($label, $self->{extra});
            }
            # $self->{format_last} sprintf pattern
            elsif ($self->{format_last} && ! ref $self->{format_last}) {
                $out .= sprintf $self->{format_last}, $label;
            }
            # Else croak
            else {
                croak "[Breadcrumbs::format] invalid format_last $self->{format_last}";
            }
        }
    }

    return $out;
}

#
# The real work - process and render the given path
#
sub render
{
    my $self = shift;
    my %arg = @_;

    # Check for invalid args
    my %ARG = map { $_ => 1 } @ARG;
    my @bad = grep { ! exists $ARG{$_} } keys %arg;
    croak "[Breadcrumbs::render] invalid argument(s): " . join(',',@bad) if @bad;

    # Add args to $self
    for (@ARG) {
        $self->{$_} = $arg{$_} if defined $arg{$_};
    }

    # Croak if no path
    croak "[Breadcrumbs::render] no valid 'path' found" if ! $self->{path};
    croak "[Breadcrumbs::render] 'path' argument must be absolute"
        if substr($self->{path},0,1) ne '/';

    # Split the path into elements
    $self->_split();

    # Format
    return $self->_format();
}

#
# Alias for render
#
sub to_string
{
    my $self = shift;
    $self->render(@_);
}

#
# Procedural interface
#
sub breadcrumbs
{
    my $bc = HTML::Breadcrumbs->new(@_);
    croak "[breadcrumbs] object creation failed!" if ! ref $bc;
    return $bc->render();
}

1;

__END__