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 => '<a href="%s">%s</a>',
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__
=head1 NAME
HTML::Breadcrumbs - module to produce HTML 'breadcrumb trails'.
=head1 SYNOPSIS
# Procedural interace
use HTML::Breadcrumbs qw(breadcrumbs);
print breadcrumbs(path => '/foo/bar/bog.html');
# prints: Home > Foo > Bar > Bog (the first three as links)
# More complex version - some explicit element labels + extras
print breadcrumbs(
path => '/foo/bar/biff/bog.html',
labels => {
'bog.html' => 'Various Magical Stuff',
'/foo' => 'Foo Foo',
bar => 'Bar Bar',
'/' => 'Start',
},
sep => ' :: ',
format => '<a target="_blank" href="%s">%s</a>',
);
# prints: Start :: Foo Foo :: Bar Bar :: Biff :: Various Magical Stuff
# Object interface
use HTML::Breadcrumbs;
# Create
$bc = HTML::Breadcrumbs->new(
path => $path,
labels => {
'download.html' => 'Download',
foo => 'Bar',
'x.html' => 'The X Files',
},
);
# Render
print $bc->render(sep => ' :: ');
=head1 DESCRIPTION
HTML::Breadcrumbs is a module used to create HTML 'breadcrumb trails'
i.e. an ordered set of html links locating the current page within
a hierarchy.
HTML::Breadcrumbs splits the given path up into a list of elements,
derives labels to use for each of these elements, and then renders this
list as N-1 links using the derived label, with the final element
being just a label.
Both procedural and object-oriented interfaces are provided. The OO
interface is useful if you want to separate object creation and
initialisation from rendering or display, or for subclassing.
Both interfaces allow you to munge the path in various ways (see the
I<roots> and I<indexes> arguments); set labels either explicitly
via a hashref or via a callback subroutine (see I<labels>); and
control the formatting of elements via sprintf patterns or a callback
subroutine (see I<format> and I<format_last>).
=head2 PROCEDURAL INTERFACE
The procedural interface is the breadcrumbs() subroutine (not
exported by default), which uses a named parameter style. Example
usage:
# Procedural interace
use HTML::Breadcrumbs qw(breadcrumbs);
print breadcrumbs(
path => $path,
labels => {
'download.html' => 'Download',
foo => 'Bar',
'x.html' => 'The X Files',
},
sep => ' :: ',
format => '<a class="breadcrumbs" href="%s">%s</a>',
format_last => '<span class="bclast">%s</span>,
);
=head2 OBJECT INTERFACE
The object interface consists of two public methods: the traditional new() for
object creation, and render() to return the formatted breadcrumb trail as a
string (to_string() is an alias for render). Arguments are passed in the same
named parameter style used in the procedural interface. All arguments can be
passed to either method (using new() is preferred, although using render() for
formatting arguments can be a useful convention).
Example usage:
# OO interface
use HTML::Breadcrumbs;
$bc = HTML::Breadcrumbs->new(path => $path);
# Later
print $bc->render(sep => ' :: ');
# OR
$bc = HTML::Breadcrumbs->new(
path => $path,
labels => {
'download.html' => 'Download',
foo => 'Bar',
'x.html' => 'The X Files',
},
sep => ' :: ',
format => '<a class="breadcrumbs" href="%s">%s</a>',
format_last => '<span class="bclast">%s</span>,
);
print $bc->render(); # Same as bc->to_string()
=head2 ARGUMENTS
breadcrumbs() takes the following parameters:
PATH PROCESSING
=over 4
=item *
L<path|path> - the uri-relative path of the item this breadcrumb trail
is for, as found, for example, in $ENV{SCRIPT_NAME}. This should
probably be the I<real> uri-based path to the object, so that the
elements derived from it produce valid links - if you want to munge
the path and the elements from it see the L<roots>, L<omit>, and L<map>
parameters. Default: $ENV{SCRIPT_NAME}.
=item *
L<roots|roots> - an arrayref of uri-relative paths used to identify
the root (the first element) of the breadcrumb trail as something other
than '/'. For example, if the roots arrayref contains '/foo', a path of
/foo/test.html will be split into two elements: /foo and /foo/test.html,
and rendered as "Foo > Test". The default behaviour would be to split
/foo/test.html into three elements: /, /foo, and /foo/test.html, rendered
as "Home > Foo > Test". Default: [ '/' ].
=item *
L<indexes|indexes> - an arrayref of filenames (basenames) to treat
as index pages. Index pages are omitted where they occur as the
last element in the element list, essentially identifying the index
page with its directory e.g. /foo/bar/index.html is treated as
/foo/bar, rendered as "Home > Foo > Bar" with the first two links.
Anything you would add to an apache DirectoryIndex directive should
probably also be included here. Default: [ 'index.html' ].
=item *
L<omit|omit> - a scalar or arrayref of elements to be omitted or
skipped when producing breadcrumbs. Omit arguments should be either
bare element names (i.e. contain no '/' characters, e.g. 'forms') or
full absolute paths (i.e. begin with a '/', e.g. '/cgi-bin/forms') .
For example, if omit includes 'cgi-bin', then a path of
'/cgi-bin/forms/help.html' would be rendered as "Home > Forms > Help"
instead of the default "Home > cgi-bin > Forms > Help". Default: none.
=item *
L<omit_regex|omit_regex> - a scalar or arrayref of regular expressions
used to match elements to be omitted when producing breadcrumbs.
Like 'omit', regexes should match either bare element names (no '/'
characters, e.g. 'forms') or full absolute paths (beginning with '/',
e.g. '/cgi-bin/forms'). WARNING: absolute paths are always explicitly
anchored at both ends (i.e. '/cgi-bin/forms' is used as
m!^/cgi-bin/forms/$!), since otherwise the pattern matches every path
after an initial match.
For example, a path like "/product/12/sample" will be rendered as
"Home > Product > Sample" instead of the default
"Home > Product > 12 > Sample" using any of the following omit_regex
patterns: '\d+', '/product/\d+', '/product/[^/]+', etc. Note that
partial full-path matches like '/product/1' will NOT cause the '12'
element to be omitted, however.
Default: none.
=item *
L<map|map> - a hashref of path mappings used to transform individual
element paths. Map key paths may be either full absolute paths, or
simple path basenames. Elements that match a map key path have their
paths replaced by the map value e.g. a path of /foo/bar/bog.html
with the following map:
map => {
'/' => '/home.html',
'/foo' => '/foo/foo.html',
'bar' => '/foo/bar.html',
},
will render with paths of (non-final labels omitted for clarity):
/home.html > /foo/foo.html > /foo/bar.html > Bog
=back
LABELS
=over 4
=item *
L<labels|labels> - a hashref or a subroutine reference used to derive
the labels of the breadcrumb trail elements. Default: none.
If a hashref, first the fully-qualified element name (e.g. /foo/bar or
/foo/bar/, or /foo/bar/bog.html) and then the element basename
(e.g. 'bar' or 'bog.html') are looked up in the hashref. If found,
the corresponding value is used for the element label.
If this parameter is a subroutine reference, the subroutine is invoked
for each element as:
C<$sub->($elt, $base, $last)>
where $elt is the fully-qualified element (e.g. /foo/bar or
/foo/bar/bog.html), $base is the element basename (e.g. 'bar' or
'bog.html'), and $last is a boolean true iff this is the last element.
The subroutine should return the label to use (return undef or '' to
accept the default).
If no label is found for an element, the default behaviour is to use
the element basename as its label (without any suffix, if the final
element). If the label is lowercase and only \w characters, it will be
ucfirst()-ed.
=back
RENDERING
=over 4
=item *
L<sep|sep> - the separator (scalar) used between breadcrumb elements.
Default: ' > '.
=item *
L<format|format> - a subroutine reference or a (scalar) sprintf pattern
used to format each breadcrumb element except the last (for which, see
L<format_last>).
If a subroutine reference, the subroutine is invoked for each element as:
C<$sub->($elt, $label)>.
where $elt is fully-qualified element (e.g. /foo/bar or /foo/bar/bog.html)
and $label is the label for the element.
If a scalar, it is used as a sprintf format with the fully-qualified
element and the label as arguments i.e. C<sprintf $format, $element,
$label>.
Default: '<a href="%s">%s</a>' i.e. a vanilla HTML link.
=item *
L<format_last|format_last> - a subroutine reference or a (scalar)
sprintf pattern used to format the last breadcrumb element (not a
link).
If a subroutine reference, the subroutine is invoked for the element
the label as only parameter i.e. C<$sub->($label)>.
If a scalar, it is used as a sprintf format with the label as
argument i.e. C<sprintf $format_last, $label>.
Default: '%s' i.e. the label itself.
=back
=head1 AUTHOR
Gavin Carr <gavin@openfusion.com.au>
=head1 COPYRIGHT
Copyright 2002-2005, Gavin Carr. All Rights Reserved.
This program is free software. You may copy or redistribute it under the
same terms as perl itself.
=cut
# arch-tag: 0e040afb-30be-467f-9693-f9e16bbfe20f