code/OrderCheck/regex.oc

   1 # Copyright 2005-2007 Interchange Development Group and others
   2 #
   3 # This program is free software; you can redistribute it and/or modify
   4 # it under the terms of the GNU General Public License as published by
   5 # the Free Software Foundation; either version 2 of the License, or
   6 # (at your option) any later version.  See the LICENSE file for details.
   7 #
   8 # $Id: regex.oc,v 1.3 2007-03-30 23:40:48 pajamian Exp $
   9
  10 CodeDef regex OrderCheck 1
  11 CodeDef regex Description Regular expression match
  12 CodeDef regex Routine <<EOR
  13 sub {
  14         my($ref, $name, $value, $code) = @_;
  15         my $message;
  16
  17         $code =~ s/\\/\\\\/g;
  18         my @code = Text::ParseWords::shellwords($code);
  19         if($code =~ /(["']).+?\1$/) {
  20                 $message = pop(@code);
  21         }
  22
  23         for(@code) {
  24                 my $negate;
  25                 s/^!\s*// and $negate = 1;
  26                 my $op = $negate ? "!~" :  '=~';
  27                 my $regex = qr($_);
  28                 my $status;
  29                 if($negate) {
  30                         $status = ($value !~ $regex);
  31                 }
  32                 else {
  33                         $status = ($value =~ $regex);
  34                 }
  35                 if(! $status) {
  36                         $message = errmsg(
  37                                                           "failed pattern - %s",
  38                                                           "'$value' $op $_"
  39                                                          ) if ! $message;
  40                         return ( 0, $name, $message);
  41                 }
  42         }
  43         return (1, $name, '');
  44 }
  45 EOR