#!/usr/bin/env perl

# Tests to see if the url_pattern accepts what it should accept and
# rejects what it should reject.

$url_pattern =
'(
 (
  # Handle http, https, and relative URIs:
  ((https?://([A-Za-z0-9][A-Za-z0-9\-]*(\.[A-Za-z0-9][A-Za-z0-9\-]*)*\.?))|
    ([A-Za-z0-9\-\_\.\!\~\*\'\(\)]|(%[2-9A-Fa-f][0-9a-fA-F]))+)?
  ((/([A-Za-z0-9\-\_\.\!\~\*\'\(\)]|(%[2-9A-Fa-f][0-9a-fA-F]))+)*/?) # path
   (\?(                                                              # query:
       (([A-Za-z0-9\-\_\.\!\~\*\'\(\)\+]|(%[2-9A-Fa-f][0-9a-fA-F]))+=
        ([A-Za-z0-9\-\_\.\!\~\*\'\(\)\+]|(%[2-9A-Fa-f][0-9a-fA-F]))+
        (\&([A-Za-z0-9\-\_\.\!\~\*\'\(\)\+]|(%[2-9A-Fa-f][0-9a-fA-F]))+=
         ([A-Za-z0-9\-\_\.\!\~\*\'\(\)\+]|(%[2-9A-Fa-f][0-9a-fA-F]))+)*)
       |
       (([A-Za-z0-9\-\_\.\!\~\*\'\(\)\+]|(%[2-9A-Fa-f][0-9a-fA-F]))+  # isindex
       )
   ))?
   (\#([A-Za-z0-9\-\_\.\!\~\*\'\(\)\+]|(%[2-9A-Fa-f][0-9a-fA-F]))+)? # fragment
  )|
 # Handle ftp:
 (ftp://([A-Za-z0-9][A-Za-z0-9\-]*(\.[A-Za-z0-9][A-Za-z0-9\-]*)*\.?)
  ((/([A-Za-z0-9\-\_\.\!\~\*\'\(\)]|(%[2-9A-Fa-f][0-9a-fA-F]))+)*/?) # path
  (\#([A-Za-z0-9\-\_\.\!\~\*\'\(\)\+]|(%[2-9A-Fa-f][0-9a-fA-F]))+)? # fragment
  )
 )';


$GOOD = 1;
$BAD  = 0;


sub url_okay {
 my $url = shift(@_);

 # print " Testing url: !$url!\n";
 if ($url =~ m!^${url_pattern}$!sx) {return $GOOD;}
 else {return $BAD;}
}


sub check {
 my ($url, $status) = @_;
 my $actual_status = &url_okay($url);

 if ($actual_status != $status) {
   print "FAILURE! Expected $status, actual $actual_status from url=\"$url\"\n";
 }
}


print "Running tests of URIs.\n";
check("http://www.yahoo.com", $GOOD);
check("http://www.yahoo.com/", $GOOD);
check("http://1.2.3.4/", $GOOD);
check("http://www.yaho%6f.com", $BAD);
check("http://www.yahoo.com/stuff", $GOOD);
check("http://www.yahoo.com/stuff/", $GOOD);
check("http://www yahoo.com", $BAD);
check("http://www.yahoo.com/hello world/", $BAD);
check("http://www.yahoo.com/hello%00world/", $BAD);
check("http://www.yahoo.com/hello%20world/", $GOOD);
check("http://www.yahoo.com/hello+world/", $BAD);
check("http://www.yahoo.com?name=obi", $GOOD);
check("http://www.yahoo.com?name=obi&", $BAD);
check("http://www.yahoo.com?name=obi&type=", $BAD);
check("http://www.yahoo.com?name=obi+wan&status=jedi", $GOOD);
check("http://www.yahoo.com?onery", $GOOD);
check("http://www.yahoo.com?name=%00%01", $BAD);
check("http://www.yahoo.com#bottom", $GOOD);
check("http://www.yahoo.com/yelp.html#bottom", $GOOD);
check("http://www.yahoo.com/yelp.html#", $BAD);
check("http://www.yahoo.com/yelp.html#\"", $BAD);
check("https://www.yahoo.com/", $GOOD);
check("ftp://www.yahoo.com/", $GOOD);
check("ftp://www.yahoo.com/hello", $GOOD);
check("demo.txt", $GOOD);
check("demo/hello.txt", $GOOD);
check("demo/hello.txt?query=hello#fragment", $GOOD);
check("/cgi-bin/query?query=hello#fragment", $GOOD);
check("/demo.txt", $GOOD);
check("/hello/demo.txt", $GOOD);
check("hello/demo.txt", $GOOD);
check("/", $GOOD);      # Document/anonymous-ftp root of current system
check("//", $BAD);
check("", $GOOD);       # Reference to beginning of this document.
check("#here", $GOOD);  # Reference to location "here" of this document.
print "Test ended, all errors reported.\n";