String::Rexx - Perl implementation of Rexx string functions
Index
- NAME
- SYNOPSIS
- DESCRIPTION
-
- Abbrev( 'long', 'short' [, len] )
- countstr( 'pat', 'string' )
- center( 'string' , len [, char ] )
- changestr( 'old', 'string' , 'new' )
- compare( 'string1' , 'string2' [, char ] )
- copies( 'string' , N )
- delstr( 'string' , start [,length] )
- delword( 'string' , start [,length] )
- errortext( N )
- datatype( 'string' [, option ] )
- d2c( N )
- d2x( N [, length] )
- insert( 'source' , 'target' [,'position' ] [,'length'] [, char ] )
- lastpos( 'needle' , 'haystack', [, start ] )
- left( 'string' , length, [, 'char'] )
- Length( 'string' )
- overlay( 'source', 'target' [, start] [, length] [, pad] )
- Reverse( 'string' )
- Pos( 'needle' , 'haystack', [, start ] )
- right( 'string' , length, [, 'char'] )
- space( 'string' [, 'length'] [, 'char'] )
- strip( 'string' [, 'Option'] [, 'char'] )
- Substr( 'string', start, [, length ] [, padchar ] )
- wordindex( 'string', N )
- wordlength( 'string', N )
- subword( 'string', start [, N ] )
- translate( 'string' [, 'new' , 'old' [, pad] ] )
- verify( 'string', 'chars' [, sense] [, start] )
- wordpos( 'pattern' , 'string' )
- word( 'string', wordno )
- words( 'string' )
- xrange( S , E )
- AUTHOR
- SEE ALSO
Code Index:
NAME
String::Rexx - Perl implementation of Rexx string functions
SYNOPSIS
use String::Rexx qw( :all );
use String::Rexx qw( functions... );
DESCRIPTION
This module implements almost all string functions
of regina2-rexx .
- 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.
- countstr( 'pat', 'string' )
-
Counts the number of occurences of 'pat' within 'string'
- center( 'string' , len [, char ] )
-
Returns a string of length len, with the proper padding so that 'string' is centered
- changestr( 'old', 'string' , 'new' )
-
Changes all instances of substing 'old' inside 'string' to the new string 'new'
- compare( 'string1' , 'string2' [, char ] )
-
Returns 0 when both strings are equal, or N when they are not.
The number N denotes the length of either string -- strings are always
compared after padding, so they always have equal length when they are compared.
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 , ' ' .
- copies( 'string' , N )
-
Returns a string consisting of N concatenated copies. N = 0, 1, 2, ...
- delstr( 'string' , start [,length] )
-
Deletes the substring which starts at $start.
Length defaults to the rest of string.
- delword( 'string' , start [,length] )
-
Deletes $length words, starting from $start.
Length defaults to the rest of string.
- errortext( N )
-
Returns the error string that describes the error number N .
- 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 ;
- d2c( N )
-
Same as chr(N) . Converts decimal N to its char in the character set.
- d2x( N [, length] )
-
Converts decimal N to a hex string of size $lenght .
- 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 ' ' .
- 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
- 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.
- Length( 'string' )
-
Returns the length of string.
- overlay( 'source', 'target' [, start] [, length] [, pad] )
-
Overstrikes the $target string, with $source .
- Reverse( 'string' )
-
Reverses the order of characters in string.
- 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
- 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.
- space( 'string' [, 'length'] [, 'char'] )
-
After removing leading and trailing spaces, internal whitespace
change to $length chars. Char defaults to ' ' , and length defaults to 1 .
- 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.
- 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 .
- wordindex( 'string', N )
-
Returns the index in the string for the Nth word.
- 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
- 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,...
- 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.
- verify( 'string', 'chars' [, sense] [, start] )
-
Returns 0 if $string consists from characters in the set $chars , otherwise
it returns the position of the 1st character in $sting that failed the match.
The sense param is either 'M' for match, or 'N' for non-match, default is 'M' .
The start param indicate the position from 'string' to start matching (default is 1,
to match from the start of 'string').
- wordpos( 'pattern' , 'string' )
-
Returns the position of the word in 'string' containing 'pattern'
- word( 'string', wordno )
-
Returns the nth word in the string.
- words( 'string' )
-
Returns the number of words in the string.
- xrange( S , E )
-
Retruns a sequence of characters, starting with char S, and ending with char E .
EXPORT
AUTHOR
Ioannis Tambouras, <ioannis@earthlink.net>
SEE ALSO
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.07';
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;
sub Abbrev ($$;$) {
( local $_ , my ( $short , $len )) = validate_pos @_ ,
{ type => SCALAR },
{ type => SCALAR },
{ regex => qr/^\+?\s*\d+$/, optional=>1 };
/^$short/ || ((defined $len)&&length $short >= $len) ? 1
: 0 ;
}
sub center ($$;$) {
my ($str , $len , $char) = validate_pos @_ ,
{ type => SCALAR } ,
{ regex => qr/^\+?\s*\d+$/ } ,
{ regex => qr/^.$/ , default => ' ' },
;
$str = substr( $str, 0, $len ) ; # if they asked for less space than given text
my $offset = ($len - length $str)/2 ;
($char x $offset) . $str . ($char x ($offset+0.6) ) ;
}
sub centre ($$;$) { goto ¢er }
sub changestr ($$$) {
my ( $old , $string, $new) = @_ ;
$string =~ s/\Q$old/$new/g , $string;
}
sub compare ($$;$) {
my ( $a, $b , $char) = validate_pos @_ ,
{ type => SCALAR },
{ type => SCALAR },
{ regex => qr/^.$/ , default => ' ' };
my ($Alen , $Blen) = ( length($a) , length($b) );
my $max = ($Alen > $Blen) ? $Alen : $Blen ;
substr( $a, $Alen ) = $char x ($max - $Alen) ;
substr( $b, $Blen ) = $char x ($max - $Blen) ;
$a cmp $b && $max ;
}
sub copies ($$) {
my ( $str , $num ) = validate_pos @_ ,
{ type => SCALAR },
{ regex => NONNEGATIVE } ;
$str x $num ;
}
sub countstr ($$) {
(my ($pat), local $_) = @_ ;
($pat eq '') ? 0 : ( () = /\Q$pat/gx ) ;
}
sub datatype ($;$) {
my ($real, $str, $option) = (REAL, validate_pos @_,
{ type => SCALAR },
{ regex => qr/^[ablmnuwx]$/i, optional=>1});
(defined $option)
? $str =~ { A => '(?i)^[a-z\d]+$' ,
B => '^[01]+$' ,
L => '^[a-z]+$' ,
M => '(?i)^[a-z]+$' ,
N => "^$real\$" ,
U => '^[A-Z]+$' ,
W => '^[-+]?[\d]+$' ,
X => '(?i)^[\da-f]+$' ,
}->{uc $option} || 0
: ($str =~ /^$real$/) && 'NUM' || 'CHAR' ;
}
sub d2c ($) {
chr(shift) ;
}
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;
$pad = $pad || ' ' ;
eval "y/$old/$new$pad/" ;
$_;
}
sub verify ($$;$$) {
(local $_, my ($ref, $opt, $start)) =
validate_pos @_ ,
{ type => SCALAR },
{ type => SCALAR },
{ regex => qr/^[NM]$/i, default=>'N' }, { regex => POSITIVE, default=> 1 };
return 0 if $ref eq '';
my $pattern = qr/ (?: [\Q$ref\E]) /x ;
pos() = --$start;
($opt =~ /N/i)
? do{ /\G $pattern+/xgc;
return (pos == length) ? 0 : 1 + pos }
: /$pattern/gc or return 0;
pos ;
}
sub word ($$) {
(local $_, my $start) = validate_pos @_ ,
{ type => SCALAR } ,
{ regex => POSITIVE } ;
$start--;
/ ^ (?>\s* (?:\S+\s*){$start}) (\s*\S+) /x
and $+;
}
sub wordindex ($$) {
my ($str, $n) = validate_pos @_ , { type => SCALAR },
{ regex => NONNEGATIVE } ;
(' '.$str) =~ / (?:\s+ (\S+)){$n} /x
&& $-[1] or 0;
}
sub wordlength ($$) {
my ($str, $n) = validate_pos @_ , { type => SCALAR },
{ regex => NONNEGATIVE };
(' '.$str) =~ / (?:\s (\S+)){$n} /x
? length ($1||'')
: 0 ;
}
sub subword ($$;$) {
(local $_, my ($start, $n)) = validate_pos @_ ,
{ type => SCALAR } ,
{ regex => POSITIVE } ,
{ regex => NONNEGATIVE , default => 3e3 };
$start--;
/ ^ (?>\s* (?:\S+\s*){$start}) ((?:\s*\S+){0,$n}) /x
and $+;
}
sub wordpos ($$) {
(my $pat, local $_, my $i) = @_ ;
return 0 if $pat eq '';
$i++ while ( / \G (?>\s*\S+) (?<!\Q$pat\E) /xcg) ;
((pos||0) == length) ? 0 : ++$i ;
}
sub words ($) {
scalar ( () = shift() =~ /(\S+)/g );
}
sub xrange ($$) {
my ($start, $end) = @_ ;
my $len = 1 + ord ($end) - ord ($start);
return pack 'A'x$len , $start..$end if $len>0 ;
pack 'A'x(257+$len) , $start..chr(0xff) , chr(0)..$end ;
}
sub b2d {
(local $_) = validate_pos @_ , { regex => qr/^[01]+$/ } ;
eval "0b$_";
# Method2 (4x faster)
# pack 'A*', unpack 'N', pack 'B32', '0'x (32-length) .$_ ;
}
sub d2x {
validate_pos @_, { regex => NONNEGATIVE } ;
local $_ = pack '(A*)*', unpack '(H2)*', pack 'N', shift ;
s/^0*//g ;
$_ or '0';
}
sub sign ($) {
($_[0] > 0) ? 1
: ($_[0]<0) ? -1
: 0 ;
}
sub x2b {
local ($_) = validate_pos @_, { regex => HEX } ;
$_ = '0'x(8-(length||return '')) . $_ ;
($_=unpack 'B32', pack 'H*', $_ ) =~ s/^0*(?!$)// , $_ ;
}
sub b2x {
local ($_) = validate_pos @_, { regex => BINARY } ;
$_ = '0'x(32-(length||return '')) . $_ ;
($_ = unpack 'H*', pack 'B32', $_ ) =~ s/^ 0* (?!$) //x , $_;
}
sub x2c {
validate_pos @_ , { regex => HEX } ;
unpack 'A*', pack 'H*', (shift||return '');
}
sub x2d {
validate_pos @_ , { regex => HEX } ;
hex shift;
}
sub c2x {
pack '(A*)*', unpack '(H2)*', shift;
}
sub d2b {
validate_pos @_ , { regex => NONNEGATIVE };
local $_ = unpack 'B32'x8, pack 'N', shift ;
s/^0*//g ;
'0' x (8-(length)%8) . $_;
}