home *** CD-ROM | disk | FTP | other *** search
/ linuxmafia.com 2016 / linuxmafia.com.tar / linuxmafia.com / pub / linux / network / domain-check < prev    next >
Text File  |  2015-02-02  |  23KB  |  591 lines
  1. #!/usr/bin/perl -ws
  2. # Created by Ben Okopnik on Thu Jun 28 09:11:52 EDT 2007
  3. #
  4. # Copyright (C) 2007 Ben Okopnik <ben@okopnik.com>
  5. # Copyright (C) 2007 Ben Okopnik <ben@okopnik.com>
  6. # Copyright (C) 2015 Jesse Monroy <jesse650@gmail.com>
  7. # This program is free software; you can redistribute it and/or modify
  8. # it under the terms of the GNU General Public License as published by
  9. # the Free Software Foundation; either version 2 of the License, or
  10. # (at your option) any later version.
  11. #
  12. # This program is distributed in the hope that it will be useful,
  13. # but WITHOUT ANY WARRANTY; without even the implied warranty of
  14. # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  15. # GNU General Public License for more details.
  16.  
  17. =pod
  18. ################################## Changelog ##############################
  19. 02/03/15 02-56 v4.4
  20. # Contributor Jesse Monroy added a new regex to handle all-new date 
  21. # format now being issued for .org and .info domains.
  22.  
  23. 09/20/09 19:47 v4.3
  24. * Added a new regex based on daum.net; modified existing regex for cdn1.net
  25. (Sukbum Hong is working hard to earn that "Gold Star" contributor status! :)
  26.  
  27. 06/20/09 13:10 v4.2
  28. * Added a 'retries_max' feature for unreliable domains (thanks again to
  29. Sukbum Hong for the suggestion). This has resulted in my list of
  30. "problem domains" becoming significantly smaller. Also added '-w' to force
  31. "whois" instead of "jwhois"; some domains (e.g., the entire ".jobs" kit)
  32. require this.
  33.  
  34. 06/18/09 21:59 v4.1
  35. * Added .co.jp - very odd format for expirations. Thanks, Sukbum Hong!
  36.  
  37. 12/30/08 12:33 v4.0
  38. * Hostfile parsing is now a bit more robust (tolerant of comments and blanks
  39. in the host list file.) Thanks to Eric S. Raymond for the pointer!
  40.  
  41. 11/09/08 09:55 v3.9
  42. * North Koreans (silently) switched their WHOIS and now use an invalid year
  43. (9999.) This crashes 'timegm()' - so I've added a "ridiculous year" detector.
  44.  
  45. 10/22/08 09:33 v3.8
  46. * Added several Korean formats - 'gabia.com', 'yesnic.com', 'cfolder.net'.
  47. Thanks, Sukbum Hong!
  48.  
  49. 08/27/08 19:55 v3.7
  50. * Tweaked for the PairNIC date format. Thanks to Janek Hellqvist for the
  51. heads-up!
  52.  
  53. 07/27/08 22:33 v3.6
  54. * Added a .ca "special": 'Renewal date:'
  55.  
  56. 11/05/07 21:01 v3.5
  57. * Tweaked to resolve .cz ("expire:" along with "expires:")
  58.  
  59. 09/25/07 12:27 v3.4
  60. * Tweaked regexes to include the ".name" date syntax.
  61.  
  62. 08/15/07  1:06 v3.3
  63. * Added a bit more CLI error checking (trips off on '-d foo.com', etc.)
  64.  
  65. 08/14/07 23:03 v3.2
  66. * Polished the regexen based on Rick Moen's list of 270 TLDs
  67. * Wrapped the date-calc section in an eval for cases where the date is past
  68.     the Unix "death boundary" (18-Jan-2038)
  69.  
  70. 08/08/07 23:26 v3.1
  71. * Added another regex to parse the weird structure of 'extragalactic.net';
  72.     modified another regex slightly to accomodate 'expire date' for 'nic.it'.
  73.  
  74. 07/29/07  1:26 v3.0
  75. * MAJOR REVISION:
  76.     o The format of the 'domain-list' file has been changed, although the
  77.       old format is still valid. You can now add the name of the host for
  78.       'whois' to use as the second argument on the line; however, using the
  79.       '-s' command line argument will force all lookups to be done via the
  80.       specified host.
  81.     o Fixed up a number of regexen for the 'jwhois' differences
  82.  
  83. 07/28/07  0:41 - v2.2
  84. * Added 'jwhois' as the preferred option, with a warning if it's not
  85.     installed. Caching for 'jwhois' is disabled when '-X' is in effect;
  86.     '-H' is no longer a hard-wired argument to 'whois' ('jwhois' doesn't
  87.     support it), but is still appended if 'whois' is used.
  88. * Tweaked a couple of the regexen to process new TLDs (.fi, .ly, etc.)
  89. * Giving serious thought to modifying the format of the -F files; it would
  90.     be nice to be able to specify the whois server for individual domains.
  91.  
  92. 07/20/07  9:36 - v2.1
  93. * Added a bunch of tracing/debugging statements to the date parser, making
  94.     the '-X' option much more useful
  95. * Built a 'switch-case' structure around the parser so that only one regex
  96.     would apply to any given host
  97. * Added a '-H' argument to 'whois' ("elide legal disclaimer") to make
  98.     debugging output less annoying (and maybe speed things up fractionally)
  99. * Made the 'no expiration date found' error into a non-fatal warning (used
  100.     to break list processing)
  101. * Modified the output format slightly (warnings now appear on the same line
  102.     as the domain name)
  103. * Domains without a registrar will no longer be omitted from the mailed
  104.     notifications
  105.  
  106. 07/19/07 22:28 - v2.0
  107. * Now parsing .ci domains as well (millions of people cheer, world peace
  108.     can't be far away now...)
  109.  
  110. 07/19/07 20:54 - v1.9
  111. * Added a little regex-fu to accept lines that have whitespace at the end
  112. * Added a Big Sekrit Option ('-X' - shhh, don't tell anybody!) for debugging
  113.  
  114. 07/19/07 11:56 - v1.8
  115. * Lots and lots of fixes for many different TLDs; much mangling of regexen.
  116.     Now handles many more expiration date types than before. Most
  117.     importantly, domains that don't list a registrar will now be displayed
  118.     anyway; people probably know where to send their money, but not
  119.     necessarily _when._
  120.  
  121. 07/04/07 12:28 - v1.7
  122. * Scrapped previous approach to the .org delay; the .orgs are now sorted to
  123.     the end of the domain list and all except the first one wait 20 seconds.
  124. * Added a cute little time ticker to the delay routine, just because. :)
  125.  
  126. 07/03/07  1:27 - v1.6
  127. * Added a rate limiter (3/minute) for .org domains
  128.  
  129. 06/30/07 18:34 - v1.5
  130. * Added a "domain not parseable; please report" warning
  131. * Added an "Unable to read 'whois' info" warning for the 'fgets: connection
  132.     reset by peer' error.
  133. * All expiration warnings are now sent as one email instead of one per
  134.     domain; ditto the expired domains notifications.
  135. * The 'printf' for the 'SKIPPED' error was ignoring the '-q' option; fixed
  136.  
  137. 06/30/07  8:19 - v1.4
  138. * Removed dependency on File::Find; searching PATH 'manually'
  139. * Added an 'exit 1' to the silent failure mode of 'croak'
  140.  
  141. 06/30/07  7:06 - v1.3
  142. * Improved the date-parsing regexes (the numerical months part can now only
  143.     match '01-12' instead of 'any two digits'); this should increase the
  144.     reliability of resolving 'dd-mm-yyyy' vs. 'mm-dd-yyyy' somewhat.
  145. * More accurate reporting for the 'SKIPPED' error (now shows exact reason)
  146. * Fixed the regexes that I screwed up while adding the Dotster extension
  147. * Added a '-v' option
  148.  
  149. 06/29/07 18:54 - v1.2
  150. * Got rid of an unnecessary system dependency ('which') - 'File::Find' is a
  151.     bit clunky, but better than depending on unknowns...
  152. * Another date-processing regex (ISOC-IL: 'validity: 29-06-2007')
  153.  
  154. 06/29/07 17:07 - v1.1
  155. * Modified output format to include both exp. date and days remaining
  156. * Added another date-processing regex (DOTSTER: 'Expires on: 29-Jun-07')
  157.  
  158. 06/29/07 15:06 - v1.0
  159. I'm finally willing to admit that this script is usable. :) Recent changes
  160. include:
  161.  
  162. * Parsing routine for "2007/08/12" date format
  163. * 'croak' notifies admin of problems encountered in silent mode
  164. * Added a fallback email address for 'croak'
  165. * Fixed GMT parsing routine miscalc (thanks to Rick Moen for the heads up)
  166.  
  167. For Nosy Nellies only: *Yes*, I'm aware of the various '*Whois.pm' modules
  168. on CPAN. None of them do what I want; the one that comes closest
  169. (Net::XWhois) hasn't been maintained since 2001 and only covers a smallish
  170. subset of what I want. No, I'm not interested in taking it over and
  171. maintaining it; I've got enough to do as it is.
  172.  
  173. ###########################################################################
  174. =cut
  175.  
  176. use strict;
  177. use Time::Local;
  178. $|++;
  179.  
  180. # Command-line variables
  181. our ($d, $e, $F, $h, $q, $r, $s, $v, $w, $x, $X);
  182.  
  183. ### FALLBACK ADDRESS FOR NOTIFICATION ############
  184. my $address = 'root@localhost';
  185. ##################################################
  186.  
  187. my ($name) = $0 =~ /([^\/]+)$/;
  188.  
  189. my $usage =<<"+EoT+";
  190. Usage: $name [-e=email] [-x=expir_days] [-q] [-h] <-d=domain_name|-F=domainfile>
  191.  
  192.   -d=domain        : Domain to analyze
  193.   -e=email_address : Send a warning message by email
  194.   -F=domain_list   : File with a list of domains, one per line
  195.   -h               : Print this message
  196.   -q               : Don't print to the console (REQUIRES '-e' OPTION)
  197.   -r=max_retries   : Change the maximum number of retries (default: 3)
  198.   -s=whois server  : Use alternate whois server
  199.   -v               : Display current version of this script
  200.   -x=days          : Change default (30d) expiration interval (REQUIRES '-e' OPTION)
  201.   -w               : Use 'whois' in preference to 'jwhois' (some domains need this)
  202.  
  203. +EoT+
  204.  
  205. my $retries = 0;
  206. my $max_retries = $r || 3;
  207.  
  208. # Locate 'whois' or (preferred) 'jwhois'
  209. my ($whois) = grep -e, map "$_/jwhois", split /:/, $ENV{PATH};
  210. ($whois) = grep -e, map "$_/whois", split /:/, $ENV{PATH} unless $whois;
  211. die "'whois'|'jwhois' not found in path.\n" unless $whois;
  212. if ($whois =~ m#/whois$#){
  213.     # $q || print "You really should install 'jwhois'; it gives better results.\n";
  214.     # Turn down the noise (minimal output option - only works with 'whois')
  215.     $whois .= " -H";
  216. }
  217. else {
  218.     # Turn off caching for 'jwhois' if the debug option is on
  219.     $whois .= " -f" if $X;
  220. }
  221.  
  222. # Force 'whois' if requested
  223. $whois = "/usr/bin/whois" if $w;
  224.  
  225. # Find a mail client (mutt or mailx)
  226. my ($mail) = grep -e, map "$_/mutt", split /:/, $ENV{PATH};
  227. # Switch Mutt into 'mailx' mode if found
  228. if ($mail){
  229.     $mail .= " -x";
  230. }
  231. else {
  232.     ($mail) = grep -e, map "$_/mailx", split /:/, $ENV{PATH};
  233. }
  234. die "No 'mailx' or 'mutt' (mail client) found in path.\n" unless $mail;
  235.  
  236. # Read the version number at the top of the changelog
  237. if ($v){
  238.     seek DATA, 0, 0;
  239.     while (<DATA>){
  240.         if (m[^\d+/\d+/\d+[^v]+v([0-9.]+)]){
  241.             print "Version: $1\nCopyright (C) 2007 Ben Okopnik <ben\@okopnik.com>\n\n";
  242.             exit 0;
  243.         }
  244.     }
  245. }
  246.  
  247. # Email admin if '-q' is on; otherwise, just exit with the error
  248. sub croak {
  249.     if ($q){
  250.         # If '-e' wasn't specified, use the fallback address
  251.         $e ||= $address;
  252.  
  253.         # No place to send an error if this fails... :)
  254.         open Mail, "|$mail -s 'WARNING: $name script error' $e";
  255.         print Mail "$name [" . localtime() . "]: ", $_[0];
  256.         close Mail;
  257.  
  258.         exit 1;
  259.     }
  260.     else {
  261.         die $_[0];
  262.     }
  263. }
  264.  
  265. # Display the help output if requested or in case of incorrect usage
  266. die "$usage\n" if $h;
  267. die "\n*ERROR: '$name' requires an email address with the '-q' and the '-x' options*\n\n$usage" if ($q || $x) && ! $e;
  268. die "\n*ERROR: '$name' requires either a domain name or a domain list as an argument*\n\n$usage" if ! $d && ! $F;
  269. die "\n*ERROR: Please make sure you're using correct syntax (i.e., '-d=domain_name')*\n\n$usage" if (defined $d && $d =~ /^1$/) || (defined $F && $F =~ /^1$/) || (defined $s && $s =~ /^1$/) || (defined $r && $r !~ /^\d+$/);
  270.  
  271. # Set default notification interval to 30 days
  272. if ($x){
  273.     croak "Expiration interval must be specified in days (0-9999).\n"
  274.         unless $x =~ /^\d{1,4}$/;
  275. }
  276. else {
  277.     $x = 30;
  278. }
  279.  
  280. # Read the domain list file
  281. my @domains;
  282. if ($F){
  283.     croak "$F is not a regular file\n" unless -f $F;
  284.     croak "Can't read $F\n" unless -r _;
  285.     # Open the file if it exists
  286.     open F or croak "$F: $!\n";
  287.     while (<F>){
  288.         # Skip blank lines; ignore comments
  289.         next if /^\s*(?:#|$)/;
  290.         # Strip preceding and following blanks
  291.         s/^\s*(.*?)\s*$/$1/;
  292.  
  293.         # Separate domain and server if they exist
  294.         my (@line) = split;
  295.         for (@line){
  296.             # Strip URI method and any terminal '/'s
  297.             s#^.*://##;
  298.             s#/$##;
  299.         }
  300.         push @domains, [ @line ];
  301.     }
  302.     close F;
  303. }
  304.  
  305. # Having a '-F' AND a '-d' is explicitly not excluded
  306. if ($d){
  307.     # Strip URI method and any terminal '/'s
  308.     $d =~ s#^.*://##;
  309.     $d =~ s#/$##;
  310.     push @domains, [ $d ];
  311. }
  312.  
  313. # Set the server if specified (this REPLACES any servers defined
  314. # in the domain-list file)
  315. if ($s){
  316.     $_ -> [1] = $s for @domains;
  317. }
  318.  
  319. # Sort list to push .orgs to the end; ASCIIbetical sort otherwise
  320. @domains = sort { ($a->[0] =~ /\.org$/i) <=> ($b->[0] =~ /\.org$/i) || $a->[0] cmp $b->[0] } @domains;
  321.  
  322. # Trim strings to specified length; return '**UNKNOWN**' if undef
  323. sub trim {
  324.     defined $_[0] || return "**UNKNOWN**";
  325.     substr($_[0], 0, $_[1]);
  326. }
  327.  
  328. # Lookup list for month number->name conversion
  329. my (%mth,%mlookup);
  330. @mth{map sprintf("%02d", $_), 1..12} = qw/jan feb mar apr may jun jul aug sep oct nov dec/;
  331. # Lookup list for month name->abbrev conversion
  332. @mlookup{qw/january february march april may june july august september october november december/} =
  333.     (qw/jan feb mar apr may jun jul aug sep oct nov dec/) x 2;
  334.  
  335. ########################## DATA COLLECTION SECTION #############################
  336.  
  337. # Process the domain list
  338. my ($seen, %list);
  339. TOP: for my $line (@domains){
  340.     next TOP if $line =~ /^\s*(?:#|$)/;
  341.  
  342.     my ($host, $server) = @{$line};
  343.  
  344.     my $opt = $server ? "-h $server" : "";
  345.  
  346.     $q || print "\b\nProcessing $host... ";
  347.  
  348.     # Delay to avoid triggering rate limiter
  349.     if ($host =~ /\.org$/i){
  350.         $q || print "(NOTE: Subsequent ORG queries will be delayed by 20 seconds each due to rate limiting) "
  351.             unless $seen;
  352.         # Show the cute little time ticker :)
  353.         if ($seen++){
  354.             my @chars = split //, '|/-\\';
  355.             for (0 .. 19){
  356.                 $q || print $chars[$_ % 4], "\b";
  357.                 sleep 1;
  358.             }
  359.             print " \b";
  360.         }
  361.     }
  362.  
  363.     my $out;
  364.     while (1){    # Start the 'retry' block
  365.  
  366.         # Execute the query, save as a single string
  367.         open Who, "$whois $opt $host|" or croak "Error executing $whois: $!\n";
  368.         $out = do { local $/; <Who> };
  369.         close Who;
  370.  
  371.         if (!$out || $out !~ /domain/i){
  372.             # Whoops, the lookup failed! If we're using "jwhois", ignore the cache -
  373.             # no point to repeated lookups otherwise.
  374.             if ($whois =~ m#/jwhois$#){
  375.                 $whois .= " -f";
  376.             }
  377.  
  378.             # Skip the retries if we're troubleshooting, or if we've exceeded MAX.
  379.             if (($retries <= $max_retries) && !$X){
  380.                 $retries++;
  381.                 $q || print "Lookup failed; retrying ($retries of $max_retries max retries)\n";
  382.                 next;
  383.             }
  384.             else {
  385.                 $q || print "Unable to read 'whois' info for $host. Skipping... ";
  386.                 next TOP;
  387.             }
  388.         }
  389.         else {
  390.             $retries = 0;
  391.             last;
  392.         }
  393.     } # End of retry block
  394.  
  395.     # Freak out and run away if there's no match
  396.     if ($out =~ /no match/i){
  397.         $q || print "No match for $host!\n";
  398.         next;
  399.     }
  400.     # Ditto for bad hostnames
  401.     if ($out =~ /No whois server is known for this kind of object/i){
  402.         $q || print "'whois' doesn't recognize this kind of object. ";
  403.         next;
  404.     }
  405.  
  406.     # Get rid of the DOS formatting
  407.     $out =~ tr/\cM//d;
  408.  
  409.     # Convert multi-line 'labeled block' output to 'Label: value'
  410.     my $debug;
  411.     if ($out =~ /registrar:\n/i){
  412.         $out =~ s/:\n(?!\n)/: /gsm;
  413.         $debug .= "matched on line " . (__LINE__ - 1) . ": Multi-line 'labeled block'\n";
  414.     }
  415.  
  416.     # Date processing; this is the heart of the program. Desired date format is '29-jun-2007'
  417.     # 'Fri Jun 29 15:16:00 EDT 2007'
  418.     if ($out =~ s/(date:\s*| on:\s*)[A-Z][a-z]+\s+([a-zA-Z]{3})\s+(\d+).*?(\d+)\s*$/$1$3-$2-$4/igsm){
  419.         $debug .= "matched on line " . (__LINE__ - 1) . ": 'Fri Jun 29 15:16:00 EDT 2007'\n";
  420.     }
  421.     # '29-Jun-07'
  422.     elsif ($out =~ s/(date:\s*| on:\s*)(\d{2})[\/ -](...)[\/ -](\d{2})\s*$/$1$2-$3-20$4/igsm){
  423.         $debug .= "matched on line " . (__LINE__ - 1) . ": '29-Jun-07'\n";
  424.     }
  425.     # '2007-Jun-29'
  426.     elsif ($out =~ s/[^\n]*(?:date| on|expires on\.+):\s*(\d{4})[\/-](...)[\/-](\d{2})\.?\s*$/Expiration date: $3-$2-$1/igsm){
  427.         $debug .= "matched on line " . (__LINE__ - 1) . ": '2007-Jun-29'\n";
  428.     }
  429.     # '2007/06/29'
  430.     elsif ($out =~ s/(?:valid |renewal-|expir(?:e|es|y|ation)\s*)(?:date|on)?[ \t.:]*\s*(\d{4})(?:[\/-]|\. )(0[1-9]|1[0-2])(?:[\/-]|\. )(\d{2})(?:\.?\s*[0-9:.]*\s*\w*\s*|\s+\([-A-Z]+\)?)$/Expiration date: $3-$mth{$2}-$1/igsm){
  431.         $debug .= "matched on line " . (__LINE__ - 1) . ": '2007/06/29'\n";
  432.     }
  433.     # '[State]                         Connected (2009/11/30)' - .co.jp
  434.     elsif ($out =~ s/\[State\]\s+Connected\s+\((\d{4})(?:[\/-]|\. )(0[1-9]|1[0-2])(?:[\/-]|\. )(\d{2})\)\s*$/Expiration date: $3-$mth{$2}-$1/igsm){
  435.         $debug .= "matched on line " . (__LINE__ - 1) . ": [State]     Connected (2009/11/30)\n";
  436.     }
  437.     # '29-06-2007'
  438.     elsif ($out =~ s/(?:validity:|expir(?:y|ation) date:|expire:|expires? (?:on:?|on \([dmy\/]+\):|at:))\s*(\d{2})[\/.-](0[1-9]|1[0-2])[\/.-](\d{4})\s*[0-9:.]*\s*\w*\s*$/Expiration date: $1-$mth{$2}-$3/igsm){
  439.         $debug .= "matched on line " . (__LINE__ - 1) . ": '29-06-2007'\n";
  440.     }
  441.     # '[Expires on]     2007-06-29' (.jp, .ru, .ca); 'Valid Date     2016-11-02 04:21:35 EST' (yesnic.com); 'Domain Expiration Date......: 2009-01-15 GMT.' (cfolder.net)
  442.     elsif ($out =~ s/(?:valid[- ]date|(?:renewal|expiration) date(?::|\.+:)|paid-till:|\[expires on\]|expires on ?:|expired:)\s*(\d{4})[\/.-](0[1-9]|1[0-2])[\/.-](\d{2})(?:\s*[0-9:.]*\s*\w*\s*|T[0-9:]+Z| GMT\.)$/Expiration date: $3-$mth{$2}-$1/igsm){
  443.         $debug .= "matched on line " . (__LINE__ - 1) . ": '[Expires on]     2007-06-29' (.jp, .ru)\n";
  444.     }
  445.     # 'expires:     June  29[, ]+2007' (.is, PairNIC); 'Record expires on       JULY      21, 2016' (gabia.com)
  446.     elsif ($out =~ s/(?:expires:|expires on)\s*([A-Z][a-z]+)\s+(\d{1,2})(?:\s|,)+(\d{4})\s*$/"Expiration date: " . sprintf("%02d", $2) . "-" . $mlookup{"\L$1\E"} . "-$3"/igsme){
  447.         $debug .= "matched on line " . (__LINE__ - 1) . ": 'expires:     June  29 2007' (.is)\n";
  448.     }
  449.     # 'renewal: 29-June-2007'
  450.     elsif ($out =~ s/renewal:\s*(\d{1,2})[\/ -]([A-Z][a-z]+)[\/ -](\d{4})\s*$/"Expiration date: $1-" . $mlookup{"\L$2\E"} . "-$3"/igsme){
  451.         $debug .= "matched on line " . (__LINE__ - 1) . ": 'renewal: 29-June-2007' (.ie)\n";
  452.     }
  453.     # 'Record expires on........: 06-Mar-2013 EDT.' (daum.net)
  454.     elsif ($out =~ s/record expires on\.+:\s*(\d{1,2})[\/ -]([A-Z][a-z][a-z])[\/ -](\d{4})\s*[A-Z]+\.$/"Expiration date: $1-\l$2-$3"/igsme){
  455.         $debug .= "matched on line " . (__LINE__ - 1) . ": 'Record expires on........: 06-Mar-2013 EDT.' (daum.net)\n";
  456.     }
  457.     # 'expire:         20080315' (.cz, .ke)
  458.     elsif ($out =~ s/expir[ey]:\s*(\d{4})(\d{2})(\d{2})\s*$/Expiration date: $3-$mth{$2}-$1/igsm){
  459.         $debug .= "matched on line " . (__LINE__ - 1) . ": 'expire:         20080315' (.cz, .ke)\n";
  460.     }
  461.     # 'domain_datebilleduntil: 2007-06-29T00:00:00+12:00' (.nz)
  462.     elsif ($out =~ s/domain_datebilleduntil:\s*(\d{4})[-\/](\d{2})[-\/](\d{2})T[0-9:.+-]+\s*$/Expiration date: $3-$mth{$2}-$1/igsm){
  463.         $debug .= "matched on line " . (__LINE__ - 1) . ": 'domain_datebilleduntil: 2007-06-29T00:00:00+12:00' (.nz)\n";
  464.     }
  465.     # '29 Jun 2007 11:58:42 UTC' (.coop)
  466.     elsif ($out =~ s/(?:expir(?:ation|y) date|expire[sd](?: on)?)[:\] ]\s*(\d{2})[\/ -](...)[\/ -](\d{4})\s*[0-9:.]*\s*\w*\s*$/Expiration date: $1-\L$2\E-$3/igsm){
  467.         $debug .= "matched on line " . (__LINE__ - 1) . ": '29 Jun 2007 11:58:42 UTC' (.coop)\n";
  468.     }
  469.     # 'Record expires on 17/8/2100' (.hm, fi)
  470.     elsif ($out =~ s/(?:expires(?: on|:))\s*(\d{2})[\/.-]([1-9]|0[1-9]|1[0-2])[\/.-](\d{4})\s*[0-9:.]*\s*\w*\s*$/"Expiration date: $1-".$mth{sprintf "%02d", $2} . "-$3"/iegsm){
  471.         $debug .= "matched on line " . (__LINE__ - 1) . ": 'Record expires on 17/8/2100' (.hm)\n";
  472.     }
  473.     # 'Expires on..............: Sat, Mar 29, 2008'
  474.     elsif ($out =~ s/expires on\.*:\s*(?:[SMTWF][uoehra][neduit]),\s+([A-Z][a-z]+)\s+(\d{1,2}),\s+(\d{4})\s*$/"Expiration date: " . sprintf("%02d", $2) . "-\L$1-$3"/iegsm){
  475.         $debug .= "matched on line " . (__LINE__ - 1) . ": 'Expires on..............: Sat, Mar 29, 2008'\n";
  476.     }
  477.     # 'Registry Expiry Date: 2016-08-06T04:00:00Z' (.org)
  478.         elsif ($out =~ s/Registry Expiry Date: ([0-9]{4})-([0-9]{2})-([0-9]{2})T/Expiration date: $3-$mth{$2}-$1/igsm){
  479.                 #print "\nFOUND DATE: $1 $2 $3\n";
  480.             $debug .= "matched on line " . (__LINE__ - 1) . ": '(.org)\n";
  481.         }
  482.     else {
  483.         $debug = "No regexes matched.\n";
  484.     }
  485.  
  486.     # Collect the data from each query
  487.     for (split /\n/, $out){
  488.         # Clip pre- and post- blanks
  489.         s/^\s*(.*?)\s*$/$1/;
  490.         # Squash repeated tabs and spaces
  491.         tr/ \t//s;
  492.  
  493.         # This is where it all happens - regexes to capture registrar and expiration
  494.         $list{$host}{Registrar} ||= $1 if /(?:maintained by|registration [^:]*by|authorized agency|registrar)(?:\s*|_)(?:name|id|of record)?:\s*(.*)$/i;
  495.         $list{$host}{Expires} ||= $1 if /(?:expires(?: on)?|expir(?:e|y|ation) date\s*|renewal(?:[- ]date)?)[:\] ]\s*(\d{2}-[a-z]{3}-\d{4})/i;
  496.     }
  497.  
  498.     # Assign default message if no registrar was found
  499.     $list{$host}{Registrar} ||= "[[[ No registrar found ]]]";
  500.     
  501.     $q || print "No expiration date found in 'whois' output. Please report this domain to the author!"
  502.         unless defined $list{$host}{Expires};
  503.  
  504.     # Debug option (activated by '-X'); exits here with parsed 'whois' output
  505.     $debug .= "Registrar: $list{$host}{Registrar}\n" if defined $list{$host}{Registrar};
  506.     $debug .= "Expires: $list{$host}{Expires}\n" if defined $list{$host}{Expires};
  507.     die "\n", "=" x 70, "\n$out\n", "=" x 70, "\n$debug", "=" x 70, "\n" if $X;
  508. }
  509.  
  510. $q || print "\n";
  511.  
  512. ########################## DATA ANALYSIS SECTION #############################
  513.  
  514. # Get current time snapshot in UTC
  515. my $now = timegm(gmtime);
  516.  
  517. # Convert dates to UTC epoch seconds; *will* fail on 19 Jan 2038. :)
  518. my %months;
  519. @months{qw/jan feb mar apr may jun jul aug sep oct nov dec/} = 0..11;
  520.  
  521. # Print the header if '$q' is off and there's content in %list
  522. $q || %list && printf "\n\n%-24s%-36s%s\n%s\n", "Host", "Registrar", "Exp.date/Days left", "=" x 78;
  523.  
  524. # Process the collected data
  525. my (%exp, %end);
  526. for my $k (sort keys %list){
  527.     unless (defined $list{$k}{Expires}){
  528.         $q || printf "%-32s%s\n", trim($k, 31), "*** SKIPPED (missing exp. date) ***";
  529.         delete $list{$k};
  530.         next;
  531.     }
  532.     my @chunks = split /-/, $list{$k}{Expires};
  533.     my $epoch;
  534.  
  535.     # The "date is ridiculously far in the future" interceptor
  536.     if ($chunks[2] > 2038){
  537.         $q || print "**** NOTE: Year out of range - date will NOT be calculated correctly! ****\n";
  538.         # Set epoch to EPOCH_MAX
  539.         $epoch = 2147212800;
  540.     }
  541.     else {
  542.         eval { $epoch = timegm(0, 0, 0, $chunks[0], $months{lc $chunks[1]}, $chunks[2] - 1900) };
  543.         if ($@){
  544.             $q || print "$@\n";
  545.             if ($@ =~ /too big/){
  546.                 $q || print "**** NOTE: Date past 19-Jan-2038 - date will NOT be calculated correctly! ****\n";
  547.             }
  548.             # Set epoch to EPOCH_MAX
  549.             $epoch = 2147212800;
  550.         }
  551.     }
  552.     my $diff = int(($epoch - $now) / 86400);
  553.     $q || printf "%-24s%-36s%-12s/%5s\n", trim($k, 23), trim($list{$k}{Registrar}, 35),
  554.         $list{$k}{Expires}, $diff;
  555.  
  556.     # Prepare alerts if domain is expired or the expiration date is <= $x days
  557.     if ($e && ($diff <= $x)){
  558.         if ($diff <= 0){
  559.             $exp{$k} = -$diff;
  560.         }
  561.         else {
  562.             $end{$k} = $diff;
  563.         }
  564.     }
  565. }
  566.  
  567. # Report expired domains
  568. if (%exp){
  569.     open Mail, "|$mail -s '$name: Expired domains' $e" or croak "$mail: $!\n";
  570.     print Mail "According to 'whois', the following domains have expired:\n\n";
  571.     for my $x (sort { $exp{$a} <=> $exp{$b} } keys %exp){
  572.         my $s = $exp{$x} == 1 ? "" : "s";
  573.         print Mail "$x ($exp{$x} day$s ago)\n";
  574.     }
  575.     close Mail;
  576. }
  577.  
  578. # Report domains that will expire within the '-x' period
  579. if (%end){
  580.     open Mail, "|$mail -s '$name: Domain expiration warning ($x day cutoff)' $e" or croak "$mail: $!\n";
  581.     print Mail "According to 'whois', these domains will expire soon:\n\n";
  582.     for my $d (sort { $end{$a} <=> $end{$b} } keys %end){
  583.         my $s = $end{$d} == 1 ? "" : "s";
  584.         print Mail "$d (in $end{$d} day$s)\n";
  585.     }
  586.     close Mail;
  587. }
  588.  
  589. __END__
  590.  
  591.