summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Ivy.pm262
1 files changed, 242 insertions, 20 deletions
diff --git a/Ivy.pm b/Ivy.pm
index 518254b..5918ba7 100644
--- a/Ivy.pm
+++ b/Ivy.pm
@@ -46,7 +46,7 @@ use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK);
# to compute the VERSION from the CVS tag (or if no tag, as the cvs file revision)
my $TAG= q$Name$;
my $REVISION = q$Revision$ ;
-$VERSION = '1.39' ; # for Makefile.PL
+$VERSION = '1.42' ; # for Makefile.PL
($VERSION) = $TAG =~ /^\D*([\d_]+)/ ;
if (defined $VERSION and $VERSION ne "_") {
$VERSION =~ s/_/\./g;
@@ -165,6 +165,17 @@ sub _getNameByFileDes ($$); # retourne le nom de l'appi en fonction du filedes
# de la socket
sub _univSend ($$$); # effectue les send de manière bloquante ou non bloquante
# et accumule les messages si la socket est bloquée
+
+sub _regexpGen ($$$); # routines for generating regexps wich matches
+sub _strictPosRegexpGen ($$$$); # numerical interval using the special syntax
+sub _genAtRank ($$$); # (?I-20#-10) or (?I-20#-10i)
+sub _genPreRank ($$$);
+sub _genRank ($$$);
+sub _genPostRank ($);
+sub _nextMax ($$);
+sub _max ($$);
+sub _min ($$);
+
#############################################################################
#### CONSTANTES #####
#############################################################################
@@ -793,36 +804,51 @@ sub bindRegexp ($$$;$)
{
my $self = ref($_[0]) eq __PACKAGE__ ? shift : $globalIvy;
my ($regexp, $cb, $callByRef) = @_;
+ my $id;
$callByRef = defined $callByRef ? 1 : 0;
- my $original_regexp = $regexp;
- # on substitue les meta caracteres des regexps perl : \d, \w, \s, \e
- # par les classes de caracteres corespondantes de maniere a ce
- # qu'une appli distante non perl comprenne ces regexp.
+# my $original_regexp = $regexp;
+# # on substitue les meta caracteres des regexps perl : \d, \w, \s, \e
+# # par les classes de caracteres corespondantes de maniere a ce
+# # qu'une appli distante non perl comprenne ces regexp.
+# $regexp =~ s|
+# (
+# (?<!\\) \[ # le premier crochet ouvrant non precede d'un \
+# .*? # ce qu'il y a dans le crochet, en mode frugal
+# (?<!\\) \] # le premier crochet fermant non precede d'un \
+# )
+# |
+# _substituteEscapedChar ('inside', $1)
+# |xge;
+
+# $regexp = _substituteEscapedChar ('outside', $regexp);
+
+ # substitution des intervalles numériques de la forme
+ # (?I-10#20) ou (?I-10#20f) ou (?I-10#20i)
+
$regexp =~ s|
- (
- (?<!\\) \[ # le premier crochet ouvrant non precede d'un \
- .*? # ce qu'il y a dans le crochet, en mode frugal
- (?<!\\) \] # le premier crochet fermant non precede d'un \
- )
+ \(\?I # l'extension (?I
+ ([\d-]+) # la borne inférieure
+ \# # l'operateur d'intervalle
+ ([\d-]+) # la borne supérieure
+ ([if]?) # le caractère de codage f pour flottant, i pour integer, flottant par defaut
+ \) # la parenthèse fermante
|
- _substituteEscapedChar ('inside', $1)
+ _regexpGen ($1, $2, $3);
|xge;
- $regexp = _substituteEscapedChar ('outside', $regexp);
# print ("DBG> regexp = $regexp\n");
-
if ($^W) {
eval {my $test = "a" =~ /$regexp/ } ; # testing the regexp for avoiding
if ($@) {
- carp "Warning in Ivy::bindRegexp, ill-formed regexp: '$original_regexp'" ;
- return
+ carp "Warning in Ivy::bindRegexp, ill-formed regexp: '$regexp'" ;
+ return;
};
}
+
if ($cb) {
- my $id;
# on rajoute le couple $regexp, $cb dans la liste des messages
# qu'on prend
@@ -848,11 +874,12 @@ sub bindRegexp ($$$;$)
$self->[recCbList][$id]->[1] = [];
# on envoie le mesage delregexp
foreach my $fd (values %{$self->[sockList]}) {
- _univSend ($self, $fd, sprintf (MSG_FMT, DELREGEXP, $id,""));
+ _univSend ($self, $fd, sprintf (MSG_FMT, DELREGEXP, $id, ""));
}
}
}
}
+ return ($id);
} # end bindRegexp
############### METHODE BIND REGEXP
@@ -2070,8 +2097,6 @@ sub _getNameByFileDes ($$)
}
-
-
sub _getHostByAddr ($)
{
my $addr = shift;
@@ -2081,6 +2106,192 @@ sub _getHostByAddr ($)
return ($hostNameByAddr{$addr}= $peerName);
}
+
+
+sub _regexpGen ($$$)
+{
+ my ($min, $max, $withDecimal) = @_;
+
+ print ("DBG> min=$min max=$max withDecimal=$withDecimal\n");
+
+ ($min, $max) = ($max, $min) if $min > $max;
+
+ $min = int ($min);
+ $max = int ($max);
+
+ my ($decimalPart,$boundDecimalPart, $reg) = ('') x 3;
+
+ if ((!defined $withDecimal) || ($withDecimal ne 'i')) {
+ $decimalPart = '(?:\.\d+)?';
+ $boundDecimalPart = '(?:\.0+)?';
+ }
+
+ if ($min == $max) {
+ $reg= $min;
+ } elsif ($min < 0) {
+ if ($max < 0) {
+ $reg = '\-(?:' . _strictPosRegexpGen (-$max, -$min, $decimalPart, $boundDecimalPart). ')';
+ } elsif ($max == 0) {
+ $reg = "(?:0${boundDecimalPart})|(?:-0${decimalPart})|-(?:" .
+ _strictPosRegexpGen (1, -$min, $decimalPart,$boundDecimalPart ) . ')';
+ } else {
+ $reg ='(?:' . regexpGen ($min, 0,$withDecimal) . '|' . regexpGen (0, $max, $withDecimal). ')' ;
+ }
+ } elsif ($min == 0) {
+ $reg = "(?:0${decimalPart})|" . _strictPosRegexpGen (1, $max, $decimalPart,$boundDecimalPart) ;
+ } else {
+ $reg = _strictPosRegexpGen ($min, $max, $decimalPart,$boundDecimalPart);
+ }
+ return ("(?:$reg)(?![\\d.])");
+}
+
+
+
+sub _strictPosRegexpGen ($$$$)
+{
+ my ($min, $max, $decimalPart,$boundDecimalPart) = @_;
+ die "min[$min] sould be <= max[$max]\n " unless ($min <= $max);
+ die "min[$min] and max[$max] should be strictly positive\n " unless (($min >0) && ($max > 0));
+
+# my $fixBound ;
+# $max -- if ($fixBound = ($decimalPart ne '') && ((int ($max /10) *10) != $max));
+
+ if ($min == $max) {
+ return ($min);
+ }
+
+ $max -- ;
+
+ my @regexps ;
+ my $nbRank = length ($max);
+ my ($rank, $lmax) ;
+
+ do {
+ ($lmax, $rank) = _nextMax ($min, $max);
+ push (@regexps, _genAtRank ($min, $lmax, $rank));
+ $min = $lmax+1;
+ } while ($lmax != $max) ;
+
+ my $regexp = join ('|', map ("(?:$_$decimalPart)", @regexps));
+ $max ++;
+ $regexp .= "|(?:${max}$boundDecimalPart)";
+
+ return ($regexp);
+}
+
+
+sub _genAtRank ($$$)
+{
+ my ($min, $max, $rank) = @_;
+ my $reg = _genPreRank ($min, $max, $rank);
+ $reg .= _genRank ($min, $max, $rank);
+ $reg .= _genPostRank ($rank);
+ return ($reg);
+}
+
+
+sub _nextMax ($$)
+{
+ my ($min, $max) = @_;
+ my $nextMax;
+
+ # on a les unités au debut
+ my (@min) = reverse split ('', $min);
+ my (@max) = reverse split ('', $max);
+ my $nbDigit = scalar (@max);
+ my ($rankRev, $rankForw, $rank) = (0, $nbDigit-1, 0) ;
+
+ # on rajoute des 0 en face si min n'a pas le même nombre de digits que max
+ push (@min, ('0') x ($#max - $#min)) if ($#min != $#max);
+
+ # on calcule le rang concerné par le prochain intervale
+
+ # en partant des unitées (digit de poids faible), premier champ de min != 0
+ while (($min[$rankRev] == 0) && $rankRev < $nbDigit) {$rankRev++} ;
+ # printf ("DBG> min = $min[0]|$min[1]|$min[2] rankRev=$rankRev, nbDigit=$nbDigit\n");
+
+ # en partant du digit de poids fort, premier champ de max != du même champ
+ while (($min[$rankForw] == $max[$rankForw]) && $rankForw > 0) {$rankForw--};
+# printf ("DBG> min = $min[0]|$min[1]|$min[2] rankForw=$rankForw, nbDigit=$nbDigit\n");
+
+ if ($rankForw <= $rankRev) {
+ $rank = $rankForw;
+ $min[$rankForw]= $max[$rankForw] - ($rankForw ? 1 : 0);
+ @min[0 .. $rankForw-1]= (9) x ($rankForw);
+ } else {
+ $rank = $rankRev;
+ @min[0 .. $rankRev]= (9) x ($rankRev+1);
+ }
+
+# print ("DBG> NEWmin = $min[0]|$min[1]|$min[2]\n");
+ $nextMax = join ('',reverse @min);
+ $nextMax = $max if $nextMax > $max;
+
+ return ($nextMax, $rank+1);
+}
+
+
+
+sub _genPreRank ($$$)
+# les invariants du min
+{
+ my ($min, $max, $rank) = @_;
+
+ $min = $min + 0; # force scalar to be evaluated as numérical
+ $max = $max + 0; # instead string (eliminate leading zeroes)
+ my $a = substr ($min, 0, (length ($min) - $rank));
+ my $b = substr ($max, 0, (length ($max) - $rank));
+ die "genPreRank error $min, $max are not invariant @ rank $rank\n" if $a ne $b;
+ return $a;
+}
+
+
+sub _genRank ($$$)
+{
+ my ($min, $max, $rank) = @_;
+ my $syl ;
+
+ my $a = substr ($min, (length ($min) - $rank), 1);
+ my $b = substr ($max, (length ($max) - $rank), 1);
+
+ $min = _min ($a, $b);
+ $max = _max ($a, $b);
+
+ if (($min == 0) && ($max == 9)) {
+ $syl = '\d';
+ } elsif ($min == $max) {
+ $syl = $min;
+ } elsif ($max == $min+1) {
+ $syl = "[${min}${max}]"
+ } else {
+ $syl = "[$min-$max]";
+ }
+
+ return ($syl);
+}
+
+
+sub _genPostRank ($)
+{
+ my $rank = shift;
+
+ return "" if ($rank <= 1);
+ return ($rank == 2) ? '\d' : sprintf ('\d{%d}', $rank -1);
+}
+
+sub _max ($$)
+{
+ my ($a,$b) = @_;
+ return ($a > $b) ? $a : $b;
+}
+
+sub _min ($$)
+{
+ my ($a,$b) = @_;
+ return ($a > $b) ? $b : $a;
+}
+
+
1;
__END__
@@ -2402,8 +2613,19 @@ To unbind callback(s) associated to a regexp use bindRegexp with only
one argument, the regexp. Note that doing the same binding more than
once will induce multiple call of the same callback (this is usually a bug).
+there is a special syntax for specifying numeric interval, in this case
+the interval is locally transformed in a pcre regexp.
+syntax is (?Imin#max[fi]). min and max are the bounds,
+by default the regexp match decimal number, but if max bound is
+followed by 'i', the regexp match only integers ex : (?I-10#20), (?I20#25i)
+Note that due to the regexp generator limitation (which will perhaps be raised eventually)
+the bounds are always integer.
+
+Return value : regexpId
+
Example :
$ivyobject->bindRegexp("\w+ (\d+)", [\&callback, @cb_parameters]);
+ $ivyobject->bindRegexp("\w+ ((?I-10#20i))", [\&callback, @cb_parameters]);
# Your callback will be called with one more parameter which will be
# the name of appli which send the message
@@ -2536,4 +2758,4 @@ CENA (C) 1997-2006
=head1 HISTORY
-=cu
+=cut