Ajout de la fonctionnalité pour capter des intervalles numériques

de la forme A=((?I10#20))
l'api ne change pas.

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