diff options
Diffstat (limited to 'Ivy.pm')
| -rw-r--r-- | Ivy.pm | 262 |
1 files changed, 242 insertions, 20 deletions
@@ -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 |