File Coverage

blib/lib/String/Dirify.pm

Criterion	Covered	Total	%
statement	32	32	100.0
branch	10	12	83.3
condition	3	3	100.0
subroutine	7	7	100.0
pod	0	5	0.0
total	52	59	88.1

package String::Dirify;

use strict;
use warnings;

require Exporter;

our @ISA = qw(Exporter);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows the declaration	use String::Dirify ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = ( 'all' => [ qw(
	dirify
) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw(

);

our $VERSION = '1.02';

# ------------------------------------------------

my(%high_ASCII_char) =
(
    "\xc0" => 'A',  # A`
    "\xe0" => 'a',  # a`
    "\xc1" => 'A',  # A'
    "\xe1" => 'a',  # a'
    "\xc2" => 'A',  # A^
    "\xe2" => 'a',  # a^
    "\xc4" => 'A',  # A:
    "\xe4" => 'a',  # a:
    "\xc5" => 'A',  # Aring
    "\xe5" => 'a',  # aring
    "\xc6" => 'AE', # AE
    "\xe6" => 'ae', # ae
    "\xc3" => 'A',  # A~
    "\xe3" => 'a',  # a~
    "\xc8" => 'E',  # E`
    "\xe8" => 'e',  # e`
    "\xc9" => 'E',  # E'
    "\xe9" => 'e',  # e'
    "\xca" => 'E',  # E^
    "\xea" => 'e',  # e^
    "\xcb" => 'E',  # E:
    "\xeb" => 'e',  # e:
    "\xcc" => 'I',  # I`
    "\xec" => 'i',  # i`
    "\xcd" => 'I',  # I'
    "\xed" => 'i',  # i'
    "\xce" => 'I',  # I^
    "\xee" => 'i',  # i^
    "\xcf" => 'I',  # I:
    "\xef" => 'i',  # i:
    "\xd2" => 'O',  # O`
    "\xf2" => 'o',  # o`
    "\xd3" => 'O',  # O'
    "\xf3" => 'o',  # o'
    "\xd4" => 'O',  # O^
    "\xf4" => 'o',  # o^
    "\xd6" => 'O',  # O:
    "\xf6" => 'o',  # o:
    "\xd5" => 'O',  # O~
    "\xf5" => 'o',  # o~
    "\xd8" => 'O',  # O/
    "\xf8" => 'o',  # o/
    "\xd9" => 'U',  # U`
    "\xf9" => 'u',  # u`
    "\xda" => 'U',  # U'
    "\xfa" => 'u',  # u'
    "\xdb" => 'U',  # U^
    "\xfb" => 'u',  # u^
    "\xdc" => 'U',  # U:
    "\xfc" => 'u',  # u:
    "\xc7" => 'C',  # ,C
    "\xe7" => 'c',  # ,c
    "\xd1" => 'N',  # N~
    "\xf1" => 'n',  # n~
    "\xdd" => 'Y',  # Yacute
    "\xfd" => 'y',  # yacute
    "\xdf" => 'ss', # szlig
    "\xff" => 'y'   # yuml
);

my($high_ASCII_re) = join '|', keys %high_ASCII_char;

# ------------------------------------------------

sub convert_high_ascii
{
	# require MT::I18N;
	# MT::I18N::convert_high_ascii(@_);

	my($self, $s) = @_;
	$s            =~ s/($high_ASCII_re)/$high_ASCII_char{$1}/g;

	return $s;

} # End of convert_high_ascii.

# ------------------------------------------------
# Re-use just the parts we need of Movable Type's 'dirify' function.
# The purpose is to take any string and make it a valid directory name.

sub dirify
{
	# ($MT::VERSION && MT->instance->{cfg}->PublishCharset =~ m/utf-?8/i)
	# ? utf8_dirify(@_) : iso_dirify(@_);

	my($self);

	if (ref $_[0]) # Handle calls like $o = String::Dirify -> new(); $d = $o -> dirify($s).
	{
		$self = shift;
	}
	elsif ($_[0] eq __PACKAGE__) # Handle calls like $d = String::Dirify -> dirify($s).
	{
		$self = new(shift @_);
	}
	else # Handle calls like $d = dirify($s).
	{
		$self = new(__PACKAGE__);
	}

	return $self -> iso_dirify(@_);

} # End of dirify.

# ------------------------------------------------

sub iso_dirify
{
	my($self, $s, $sep) = @_;

    return '' if (! defined $s);

    $sep = defined($sep) && ($sep ne '1') ? $sep : '_';
	$s   = $self -> convert_high_ascii($s); # Convert high-ASCII chars to 7-bit.
	$s   = $self -> remove_html(lc $s);     # Lower case, and remove HTML tags.
	$s   =~ s!&[^;\s]+;!!gs;                # Remove HTML entities.
	$s   =~ s![^\w\s-]!!gs;                 # Remove non-word/space chars.
	$s   =~ s!\s+!$sep!gs;                  # Change runs of spaces to the separator char.

	return $s;

} # End of iso_dirify.

# ------------------------------------------------

sub new
{
	my($class) = @_;

	return bless {}, $class;

} # End of new.

# ------------------------------------------------

sub remove_html
{
	my($self, $text) = @_;

	return $text if (! defined $text);          # Suppress warnings.
	return $text if $text =~ m/^<\!\[CDATA\[/i; # We need /i because lc() has been called.

	$text =~ s!<[^>]+>!!gs; # Remove all '<'s which have matching '>'s.
	$text =~ s!

	return $text;

} # End of remove_html.

# ------------------------------------------------

1;

__END__