String-Rexx
view release on metacpan or search on metacpan
lib/String/Rexx.pm view on Meta::CPAN
package String::Rexx;
use 5.006;
use strict;
use warnings;
use Carp;
use Params::Validate ':all' ;
use Regexp::Common;
use base 'Exporter';
#use AutoLoader qw(AUTOLOAD);
our %EXPORT_TAGS = ( 'all' => [ qw(
centre center changestr compare copies countstr
delstr delword datatype d2c b2d d2x
x2b b2x x2c x2d c2x
d2b errortext insert lastpos left Length
overlay Pos right Reverse Abbrev sign
space Substr strip subword translate verify
word wordindex wordlength wordpos words xrange
) ] );
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
our $VERSION = '0.08';
use constant BINARY => qr/^[01]{0,32}$/;
use constant REAL => $RE{num}{real};
use constant HEX8 => qr/^(?:0x)?[\dabcdef]{0,8}$/i ;
use constant HEX => qr/^(?:0x)?[\dabcdef]*$/ ;
use constant NONNEGATIVE => qr/^[+]?[\d]+$/;
use constant POSITIVE => qr/^[+]?[1-9]+$/;
1;
=pod
=head1 NAME
String::Rexx - Perl implementation of Rexx string functions
=head1 SYNOPSIS
use String::Rexx qw( :all );
use String::Rexx qw( functions... );
=head1 DESCRIPTION
This module implements almost all string functions
of regina2-rexx .
=over
=item Abbrev( 'long', 'short' [, len] )
Return 1 if string $short is a shortcut for string $long. And optionally, $len
must not be greater than what the number of charecters matched with string $shoft.
Otherwise, return 0.
=item countstr( 'pat', 'string' )
Counts the number of occurences of 'pat' within 'string'
=item center( 'string' , len [, char ] )
Returns a string of length len, with the proper padding so that 'string' is centered
=item changestr( 'old', 'string' , 'new' )
Changes all instances of substing 'old' inside 'string' to the new string 'new'
=item compare( 'string1' , 'string2' [, char ] )
Returns 0 when both strings are equal, or N when they are not.
lib/String/Rexx.pm view on Meta::CPAN
If the comparison fails, and the string contents are unequal, it will
return N, the size of either string since by now hey both have the same length.
The default pad character is space , ' ' .
=item copies( 'string' , N )
Returns a string consisting of N concatenated copies. N = 0, 1, 2, ...
=item delstr( 'string' , start [,length] )
Deletes the substring which starts at $start.
Length defaults to the rest of string.
=item delword( 'string' , start [,length] )
Deletes $length words, starting from $start.
Length defaults to the rest of string.
=item errortext( N )
Returns the error string that describes the error number N .
=item datatype( 'string' [, option ] )
When 'string' represents a number or a non-number literal, this fuction
returns 'NUM' or 'LIT', respectively.
Option can be either 'NUM' or 'LIT'; when specified, the fuction returns 1 (true) or
0 (false) depending whether 'string' is a NUM or a LIT .
If the user-supplied option is neither NUM or LOT, the return value is set to undef ;
=item d2c( N )
Same as chr(N) . Converts decimal N to its char in the character set.
=item d2x( N [, length] )
Converts decimal N to a hex string of size $lenght .
=item insert( 'source' , 'target' [,'position' ] [,'length'] [, char ] )
Inserts string 'source' into string 'targer'.
Position defaults to 0, length defaults to len of $source , and
padding char defaults to ' ' .
=item lastpos( 'needle' , 'haystack', [, start ] )
Returns the position of $needle in $haystack (searching from the end) .
Returns 0 if not found, and 1 when neelde occurs at start of haystack
=item left( 'string' , length, [, 'char'] )
Returns the leftmost $length chars. If there are not
enough characters, the string is padded (prepended) with char characters.
Char defaults to space.
=item Length( 'string' )
Returns the length of string.
=item overlay( 'source', 'target' [, start] [, length] [, pad] )
Overstrikes the $target string, with $source .
=item Reverse( 'string' )
Reverses the order of characters in string.
=item Pos( 'needle' , 'haystack', [, start ] )
Returns the position of $needle in $haystack .
Returns 0 if not found, and 1 when neelde occurs at start of haystack
=item right( 'string' , length, [, 'char'] )
Returns the $length chars from the end of string. If there are not
enough characters, the string is padded (prepended) with char characters.
Char defaults to space.
=item space( 'string' [, 'length'] [, 'char'] )
After removing leading and trailing spaces, internal whitespace
change to $length chars. Char defaults to ' ' , and length defaults to 1 .
=item strip( 'string' [, 'Option'] [, 'char'] )
Strips leading whitespace from string.
The optional 2nd param can be set to 'leading', 'trailing', or 'both' .
The optional 3rd param will strip chars instead of whitespace.
Returns the striped string.
=item Substr( 'string', start, [, length ] [, padchar ] )
Returns a substring of string. If string does not have enough chars
to fill the request, we use padding with character padchar .
=item wordindex( 'string', N )
Returns the index in the string for the Nth word.
=item wordlength( 'string', N )
Returns the length of the Nth word in the string. Where N=1,2,...
Returns 0 if there are less worlds than N .
Raises exception if is N < 1
=item subword( 'string', start [, N ] )
Returns a string of words staring from start. N denotes how many
words to return (default is as many as possible.)
start = N = 1,2,...
=item translate( 'string' [, 'new' , 'old' [, pad] ] )
The translitaration oparator. It returns a strings where all characters
in 'old' and transformed to the corresponding characters in 'new' .
In the special case when all options are absent, it translates $string
to upper case.
lib/String/Rexx.pm view on Meta::CPAN
}
sub delstr ($$;$) {
my ( $string , $start, $len ) = validate_pos @_ ,
{ type => SCALAR },
{ regex => qr/^\+?\s*\d+$/ },
{ regex => qr/^\+?\s*\d+$/ ,
default => length $_[0] } ;
substr( ($string || return'' ) , $start-1, $len, '' ) ;
$string;
}
sub delword ($$;$) {
(local $_, my ($start,$count))= validate_pos @_ ,
{type => SCALAR},
{regex=> NONNEGATIVE, default=>1 },
{regex=> NONNEGATIVE, default=>3E4};
$start-- ;
/ ^ (?:\S+\s*){$start} /xg or return $_ ;
s/(?:(?<=^)|(?<=\s)) \G (\s*\S+){0,$count} \s* //x , $_ ;
}
sub errortext ($) {
local ($!) = validate_pos @_ , { regex => qr/^\+?\s*\d+$/ } ,;
$! ;
}
sub insert ($$;$$$) {
my ($source , $target, $pos, $len, $char) = validate_pos @_ ,
{ type => SCALAR },
{ type => SCALAR },
{ regex => qr/^\+?\s*\d+$/ , default => 0 },
{ regex => qr/^\+?\s*\d+$/ , default => length $_[0] },
{ regex => qr/^.$/ , default => ' ' };
my $targlen = length $target ;
substr( $source, $len ) = '' ;
($pos <= $targlen) ? substr( $target, $pos , 0 , $source )
: ($target .= $char x ($pos-$targlen) . $source ) ;
$target;
}
sub lastpos ($$;$) {
my ($needle , $hay, $start ) = validate_pos @_ ,
{ type => SCALAR },
{ type => SCALAR },
{ regex => qr/^\+?\s*\d+$/,
default => length $_[1] };
1 + rindex( $hay, ($needle || return 0), --$start );
}
sub left ($$;$) {
my ($str, $len, $char) = validate_pos @_ ,
{ type => SCALAR },
{ regex => qr/^\+?\s*\d+$/ },
{ type => SCALAR, default=>' '},;
my $padding = $char x (($len||return '') - length $str) ;
substr( $str, 0, $len) . $padding ;
}
sub Length ($) {
length shift();
}
sub overlay ($$;$$$) {
my ($source , $target, $start, $len, $char ) = validate_pos @_ ,
{ type => SCALAR },
{ type => SCALAR },
{ regex => qr/^\+?\s*\d+$/ , default => 1 },
{ regex => qr/^\+?\s*\d+$/ , default => length $_[0] },
{ regex => qr/^.$/ , default => ' ' };
$source .= $char x ($len-length $source) ;
substr( $source, $len ) = '' ;
substr( $target, --$start, (length $source) , $source ) ;
$target;
}
sub Pos ($$;$) {
my ($needle , $hay, $start ) = @_ ;
1 + index( $hay, ($needle||return 0), ($start||0) );
}
sub right ($$;$) {
my ($str, $len, $char) = validate_pos @_ ,
{ type => SCALAR },
{ regex => qr/^\+?\s*\d+$/ },
{ type => SCALAR, default=>' '},;
my $padding = $char x (($len||return '') - length $str) ;
$padding . substr( $str, - $len);
}
sub Reverse ($) {
scalar reverse shift() ;
}
sub space ($;$$) {
(local $_, my ($len , $char)) = validate_pos @_ ,
{ type => SCALAR },
{ regex => NONNEGATIVE, default => 1 },
{ regex => qr/^.$/s , default => ' '};
s/^\s*|\s*$//g ;
s/\s+/{ $char x $len }/eg , $_ ;
}
sub Substr ($$;$$) {
my ($str, $start, $len, $char) = @_ ;
my $slen = length($str) || return '' ;
my $padding = ( $slen && $start) + $len - ($slen && 1) - $slen ;
substr($str, $start-1, $len) . $char x $padding ,
}
sub strip ($;$$) {
(local $_, my ( $direction, $char)) = validate_pos @_ ,
{ type => SCALAR },
{ regex => qr/^[LTB]$/i ,
default => 'B' },
{ regex => qr/^\S$/, default=>' '};
my $pattern = { L => "^[$char]+" ,
T => "[$char]+\$" ,
B => "^[$char]+|[$char]+\$" ,
}->{ uc $direction } ;
s/ $pattern //gx , $_ ;
}
sub translate ($;$$$) {
$_ = shift , my ($new, $old, $pad) = @_ ;
return uc unless ( $new || $old );
return undef unless defined $old;
( run in 1.495 second using v1.01-cache-2.11-cpan-df04353d9ac )