Interchange Reference Pages: Checks

# Copyright 2006-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: always_fail.oc,v 1.2 2007-03-30 23:40:48 pajamian Exp $

CodeDef always_fail OrderCheck 1
CodeDef always_fail Description Always fails
CodeDef always_fail Routine <<EOR
sub {
my ($ref, $name, $value, $msg) = @_;
return (0, $name, $msg || errmsg('failed'));
}
EOR

# Copyright 2006-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: always_pass.oc,v 1.3 2007-03-30 23:40:48 pajamian Exp $

CodeDef always_pass OrderCheck 1
CodeDef always_pass Description Always succeeds
CodeDef always_pass Routine <<EOR
sub {
return (1, $_[1], '');
}
EOR

# Copyright 2005-2009 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: email_only.oc,v 1.5 2009-01-28 07:38:26 racke Exp $

CodeDef email_only OrderCheck 1
CodeDef email_only Description Email address
CodeDef email_only Routine <<EOR
sub {
my($ref, $var, $val, $msg) = @_;
if($val and $val =~ /^[\040-\053\055-\077\101-\176]+\@[-A-Za-z0-9.]+\.[A-Za-z]+$/) {
  return (1, $var, '');
}
else {
  return (undef, $var,
    $msg || errmsg("'%s' not an email address", $val )
  );
}
}
EOR

# Copyright 2005-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: exists.oc,v 1.3 2007-03-30 23:40:48 pajamian Exp $

CodeDef exists OrderCheck 1
CodeDef exists Description Existing record
CodeDef exists Routine <<EOR
sub {
my($ref, $name, $value, $code) = @_;

$code =~ s/(\w+)(:+(\w+))?\s*//;
my $tab = $1
  or return (0, $name, errmsg("no table specified"));
my $col = $3;
my $msg = $code;

my $db = database_exists_ref($tab)
  or do {
    $msg = errmsg(
            "Table %s doesn't exist",
            $tab,
           );
    return(0, $name, $msg);
  };

my $used;
if(! $col) {
  $used = $db->record_exists($value);
}
else {
  #::logDebug("Doing foreign key check, tab=$tab col=$col value=$value");
  $used = $db->foreign($value, $col);
}

#::logDebug("Checking exists, tab=$tab col=$col, used=$used");
if($used) {
  return (1, $name, '');
}
else {
  $msg = errmsg(
          "Key %s does not exist in %s, try again.",
          $value,
          $tab,
         ) unless $msg;
  return(0, $name, $msg);
}

}
EOR

# Copyright 2005-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: filter.oc,v 1.3 2007-03-30 23:40:48 pajamian Exp $

CodeDef filter OrderCheck 1
CodeDef filter Description Passes filter unchanged
CodeDef filter Routine <<EOR
sub {    
my ($ref, $name, $value, $code) = @_;
my $message;
my $filter;

$code =~ s/\\/\\\\/g;
if($code =~ /(["']).+?\1$/) {
  my @code = Text::ParseWords::shellwords($code);
  $message = pop(@code);
  $filter = join " ", @code;
}
else {
  ($filter, $message) = split /\s+/, $code, 2;
}

my $test = Vend::Interpolate::filter_value($filter, $value, $name);
if($test ne $value) {
  $message ||= errmsg("%s caught by filter %s", $name, $filter);
  return ( 0, $name, $message);
}
return (1, $name, '');
}
EOR

# Copyright 2005-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: future.oc,v 1.5 2007-03-30 23:40:48 pajamian Exp $

CodeDef future OrderCheck 1
CodeDef future Description Future date
CodeDef future Routine <<EOR
sub {
my($ref, $name, $value, $code) = @_;
my $message;

my @code = Text::ParseWords::shellwords($code);
if($code =~ /(["']).+?\1$/) {
  $message = pop(@code);
}
my $adjust = join " ", @code;
if(! $message) {
  $message = errmsg(
            "Date must be in the future at least %s",
            $adjust,
           );
}
if($value =~ /\0/) {
  $value = Vend::Interpolate::filter_value(
                       'date_change',
                       $value,
                      );
}
my $current = Vend::Interpolate::mvtime(
                    undef,
                    { adjust => $adjust },
                    "%Y%m%d%H%M",
                     );

# reject invalid dates
if($value !~ /^[12]\d\d\d[01]\d[0123]\d(?:[0-2]\d[0-5]\d(?:[0-5]\d)?)?$/) {
  return (0, $name, $message);
} 

if($value lt $current) {
  return (0, $name, $message);
}
return (1, $name, '');
}
EOR

# Copyright 2008,2009 Interchange Development Group
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.

CodeDef isbn OrderCheck 1
CodeDef isbn Description ISBN-10/ISBN-13 check digit verification
CodeDef isbn Routine <<EOR
sub {
my($ref, $var, $val, $msg) = @_;
my($len);

if ($msg =~ s/^\s*(10|13)\s*//) {
  $len = $1;
}

$val =~ s/[^\dXx]//g;  # weed out non-digits
if ($val) {
  my @digits = split("", $val);
  my $sum = 0;
  my $check_digit = 0;
  my $modulo;

  if (@digits == 10 ) {
    # ISBN-10 number
    if ($len == 13) {
      return (0, $var, errmsg("'%s' not a valid isbn-13 number", $val));
    }
    for(my $i=10; $i > 0; $i--) {
        my $d = $digits[10 - $i];
      if ($d =~ /[Xx]/) {
        if ($i == 1) {
          $d = 10;
        }
        else {
          return (undef, $var, errmsg("'%s' not a valid isbn number", $val));
            }
      }
      $sum += $d * $i;
    }
    return ( $sum%11 ? 0 : 1, $var, '' );
  } elsif (@digits == 13) {
    # ISBN-13/EAN number
    if ($len == 10) {
      return (0, $var, errmsg("'%s' not a valid isbn-10 number", $val));
    }
    for (my $i = 0; $i < 12; $i++) {
      if ($i % 2) {
        $sum += 3 * $digits[$i];
      } 
      else {
        $sum += $digits[$i];
      }
    }
    
    if ($modulo = $sum % 10) {
                  $check_digit = 10 - $modulo;
          }

    if (pop(@digits) == $check_digit) {
      # verification successful
      return (1, $var, '');
    }
  }
}

return (undef, $var, errmsg("'%s' not a valid isbn number", $val));
}
EOR

# Copyright 2005-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: length.oc,v 1.3 2007-03-30 23:40:48 pajamian Exp $

CodeDef length OrderCheck 1
CodeDef length Description String length
CodeDef length Routine <<EOR
sub {
my($ref, $name, $value, $msg) = @_;
$msg =~ s/^(\d+)(?:\s*-(\d+))?\s*//
  or return undef;
my $min = $1;
my $max = $2;
my $len = length($value);

if($len < $min) {
  $msg = errmsg(
          "%s length %s less than minimum length %s.",
          $name,
          $len,
          $min) if ! $msg;
  return(0, $name, $msg);
}
elsif($max and $len > $max) {
  $msg = errmsg(
          "%s length %s more than maximum length %s.",
          $name,
          $len,
          $max) if ! $msg;
  return(0, $name, $msg);
}
return (1, $name, '');
}
EOR

# Copyright 2007 Interchange Development Group (http://www.icdevgroup.org/)
# Licensed under the GNU GPL v2. See file LICENSE for details.
# $Id: match.oc,v 1.1 2007-05-04 14:36:00 mheins Exp $

CodeDef match OrderCheck 1
CodeDef match Description Matches another CGI variable, possibly for password verify
CodeDef match Routine <<EOR
sub {
my($ref, $name, $value, $msg) = @_;
$msg =~ s/^\s*(\w[-\w]*)\s*//
  or return undef;
my $other = $1;

if($ref->{$other} ne $value) {
  $msg = errmsg(
          "%s doesn't match %s.",
          $name,
          $other,
          ) if ! $msg;
  return(0, $name, $msg);
}
return (1, $name, '');
}
EOR

# Copyright 2005-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: natural.oc,v 1.4 2008-04-28 12:08:38 docelic Exp $

CodeDef natural OrderCheck
CodeDef natural Description Natural number
CodeDef natural Routine <<EOR
sub {
my ($ref, $name, $value, $code) = @_;

if ($value and $value > 0 and "$value" eq int($value)) {
  return (1, $name, '');
}

$code =~ s/\\/\\\\/g;
$code =~ s/^\s*(["'])(.+?)\1$/$2/;

if ($code =~ /\S/) {
  return (0, $name, $code);
} else {
  return (0, $name, 'no natural number');
}
}
EOR

# Copyright 2010 Interchange Development Group and others
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version. See the LICENSE file for details.

CodeDef numeric OrderCheck
CodeDef numeric Description Numeric
CodeDef numeric Routine <<EOR

sub {
my ($ref, $name, $value, $msg) = @_;
use Scalar::Util qw/looks_like_number/;

if (looks_like_number($value)) {
    return (1, $name, '');
}
else {
    return (0, $name, defined($msg) ? $msg : 'not numeric');
}
}
EOR

# Copyright 2010 Interchange Development Group and others
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version. See the LICENSE file for details.

CodeDef numeric_strict OrderCheck
CodeDef numeric_strict Description Numeric (strict)
CodeDef numeric_strict Routine <<EOR
sub {
my ($ref, $name, $value, $msg) = @_;

if (defined($value) and $value =~ /\A-?\d+(?:\.\d+)?\z/) {
    return (1, $name, '');
}
else {
    return (0, $name, defined($msg) ? $msg : 'not strict numeric');
}
}
EOR

# Copyright 2005-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: regex.oc,v 1.3 2007-03-30 23:40:48 pajamian Exp $

CodeDef regex OrderCheck 1
CodeDef regex Description Regular expression match
CodeDef regex Routine <<EOR
sub {    
my($ref, $name, $value, $code) = @_;
my $message;

$code =~ s/\\/\\\\/g;
my @code = Text::ParseWords::shellwords($code);
if($code =~ /(["']).+?\1$/) {
  $message = pop(@code);
}

for(@code) {
  my $negate;
  s/^!\s*// and $negate = 1;
  my $op = $negate ? "!~" :  '=~';
  my $regex = qr($_);
  my $status;
  if($negate) {
    $status = ($value !~ $regex);
  }
  else {
    $status = ($value =~ $regex);
  }
  if(! $status) {
    $message = errmsg(
              "failed pattern - %s",
              "'$value' $op $_"
             ) if ! $message;
    return ( 0, $name, $message);
  }
}
return (1, $name, '');
}
EOR

# Copyright 2005-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: relative_filename.oc,v 1.3 2007-03-30 23:40:48 pajamian Exp $

CodeDef relative_filename OrderCheck 1
CodeDef relative_filename Description Relative filename
CodeDef relative_filename Routine <<EOR
sub {
my ($ref, $name, $value, $code) = @_;

if ($value =~ /\S/ && $value !~ /^\.{1,2}$/ 
  && ! Vend::File::absolute_or_relative($value)) {
  return (1, $name, '');
} else {
  $code ||= errmsg('filename not relative');
  return (0, $name, $code);
}
}
EOR

# Copyright 2005-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: unique.oc,v 1.3 2007-03-30 23:40:48 pajamian Exp $

CodeDef unique OrderCheck 1
CodeDef unique Description Unique record
CodeDef unique Routine <<EOR
sub {
my ($ref, $name, $value, $code) = @_;

$code =~ s/(\w+)(:+(\w+))?\s*//;
my $tab = $1
  or return (0, $name, errmsg("no table specified"));
my $col = $3;
my $msg = $code;

my $db = database_exists_ref($tab)
  or do {
    $msg = errmsg(
            "Table %s doesn't exist",
            $tab,
           );
    return(0, $name, $msg);
  };
my $used;
if(! $col) {
  $used = $db->record_exists($value);
}
else {
  #::logDebug("Doing foreign key check, tab=$tab col=$col value=$value");
  $used = $db->foreign($value, $col);
}

#::logDebug("Checking unique, tab=$tab col=$col, used=$used");
if(! $used) {
  return (1, $name, '');
}
else {
  $msg = errmsg(
          "Key %s already exists in %s, try again.",
          $value,
          $tab,
         ) unless $msg;
  return(0, $name, $msg);
}
}
EOR