File Coverage

blib/lib/Text/Stripper.pm

Criterion	Covered	Total	%
statement	47	48	97.9
branch	19	26	73.0
condition			n/a
subroutine	4	4	100.0
pod	0	1	0.0
total	70	79	88.6

package Text::Stripper;

# DOCUMENT:  Text-Stripper, strips of text.
# VERSION:   $Revision: 1.18 $
# DATE:      $Date: 2007-06-14 20:00:01 $
# AUTHOR:    M. Beranek
# COPYRIGHT: M. Beranek

use 5.006001;
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 declaration	use Text::Stripper ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
#our %EXPORT_TAGS = ( 'all' => [ qw(
#	stripof
#) ] );
#
#our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT_OK = qw(
	stripof
	breakpoints
);

#my $cvsRev = '$Revision: 1.18 $';
#$cvsRev =~ s/\$Revision:\s//g;
#$cvsRev =~ s/\s\$//g;

our $VERSION = '1.16';

# Possible breakpoints:
our @breakpoints = ( ' ', '\t', '\.', ',', ';', ':', '!',
	'-', '\?', '\n', '\r', '\/', '\|', '\(', '\)' );

# ----------------------------------------------------------------------
# Shortens text at a possible position.
# $text - text to be shortend
# $len  - minimum length
# $tol  - maximum tolerance
# $max  - 0 = shorten as early as possible | 1 = shorten as late as possible
# $dots - 0 = no dots after shortening | 1 add dots after shortening
# ----------------------------------------------------------------------
sub stripof {

	# Parameter:
	my $text = shift or return;
	my $len  = shift or return $text;
	my $tol  = shift or return substr($text, $len);
	my $max  = shift or 0;
	my $dots = shift or 0;

	# Possible breakpoints:
	#my @breakpoints = ( ' ', '\t', '.', ',', ';', ':', '!', '-', '?', '/', '|', '(', ')' );

	# minimum / maximum length:
	my $maxLen = $len + $tol;
	my $minLen = $len;

	# current length:
	my $textLen = length( $text );

	# if search for latest break:
	if( $max ){
		# stop, if text is shorter than maximum:
		if( $textLen <= $maxLen ){
			return $text;
		}
	}

	# shortest possible text (will be in returned string always):
	my $minText  = substr( $text, 0, $minLen );

	# longest possible text:
	my $maxText  = substr( $text, 0, $maxLen );

	# text between minimum and maximum:
	my $restText = substr( $text, $minLen, $tol );

	# buffer for return-string:
	my $shortText = "";

	# buffer for additional-text:
	my $addText = "";

	# find breakpoint as late as possible:
	if( $max ){

		# we're just working on $resttext:
		$addText = $restText;

		# previously hardcoded regexp:
		# $addText =~ s/(.*)[ ,\t\.;:!-\?\/\|\(\)].+/$1/gi;

		# use regexp to find possible breakpoints. regexps are greedy,
		# so they will find the last possible space:
		my $regexpBreakpoints = join '', @breakpoints;
		# print "X:".$regexpBreakpoints.":X";
		$addText =~ s/(.*)[$regexpBreakpoints].*/$1/g;

		# if no space was found:
		if( $addText eq '' ){
			# return complete text:
			$addText = $restText;
		}
		# return minimum + additional:
		$shortText = "$minText$addText";
	}

	# search for first possible break:
	else {
		# emty additional text:
		$addText = "";

		# find first break:
		# test all characters in the $restText
		for( my $idx = 0; $idx < $tol; $idx ++ ){

			# current character:
			my $char = substr( $restText, $idx, 1 );

			# is character a space?
			my $isSpace = 0;

			# test if character matches on of the
			# space-characters defined in @breakpoints:
			foreach( @breakpoints ){

				# if caharcter matches space:
				if( $char eq $_ ){

					# mark as space, skip rest of @breakpoints:
					$isSpace = 1;
					last;
				}


			}

			# if we didn't find a space:
			if( ! $isSpace ){
				# append the character to the buffer:
				$addText .= $char;
			}
			# if we found a space:
			else {
				# stop here:
				last;
			}

		}
		# return text = minimum-text + additional-text:
		$shortText = "$minText$addText";
	}

	# if we want some dots on the shortened text:
	if( $dots ){
		# only if text is really shorter than the original text:
		if( length($shortText) < length($text) ){
			# append dots:
			$shortText .= "...";
		}
	}

	# return the shortened text:
	return $shortText;

}


1;
__END__