"Fossies" - the Fresh Open Source Software Archive

Member "formmail_modules-3.14m1/lib/CGI/NMS/Validator.pm" (11 Aug 2004, 3407 Bytes) of package /linux/www/old/formmail_modules-3.14m1.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "Validator.pm" see the Fossies "Dox" file reference documentation.

    1 package CGI::NMS::Validator;
    2 use strict;
    3 
    4 =head1 NAME
    5 
    6 CGI::NMS::Validator - validation methods
    7 
    8 =head1 SYNOPSYS
    9 
   10   use base qw(CGI::NMS::Validator);
   11 
   12   ...
   13  
   14   my $validurl = $self->validate_abs_url($url);
   15 
   16 =head1 DESCRIPTION
   17 
   18 This module provides methods to validate some of the types of
   19 data the occur in CGI scripts, such as URLs and email addresses.
   20 
   21 =head1 METHODS
   22 
   23 These C<validate_*> methods all return undef if the item passed
   24 in is invalid, otherwise they return the valid item.
   25 
   26 Some of these methods attempt to transform invalid input into valid
   27 input (for example, validate_abs_url() will prepend http:// if missing)
   28 so the returned valid item may not be the same as that passed in.
   29 
   30 The returned value is always detainted.
   31 
   32 =over
   33 
   34 =item validate_abs_url ( URL )
   35 
   36 Validates an absolute URL.
   37 
   38 =cut
   39 
   40 sub validate_abs_url {
   41   my ($self, $url) = @_;
   42 
   43   $url = "http://$url" unless $url =~ /:/;
   44   $url =~ s#^(\w+://)# lc $1 #e;
   45 
   46   $url =~ m< ^ ( (?:ftp|http|https):// [\w\-\.]{1,100} (?:\:\d{1,5})? ) ( /* (?:[^\./].*)? ) $ >mx
   47     or return '';
   48 
   49   my ($prefix, $path) = ($1, $2);
   50   return $prefix unless length $path;
   51 
   52   $path = $self->validate_local_abs_uri_frag($path);
   53   return '' unless $path;
   54   
   55   return "$prefix$path";
   56 }
   57 
   58 =item validate_local_abs_uri_frag ( URIFRAG )
   59 
   60 Validates a local absolute URI fragment, such as C</img/foo.png>.  Allows
   61 a query string.  The empty string is considered to be a valid URI fragment.
   62 
   63 =cut
   64 
   65 sub validate_local_abs_uri_frag {
   66   my ($self, $frag) = @_;
   67 
   68   $frag =~ m< ^ ( (?: \.* /  [\w\-.!~*'(|);/\@+\$,%#&=]* )?
   69                   (?: \?     [\w\-.!~*'(|);/\@+\$,%#&=]* )?
   70                 )
   71               $
   72            >x ? $1 : '';
   73 }
   74 
   75 =item validate_url ( URL )
   76 
   77 Validates a URL, which can be either an absolute URL or a local absolute
   78 URI fragment.
   79 
   80 =cut
   81 
   82 sub validate_url {
   83   my ($self, $url) = @_;
   84 
   85   if ($url =~ m#://#) {
   86     $self->validate_abs_url($url);
   87   }
   88   else {
   89     $self->validate_local_abs_uri_frag($url);
   90   }
   91 }
   92 
   93 =item validate_email ( EMAIL )
   94 
   95 Validates an email address.
   96 
   97 =cut
   98 
   99 sub validate_email {
  100   my ($self, $email) = @_;
  101 
  102   $email =~ /^([a-z0-9_\-\.\*\+\=]{1,100})\@([^@]{2,100})$/i or return 0;
  103   my ($user, $host) = ($1, $2);
  104 
  105   return 0 if $host =~ m#^\.|\.$|\.\.#;
  106 
  107   if ($host =~ m#^\[\d+\.\d+\.\d+\.\d+\]$# or $host =~ /^[a-z0-9\-\.]+$/i ) {
  108      return "$user\@$host";
  109    }
  110    else {
  111      return 0;
  112   }
  113 }
  114 
  115 =item validate_realname ( REALNAME )
  116 
  117 Validates a real name, i.e. an email address comment field.
  118 
  119 =cut
  120 
  121 sub validate_realname {
  122   my ($self, $realname) = @_;
  123 
  124   $realname =~ tr# a-zA-Z0-9_\-,./'\200-\377# #cs;
  125   $realname = substr $realname, 0, 128;
  126 
  127   $realname =~ m#^([ a-zA-Z0-9_\-,./'\200-\377]*)$# or die "failed on [$realname]";
  128   return $1;
  129 }
  130 
  131 =item validate_html_color ( COLOR )
  132 
  133 Validates an HTML color, either as a named color or as RGB values in hex.
  134 
  135 =cut
  136 
  137 sub validate_html_color {
  138   my ($self, $color) = @_;
  139 
  140   $color =~ /^(#[0-9a-z]{6}|[\w\-]{2,50})$/i ? $1 : '';
  141 }
  142 
  143 =back
  144 
  145 =head1 SEE ALSO
  146 
  147 L<CGI::NMS::Script>
  148 
  149 =head1 MAINTAINERS
  150 
  151 The NMS project, E<lt>http://nms-cgi.sourceforge.net/E<gt>
  152 
  153 To request support or report bugs, please email
  154 E<lt>nms-cgi-support@lists.sourceforge.netE<gt>
  155 
  156 =head1 COPYRIGHT
  157 
  158 Copyright 2003 London Perl Mongers, All rights reserved
  159 
  160 =head1 LICENSE
  161 
  162 This module is free software; you are free to redistribute it
  163 and/or modify it under the same terms as Perl itself.
  164 
  165 =cut
  166 
  167 1;
  168