File Coverage

blib/lib/Text/CleanFragment.pm

Criterion	Covered	Total	%
statement	30	30	100.0
branch	3	4	75.0
condition			n/a
subroutine	5	5	100.0
pod	2	2	100.0
total	40	41	97.5

package Text::CleanFragment;
use strict;
use Exporter qw'import';
use Text::Unidecode;

our $VERSION = '0.08';
our @EXPORT = (qw(clean_fragment clean_fragment_filename));

=head1 NAME

=encoding utf8

Text::CleanFragment - clean up text to use as URL fragment or filename

=head1 SYNOPSIS

  my $title = "Do p\x{00FC}t  into/URL's?";
  my $id = 42;
  my $url = join "/",
              $id,
              clean_fragment( $title );
  # 42/Do_put_this_into_URLs

=head1 DESCRIPTION

This module downgrades strings of text to match

  /^[-._A-Za-z0-9]*$/

or, to be more exact

  /^([-.A-Za-z0-9]([-._A-Za-z0-9]*[-.A-Za-z0-9])?)?$/

This makes the return values safe to be used as URL fragments
or as file names on many file systems where whitespace
and characters outside of the Latin alphabet are undesired
or problematic.

=head1 FUNCTIONS

=head2 C<< clean_fragment( @fragments ) >>

    my $url_title = join("_", clean_fragment("Ümloud vs. ß",'by',"Grégory"));
    # Umloud_vs._ss_by_Gregory

Returns a cleaned up list of elements. The input elements
are expected to be encoded as Unicode strings. Decode them using
L if you read the fragments as file names from the filesystem.

The operations performed are:

=over 4

=item *

Use L to downgrade the text from Unicode to 7-bit ASCII.

=item *

Eliminate single and double quotes, backquotes and apostrophes.

=item *

Replace all non-letters, non-digits by underscores, including whitespace
and control characters.

=item *

Squash dashes to a single dash

=item *

Squash C<_-_> and C<_-_(-_)+> to -

=item *

Eliminate leading underscores

=item *

Eliminate trailing underscores

=item *

Eliminate underscores before - or .

=back

In scalar context, returns the first element of the cleaned up list.

=cut

sub clean_fragment {
    # make uri-sane filenames
    # We assume Unicode on input.

    # First, downgrade to ASCII chars (or transliterate if possible)
    @_ = unidecode(@_);

    for( @_ ) {
        tr/'"\x{2019}`´//d;   # Eliminate apostrophes and backquotes
        s/[^a-zA-Z0-9.-]+/_/g;  # Replace all non-ascii by underscores, including whitespace
        s/-+/-/g;               # Squash dashes
        s/_+/_/g;               # Squash underscores
        s/_(?:-_)+/-/g;         # Squash _-_ and _-_-_ to -
        s/^[-_]+//;             # Eliminate leading underscores
        s/[-_]+$//;             # Eliminate trailing underscores
        s/_(\W)/$1/;            # No underscore before - or .
    };
    wantarray ? @_ : $_[0];
};

=head2 C<< clean_fragment_filename( @fragments ) >>

  my @parts = clean_fragment_filename( @fragments );

Does the same as C but only removes the following characters,
making the output safe for Unicode-capable filesystems:

  \x{00}-\x{1f}
  / \ * < > : | ?
  ' " ` ´
  \x{2019}

This does not necessarily make the filename safe for blind use in shell
commands, as for example C<;> and C remain in the filenames.

=cut

sub clean_fragment_filename {
    for( @_ ) {
        tr/'"\x{2019}`´//d;   # Eliminate apostrophes and backquotes
        s/[\s\x00-\x1f\/\\\*<>:|\?]+/_/g;  # Replace all non-ascii by underscores, including whitespace
        s/-+/-/g;               # Squash dashes
        s/_+/_/g;               # Squash underscores
        s/_(?:(\p{IsPunctuation})_)+/$1/g;         # Squash _-_ and _-_-_ to -
        s/^[-_]+//;             # Eliminate leading underscores
        s/[-_]+$//;             # Eliminate trailing underscores
        s/_(\W)/$1/;            # No underscore before - or .
    };
    wantarray ? @_ : $_[0];
}

1;

__END__