diff options
author | Andreas Mair <amair.sob@googlemail.com> | 2006-02-10 11:07:59 +0100 |
---|---|---|
committer | Andreas Mair <amair.sob@googlemail.com> | 2006-02-10 11:07:59 +0100 |
commit | c908714dd89aad8aac9a01a93bdd44375d6bf69f (patch) | |
tree | cdd478697c50da254b9ea05be4cad9aade756e5b /tools/lib/String/Escape.pm | |
parent | 241fa247256050d545d0d4024f260012c20c498d (diff) | |
download | vdradmin-am-3.4.3rc3.tar.gz vdradmin-am-3.4.3rc3.tar.bz2 |
2006-02-10: 3.4.3rc3v3.4.3rc3
- Changed handling of refering pages; should work much better now.
Diffstat (limited to 'tools/lib/String/Escape.pm')
-rw-r--r-- | tools/lib/String/Escape.pm | 625 |
1 files changed, 0 insertions, 625 deletions
diff --git a/tools/lib/String/Escape.pm b/tools/lib/String/Escape.pm deleted file mode 100644 index 2c40f45..0000000 --- a/tools/lib/String/Escape.pm +++ /dev/null @@ -1,625 +0,0 @@ -### String::Escape - Backslash escaping, word splitting, and elision functions - -### Copyright 2002 Matthew Simon Cavalletto. - # You may use this software under the same terms as Perl. - -######################################################################## - -package String::Escape; - -require 5; -use strict; -use Carp; -use Exporter; - -use vars qw( $VERSION @ISA @EXPORT_OK ); -$VERSION = 2002.001; - -push @ISA, qw( Exporter ); -push @EXPORT_OK, qw( - escape - printable unprintable - elide - quote unquote quote_non_words qprintable unqprintable - string2list string2hash list2string list2hash hash2string hash2list -); - -######################################################################## - -### Call by-name interface - -# %Escapes - escaper function references by name -use vars qw( %Escapes ); -%Escapes = ( - %Escapes, - 'none' => sub ($) { $_[0]; }, - - 'uppercase' => sub ($) { uc $_[0] }, - 'lowercase' => sub ($) { lc $_[0] }, - 'initialcase' => sub ($) { ucfirst lc $_[0] }, - - 'quote' => \"e, - 'unquote' => \&unquote, - 'quote_non_words' => \"e_non_words, - - 'printable' => \&printable, - 'unprintable' => \&unprintable, - - 'qprintable' => 'printable quote_non_words', - 'unqprintable' => 'unquote unprintable', - - 'elide' => \&elide, -); - -# String::Escape::add( $name, $subroutine ); -sub add ($$) { $Escapes{ shift(@_) } = shift(@_); } - -# @defined_names = String::Escape::names(); -sub names () { keys(%Escapes); } - -# $escaped = escape($escape_spec, $value); -# @escaped = escape($escape_spec, @values); -sub escape ($@) { - my ($escape_spec, @values) = @_; - - croak "escape called with multiple values but in scalar context" - if ($#values > 0 && ! wantarray); - - my @escapes = expand_escape_spec($escape_spec); - # warn "Escaping: ". join(' ', @escapes) . "\n"; - my ($value, $escaper); - foreach $value ( @values ) { - foreach $escaper ( @escapes ) { - $value = &$escaper( $value ); - } - } - - return wantarray ? @values : $values[0]; -} - -# @escape_functions = expand_escape_spec($escape_spec); -sub expand_escape_spec { - my $escape_spec = shift; - - if ( ref($escape_spec) eq 'CODE' ) { - return $escape_spec; - } elsif ( ref($escape_spec) eq 'ARRAY' ) { - return map { expand_escape_spec($_) } @$escape_spec; - } elsif ( ! ref($escape_spec) ) { - return map { - expand_escape_spec($_) - } map { - $Escapes{$_} or croak "unsupported escape specification '$_'; " . - "should be one of " . join(', ', names()) - } split(/\s+/, $escape_spec); - } else { - croak "unsupported escape specification '$escape_spec'"; - } -} - -######################################################################## - -### Double Quoting - -# $with_surrounding_quotes = quote( $string_value ); -sub quote ($) { '"' . $_[0] . '"' } - -# $remove_surrounding_quotes = quote( $string_value ); -sub unquote ($) { local $_ = $_[0]; s/\A\"(.*)\"\Z/$1/s; $_; } - -# $word_or_phrase_with_surrounding_quotes = quote( $string_value ); -sub quote_non_words ($) { - ( ! length $_[0] or $_[0] =~ /[^\w\_\-\/\.\:\#]/ ) ? '"'.$_[0].'"' : $_[0] -} - -### Backslash Escaping - -use vars qw( %Printable %Unprintable ); -%Printable = ( ( map { chr($_), unpack('H2', chr($_)) } (0..255) ), - "\\"=>'\\', "\r"=>'r', "\n"=>'n', "\t"=>'t', "\""=>'"' ); -%Unprintable = ( reverse %Printable ); - -# $special_characters_escaped = printable( $source_string ); -sub printable ($) { - local $_ = ( defined $_[0] ? $_[0] : '' ); - s/([\r\n\t\"\\\x00-\x1f\x7F-\xFF])/\\$Printable{$1}/sg; - return $_; -} - -# $original_string = unprintable( $special_characters_escaped ); -sub unprintable ($) { - local $_ = ( defined $_[0] ? $_[0] : '' ); - s/((?:\A|\G|[^\\]))\\([rRnNtT\"\\]|[\da-fA-F]{2})/$1.$Unprintable{lc($2)}/gse; - return $_; -} - -# quoted_and_escaped = qprintable( $source_string ); -sub qprintable ($) { quote_non_words printable $_[0] } - -# $original_string = unqprintable( quoted_and_escaped ); -sub unqprintable ($) { unprintable unquote $_[0] } - -######################################################################## - -### Elision - -use vars qw( $Elipses $DefaultLength $DefaultStrictness ); -$Elipses = '...'; -$DefaultLength = 60; -$DefaultStrictness = 10; - -# $elided_string = elide($string); -# $elided_string = elide($string, $length); -# $elided_string = elide($string, $length, $word_boundary_strictness); - # Return a single-quoted, shortened version of the string, with ellipsis -sub elide ($;$$) { - my $source = shift; - my $length = scalar(@_) ? shift() : $DefaultLength; - my $word_limit = scalar(@_) ? shift() : $DefaultStrictness; - - # If the source is already short, we don't need to do anything - return $source if (length($source) < $length); - - # Leave room for the elipses and make sure we include at least one character. - $length -= length( $Elipses ); - $length = 1 if ( $length < 1 ); - - my $excerpt; - - # Try matching $length characters or less at a word boundary. - $excerpt = ( $source =~ /^(.{0,$length})(?:\s|\Z)/ )[0] if ( $word_limit ); - - # Ignore boundaries if that fails or returns much less than we wanted. - $excerpt = substr($source, 0, $length) if ( ! defined $excerpt or - length($excerpt) < length($source) and - ! length($excerpt) || abs($length - length($excerpt)) > $word_limit); - - return $excerpt . $Elipses; -} - -######################################################################## - -# @words = string2list( $space_separated_phrases ); -sub string2list { - my $text = shift; - - carp "string2list called with a non-text argument, '$text'" if (ref $text); - - my @words; - my $word = ''; - - while ( defined $text and length $text ) { - if ($text =~ s/\A(?: ([^\"\s\\]+) | \\(.) )//mx) { - $word .= $1; - } elsif ($text =~ s/\A"((?:[^\"\\]|\\.)*)"//mx) { - $word .= $1; - } elsif ($text =~ s/\A\s+//m){ - push(@words, unprintable($word)); - $word = ''; - } elsif ($text =~ s/\A"//) { - carp "string2list found an unmatched quote at '$text'"; - return; - } else { - carp "string2list parse exception at '$text'"; - return; - } - } - push(@words, unprintable($word)); - - return @words; -} - -# $space_sparated_string = list2string( @words ); -sub list2string { - join ( ' ', map qprintable($_), @_ ); -} - -# %hash = list2hash( @words ); -sub list2hash { - my @pairs; - foreach (@_) { - my ($key, $val) = m/\A(.*?)(?:\=(.*))?\Z/s; - push @pairs, $key, $val; - } - return @pairs; -} - -# @words = hash2list( %hash ); -sub hash2list { - my @words; - while ( scalar @_ ) { - my ($key, $value) = ( shift, shift ); - push @words, qprintable($key) . '=' . qprintable($value) - } - return @words; -} - -# %hash = string2hash( $string ); -sub string2hash { - return list2hash( string2list( shift ) ); -} - -# $string = hash2string( %hash ); -sub hash2string { - join ( ' ', hash2list( @_ ) ); -} - -######################################################################## - -1; - -__END__ - -=pod - -=head1 NAME - -String::Escape - Registry of string functions, including backslash escapes - - -=head1 SYNOPSIS - - use String::Escape qw( printable unprintable ); - # Convert control, high-bit chars to \n or \xxx escapes - $output = printable($value); - # Convert escape sequences back to original chars - $value = unprintable($input); - - use String::Escape qw( elide ); - # Shorten strings to fit, if necessary - foreach (@_) { print elide( $_, 79 ) . "\n"; } - - use String::Escape qw( string2list list2string ); - # Pack and unpack simple lists by quoting each item - $list = list2string( @list ); - @list = string2list( $list ); - - use String::Escape qw( string2hash hash2string ); - # Pack and unpack simple hashes by quoting each item - $hash = hash2string( %hash ); - %hash = string2hash( $hash ); - - use String::Escape qw( escape ); - # Defer selection of escaping routines until runtime - $escape_name = $use_quotes ? 'qprintable' : 'printable'; - @escaped = escape($escape_name, @values); - - -=head1 DESCRIPTION - -This module provides a flexible calling interface to some frequently-performed string conversion functions, including applying and removing C/Unix-style backslash escapes like \n and \t, wrapping and removing double-quotes, and truncating to fit within a desired length. - -Furthermore, the escape() function provides for dynamic selection of operations by using a package hash variable to map escape specification strings to the functions which implement them. The lookup imposes a bit of a performance penalty, but allows for some useful late-binding behaviour. Compound specifications (ex. 'quoted uppercase') are expanded to a list of functions to be applied in order. Other modules may also register their functions here for later general use. (See the "CALLING BY NAME" section below for more.) - - -=head1 FUNCTION REFERENCE - -=head2 Escaping And Unescaping Functions - -Each of these functions takes a single simple scalar argument and -returns its escaped (or unescaped) equivalent. - -=over 4 - -=item quote($value) : $escaped - -Add double quote characters to each end of the string. - -=item quote_non_words($value) : $escaped - -As above, but only quotes empty, punctuated, and multiword values; simple values consisting of alphanumerics without special characters are not quoted. - -=item unquote($value) : $escaped - -If the string both begins and ends with double quote characters, they are removed, otherwise the string is returned unchanged. - -=item printable($value) : $escaped - -=item unprintable($value) : $escaped - -These functions convert return, newline, tab, backslash and unprintable -characters to their backslash-escaped equivalents and back again. - -=item qprintable($value) : $escaped - -=item unqprintable($value) : $escaped - -The qprintable function applies printable escaping and then wraps the results -with quote_non_words, while unqprintable applies unquote and then unprintable. -(Note that this is I<not> MIME quoted-printable encoding.) - -=back - -=head2 Simple Arrays and Hashes - -=over 4 - -=item @words = string2list( $space_separated_phrases ); - -Converts a space separated string of words and quoted phrases to an array; - -=item $space_sparated_string = list2string( @words ); - -Joins an array of strings into a space separated string of words and quoted phrases; - -=item %hash = string2hash( $string ); - -Converts a space separated string of equal-sign-associated key=value pairs into a simple hash. - -=item $string = hash2string( %hash ); - -Converts a simple hash into a space separated string of equal-sign-associated key=value pairs. - -=item %hash = list2hash( @words ); - -Converts an array of equal-sign-associated key=value strings into a simple hash. - -=item @words = hash2list( %hash ); - -Converts a hash to an array of equal-sign-associated key=value strings. - -=back - -=head2 String Elision Function - -This function extracts the leading portion of a provided string and appends ellipsis if it's longer than the desired maximum excerpt length. - -=over 4 - -=item elide($string) : $elided_string - -=item elide($string, $length) : $elided_string - -=item elide($string, $length, $word_boundary_strictness) : $elided_string - -If the original string is shorter than $length, it is returned unchanged. At most $length characters are returned; if called with a single argument, $length defaults to $DefaultLength. - -Up to $word_boundary_strictness additional characters may be ommited in order to make the elided portion end on a word boundary; you can pass 0 to ignore word boundaries. If not provided, $word_boundary_strictness defaults to $DefaultStrictness. - -=item $Elipses - -The string of characters used to indicate the end of the excerpt. Initialized to '...'. - -=item $DefaultLength - -The default target excerpt length, used when the elide function is called with a single argument. Initialized to 60. - -=item $DefaultStrictness - -The default word-boundary flexibility, used when the elide function is called without the third argument. Initialized to 10. - -=back - -=head1 CALLING BY NAME - -These functions provide for the registration of string-escape specification -names and corresponding functions, and then allow the invocation of one or -several of these functions on one or several source string values. - -=over 4 - -=item escape($escapes, $value) : $escaped_value - -=item escape($escapes, @values) : @escaped_values - -Returns an altered copy of the provided values by looking up the escapes string in a registry of string-modification functions. - -If called in a scalar context, operates on the single value passed in; if -called in a list contact, operates identically on each of the provided values. - -Valid escape specifications are: - -=over 4 - -=item one of the keys defined in %Escapes - -The coresponding specification will be looked up and used. - -=item a sequence of names separated by whitespace, - -Each name will be looked up, and each of the associated functions will be applied successively, from left to right. - -=item a reference to a function - -The provided function will be called on with each value in turn. - -=item a reference to an array - -Each item in the array will be expanded as provided above. - -=back - -A fatal error will be generated if you pass an unsupported escape specification, or if the function is called with multiple values in a scalar context. - -=item String::Escape::names() : @defined_escapes - -Returns a list of defined escape specification strings. - -=item String::Escape::add( $escape_name, \&escape_function ); - -Add a new escape specification and corresponding function. - -=item %Escapes : $name, $operation, ... - -By default, the %Escapes hash is initialized to contain the following mappings: - -=over 4 - -=item quote, unquote, or quote_non_words - -=item printable, unprintable, qprintable, or unqprintable, - -=item elide - -Run the above-described functions of the same names. - -=item uppercase, lowercase, or initialcase - -Alters the case of letters in the string to upper or lower case, or for initialcase, sets the first letter to upper case and all others to lower. - -=item none - -Return an unchanged copy of the original value. - -=back - -=back - - -=head1 EXAMPLES - -Here are a few example uses of these functions, along with their output. - -=head2 Backslash Escaping - -C<print printable( "\tNow is the time\nfor all good folks\n" );> - - \tNow is the time\nfor all good folks\n - -C<print unprintable( '\\tNow is the time\\nfor all good folks\\n' );> - - Now is the time - for all good folks - - - -=head2 Escape By Name - -C<print escape('qprintable', "\tNow is the time\nfor all good folks\n" );> - - "\tNow is the time\nfor all good folks\n" - -C<print escape('uppercase qprintable', "\tNow is the time\nfor all good folks\n" );> - - "\tNOW IS THE TIME\nFOR ALL GOOD FOLKS\n" - - -C<print join '--', escape('printable', "\tNow is the time\n", "for all good folks\n" );> - - \tNow is the time\n--for all good folks\n - - -=head2 String Elision Function - -C<$string = 'foo bar baz this that the other';> - -C<print elide( $string, 100 );> - - foo bar baz this that the other - - -C<print elide( $string, 12 );> - - foo bar... - - -C<print elide( $string, 12, 0 );> - - foo bar b... - - -=head2 Simple Arrays and Hashes - -C<print list2string('hello', 'I move next march');> - - hello "I move next march" - - -C<@list = string2list('one "second item" 3 "four\nlines\nof\ntext"');> - -C<print $list[1];> - - second item - - -C<print hash2string( 'foo' =E<gt> 'Animal Cities', 'bar' =E<gt> 'Cheap' );> - - foo="Animal Cities" bar=Cheap - - -C<%hash = string2hash('key=value "undefined key" words="the cat in the hat"');> - -C<print $hash{'words'};> - - the cat in the hat - -C<print exists $hash{'undefined_key'} and ! defined $hash{'undefined_key'};> - - 1 - - -=head1 PREREQUISITES AND INSTALLATION - -This package should run on any standard Perl 5 installation. - -To install this package, download and unpack the distribution archive from -http://www.evoscript.com/dist/ or your favorite CPAN mirror, and execute -the standard "perl Makefile.PL", "make test", "make install" sequence. - - -=head1 STATUS AND SUPPORT - -This release of String::Escape is intended for public review and feedback. -It has been tested in several environments and no major problems have been -discovered, but it should be considered "beta" pending that feedback. - - Name DSLI Description - -------------- ---- --------------------------------------------- - String:: - ::Escape bdpf Registry of useful string escaping functions - -Further information and support for this module is available at E<lt>www.evoscript.orgE<gt>. - -Please report bugs or other problems to C<E<lt>simonm@cavalletto.orgE<gt>>. - -The following changes are in progress or under consideration: - -=over 4 - -=item * - -Use word-boundary test in elide's regular expression rather than \s|\Z. - -=item * - -Check for possible problems in the use of printable escaping functions and list2hash. For example, are the encoded strings for hashes with high-bit characters in their keys properly unquoted and unescaped? - -=item * - -Update string2list; among other things, embedded quotes (eg: a@"!a) shouldn't cause phrase breaks. - -=back - - -=head1 SEE ALSO - -Numerous modules provide collections of string manipulation functions; see L<String::Edit> for an example. - -The string2list function is similar to to the quotewords function in the standard distribution; see L<Text::ParseWords>. - -Use other packages to stringify more complex data structures; see L<Data::PropertyList>, L<Data::Dumper>, or other similar package. - - -=head1 CREDITS AND COPYRIGHT - -=head2 Developed By - - M. Simon Cavalletto, simonm@cavalletto.org - Evolution Softworks, www.evoscript.org - -=head2 Contributors - - Eleanor J. Evans piglet@piglet.org - Jeremy G. Bishop - -=head2 Copyright - -Copyright 2002 Matthew Simon Cavalletto. - -Portions copyright 1996, 1997, 1998, 2001 Evolution Online Systems, Inc. - -=head2 License - -You may use, modify, and distribute this software under the same terms as Perl. - -=cut |