#!/usr/bin/perl

# This chunk of stuff was generated by App::FatPacker. To find the original
# file's code, look for the end of this BEGIN block or the string 'FATPACK'
BEGIN {
my %fatpacked;

$fatpacked{"App/Yabsm.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_YABSM';
  #  Author:    Nicholas Hubbard
  #  Copyright: Nicholas Hubbard
  #  License:   GPL_3
  #  WWW:       https://github.com/NicholasBHubbard/Yabsm
  
  #  This module contains the program's &main subroutine.
  
  use strict;
  use warnings;
  use v5.34.0;
  
  package App::Yabsm;
  
  our $VERSION = '3.15.2';
  
  use App::Yabsm::Command::Daemon;
  use App::Yabsm::Command::Config;
  use App::Yabsm::Command::Find;
  
  sub usage {
      return <<'END_USAGE';
  usage: yabsm [--help] [--version] [<COMMAND> <ARGS>]
  
  See '$ man yabsm' for a detailed overview.
  
  Commands:
  
    <daemon|d> [--help] [start] [stop] [restart] [status] [init]
  
    <config|c> [--help] [check ?file] [ssh-check <SSH_BACKUP>] [ssh-key]
               [yabsm-user-home] [yabsm_dir] [subvols] [snaps] [ssh_backups]
               [local_backups] [backups]
  
    <find|f>   [--help] [<SNAP|SSH_BACKUP|LOCAL_BACKUP> <QUERY>]
  
  END_USAGE
  }
  
  sub main {
  
      # This is the toplevel subroutine of Yabsm. It is invoked directly from
      # bin/yabsm with @ARGV as its args.
  
      my $cmd = shift @_ or die usage();
  
      my @args = @_;
  
      if ($cmd =~ /^(-h|--help)$/) { print usage() and exit 0 }
      if ($cmd eq '--version')     { say $VERSION  and exit 0 }
  
      # Provide user with command abbreviations
      if    ($cmd eq 'd') { $cmd = 'daemon' }
      elsif ($cmd eq 'c') { $cmd = 'config' }
      elsif ($cmd eq 'f') { $cmd = 'find'   }
  
      # All 3 subcommands have their own &main
      if    ($cmd eq 'daemon') { $cmd = \&App::Yabsm::Command::Daemon::main }
      elsif ($cmd eq 'config') { $cmd = \&App::Yabsm::Command::Config::main }
      elsif ($cmd eq 'find'  ) { $cmd = \&App::Yabsm::Command::Find::main   }
      else {
          die usage();
      }
  
      $cmd->(@args);
  
      exit 0;
  }
  
  1;
APP_YABSM

$fatpacked{"App/Yabsm/Backup/Generic.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_YABSM_BACKUP_GENERIC';
  #  Author:    Nicholas Hubbard
  #  Copyright: Nicholas Hubbard
  #  License:   GPL_3
  #  WWW:       https://github.com/NicholasBHubbard/Yabsm
  
  #  Functions needed for both SSH and local backups.
  
  use strict;
  use warnings;
  use v5.34.0;
  
  package App::Yabsm::Backup::Generic;
  
  use App::Yabsm::Tools qw( :ALL );
  use App::Yabsm::Config::Query qw( :ALL );
  
  use App::Yabsm::Snapshot qw(take_snapshot
                              delete_snapshot
                              current_time_snapshot_name
                              is_snapshot_name
                             );
  
  use Carp q(confess);
  use File::Temp;
  use File::Basename qw(basename);
  use Feature::Compat::Try;
  
  use Exporter 'import';
  our @EXPORT_OK = qw(take_tmp_snapshot
                      tmp_snapshot_dir
                      take_bootstrap_snapshot
                      maybe_take_bootstrap_snapshot
                      bootstrap_snapshot_dir
                      the_local_bootstrap_snapshot
                      bootstrap_lock_file
                      create_bootstrap_lock_file
                      is_backup_type_or_die
                     );
  
                   ####################################
                   #            SUBROUTINES           #
                   ####################################
  
  sub take_tmp_snapshot {
  
      # Take a tmp snapshot for $backup. The tmp snapshot is the snapshot that is
      # actually replicated in an incremental backup with 'btrfs send -p'.
  
      arg_count_or_die(4, 4, @_);
  
      my $backup      = shift;
      my $backup_type = shift;
      my $tframe      = shift;
      my $config_ref  = shift;
  
      my $tmp_snapshot_dir = tmp_snapshot_dir(
          $backup,
          $backup_type,
          $tframe,
          $config_ref,
          DIE_UNLESS_EXISTS => 1
      );
  
      # Remove any old tmp snapshots that were never deleted because of a failed
      # incremental backup attempt.
      opendir my $dh, $tmp_snapshot_dir or confess("yabsm: internal error: cannot opendir '$tmp_snapshot_dir'");
      my @tmp_snapshots = grep { is_snapshot_name($_, ALLOW_BOOTSTRAP => 0) } readdir($dh);
      closedir $dh;
      map { $_ = "$tmp_snapshot_dir/$_" } @tmp_snapshots;
  
      # The old tmp snapshot may be in the process of being sent, which will cause
      # the deletion to fail. In this case we can just ignore the failure.
      for (@tmp_snapshots) {
          try {
              delete_snapshot($_);
          }
          catch ($e) {
              ; # do nothing
          }
      }
  
      my $mountpoint;
  
      if ($backup_type eq 'ssh')   {
          $mountpoint = ssh_backup_mountpoint($backup, $config_ref);
      }
      elsif ($backup_type eq 'local') {
          $mountpoint = local_backup_mountpoint($backup, $config_ref);
      }
      else { is_backup_type_or_die($backup_type) }
  
      return take_snapshot($mountpoint, $tmp_snapshot_dir);
  }
  
  sub tmp_snapshot_dir {
  
      # Return path to $backup's tmp snapshot directory. If passed
      # 'DIE_UNLESS_EXISTS => 1' # then die unless the directory exists and is
      # readable+writable for the current user.
  
      arg_count_or_die(4, 6, @_);
  
      my $backup      = shift;
      my $backup_type = shift;
      my $tframe      = shift;
      my $config_ref  = shift;
      my %die_unless_exists = (DIE_UNLESS_EXISTS => 0, @_);
  
      is_timeframe_or_die($tframe);
  
      if ($backup_type eq 'ssh') {
          ssh_backup_exists_or_die($backup, $config_ref);
      }
      elsif ($backup_type eq 'ssh') {
          local_backup_exists_or_die($backup, $config_ref);
      }
      else { is_backup_type_or_die($backup_type) }
  
      my $tmp_snapshot_dir = yabsm_dir($config_ref) . "/.yabsm-var/${backup_type}_backups/$backup/tmp-snapshot/$tframe";
  
      if ($die_unless_exists{DIE_UNLESS_EXISTS}) {
          unless (-d $tmp_snapshot_dir && -r $tmp_snapshot_dir) {
              my $username = getpwuid $<;
              die "yabsm: error: no directory '$tmp_snapshot_dir' that is readable by user '$username'. This directory should have been initialized when the daemon started.\n";
          }
      }
  
      return $tmp_snapshot_dir;
  }
  
  sub take_bootstrap_snapshot {
  
      # Take a btrfs bootstrap snapshot of $backup and return its path.
      # If there is already a bootstrap snapshot for $backup then delete
      # it and take a new one.
  
      arg_count_or_die(3, 3, @_);
  
      my $backup      = shift;
      my $backup_type = shift;
      my $config_ref  = shift;
  
      my $mountpoint;
  
      if ($backup_type eq 'ssh') {
          $mountpoint = ssh_backup_mountpoint($backup, $config_ref);
      }
      elsif ($backup_type eq 'local') {
          $mountpoint = local_backup_mountpoint($backup, $config_ref);
      }
      else { is_backup_type_or_die($backup_type) }
  
      if (my $bootstrap_snapshot = the_local_bootstrap_snapshot($backup, $backup_type, $config_ref)) {
          delete_snapshot($bootstrap_snapshot);
      }
  
      my $bootstrap_dir = bootstrap_snapshot_dir($backup, $backup_type, $config_ref, DIE_UNLESS_EXISTS => 1);
      my $snapshot_name = '.BOOTSTRAP-' . current_time_snapshot_name();
  
      return take_snapshot($mountpoint, $bootstrap_dir, $snapshot_name);
  }
  
  sub maybe_take_bootstrap_snapshot {
  
      # If $backup does not already have a bootstrap snapshot then take
      # a bootstrap snapshot and return its path. Otherwise return the
      # path of the existing bootstrap snapshot.
  
      arg_count_or_die(3, 3, @_);
  
      my $backup      = shift;
      my $backup_type = shift;
      my $config_ref  = shift;
  
      if (my $boot_snap = the_local_bootstrap_snapshot($backup, $backup_type, $config_ref)) {
          return $boot_snap;
      }
  
      return take_bootstrap_snapshot($backup, $backup_type, $config_ref);
  }
  
  sub bootstrap_snapshot_dir {
  
      # Return the path to $ssh_backup's bootstrap snapshot directory.
      # Logdie if the bootstrap snapshot directory does not exist.
  
      arg_count_or_die(3, 5, @_);
  
      my $backup      = shift;
      my $backup_type = shift;
      my $config_ref  = shift;
      my %or_die      = (DIE_UNLESS_EXISTS => 0, @_);
  
      is_backup_type_or_die($backup_type);
  
      if ($backup_type eq 'ssh') {
          ssh_backup_exists_or_die($backup, $config_ref);
      }
      if ($backup_type eq 'local') {
          local_backup_exists_or_die($backup, $config_ref);
      }
  
      my $bootstrap_dir = yabsm_dir($config_ref) . "/.yabsm-var/${backup_type}_backups/$backup/bootstrap-snapshot";
  
      if ($or_die{DIE_UNLESS_EXISTS}) {
          unless (-d $bootstrap_dir && -r $bootstrap_dir) {
              my  $username = getpwuid $<;
              die "yabsm: error: no directory '$bootstrap_dir' that is readable by user '$username'. This directory should have been initialized when the daemon started.\n";
          }
      }
  
      return $bootstrap_dir;
  }
  
  sub the_local_bootstrap_snapshot {
  
      # Return the local bootstrap snapshot for $backup if it exists and return
      # undef otherwise. Die if there are multiple bootstrap snapshots.
  
      arg_count_or_die(3, 3, @_);
  
      my $backup      = shift;
      my $backup_type = shift;
      my $config_ref  = shift;
  
      my $bootstrap_dir = bootstrap_snapshot_dir(
          $backup,
          $backup_type,
          $config_ref,
          DIE_UNLESS_EXISTS => 1
      );
  
      opendir my $dh, $bootstrap_dir or confess "yabsm: internal error: cannot opendir '$bootstrap_dir'";
      my @boot_snaps = grep { is_snapshot_name($_, ONLY_BOOTSTRAP => 1) } readdir($dh);
      map { $_ = "$bootstrap_dir/$_" } @boot_snaps;
      close $dh;
  
      if (0 == @boot_snaps) {
          return undef;
      }
      elsif (1 == @boot_snaps) {
          return $boot_snaps[0];
      }
      else {
          die "yabsm: error: found multiple local bootstrap snapshots for ${backup_type}_backup '$backup' in '$bootstrap_dir'\n";
      }
  }
  
  sub bootstrap_lock_file {
  
      # Return the path to the BOOTSTRAP-LOCK for $backup if it exists and return
      # undef otherwise.
  
      arg_count_or_die(3, 3, @_);
  
      my $backup      = shift;
      my $backup_type = shift;
      my $config_ref  = shift;
  
      my $rx = qr/yabsm-${backup_type}_backup_${backup}_BOOTSTRAP-LOCK/;
  
      my $lock_file = [ grep /$rx/, glob('/tmp/*') ]->[0];
  
      return $lock_file;
  }
  
  sub create_bootstrap_lock_file {
  
      # Create the bootstrap lock file for $backup. This function should be called
      # when performing the bootstrap phase of an incremental backup after checking
      # to make sure a lock file doesn't already exist. If a lock file already
      # exists we die, so check beforehand!
  
      arg_count_or_die(3, 3, @_);
  
      my $backup      = shift;
      my $backup_type = shift;
      my $config_ref  = shift;
  
      backup_exists_or_die($backup, $config_ref);
      is_backup_type_or_die($backup_type);
  
      if (my $existing_lock_file = bootstrap_lock_file($backup, $backup_type, $config_ref)) {
          die "yabsm: error: ${backup_type}_backup '$backup' is already locked out of performing a bootstrap. This was determined by the existence of '$existing_lock_file'\n";
      }
  
      # The file will be deleted when $tmp_fh is destroyed.
      my $tmp_fh = File::Temp->new(
          TEMPLATE => "yabsm-${backup_type}_backup_${backup}_BOOTSTRAP-LOCKXXXX",
          DIR      => '/tmp',
          UNLINK   => 1
      );
  
      return $tmp_fh;
  }
  
  sub is_backup_type_or_die {
  
      # Die unless $backup_type equals 'ssh' or 'local'.
  
      arg_count_or_die(1, 1, @_);
  
      my $backup_type = shift;
  
      unless ( $backup_type =~ /^(ssh|local)$/ ) {
          confess("yabsm: internal error: '$backup_type' is not 'ssh' or 'local'");
      }
  
      return 1;
  }
  
  1;
APP_YABSM_BACKUP_GENERIC

$fatpacked{"App/Yabsm/Backup/Local.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_YABSM_BACKUP_LOCAL';
  #  Author:    Nicholas Hubbard
  #  Copyright: Nicholas Hubbard
  #  License:   GPL_3
  #  WWW:       https://github.com/NicholasBHubbard/Yabsm
  
  #  Provides the &do_local_backup subroutine, which performs a single local_backup
  #  This is a top-level subroutine that is directly scheduled to be run by the
  #  daemon.
  
  use strict;
  use warnings;
  use v5.34.0;
  
  package App::Yabsm::Backup::Local;
  
  use App::Yabsm::Backup::Generic qw(take_tmp_snapshot
                                     take_bootstrap_snapshot
                                     the_local_bootstrap_snapshot
                                     bootstrap_lock_file
                                     create_bootstrap_lock_file
                                    );
  use App::Yabsm::Snapshot qw(delete_snapshot sort_snapshots is_snapshot_name);
  use App::Yabsm::Tools qw( :ALL );
  use App::Yabsm::Config::Query qw( :ALL );
  
  use File::Basename qw(basename);
  
  use Exporter qw(import);
  our @EXPORT_OK = qw(do_local_backup
                      do_local_backup_bootstrap
                      maybe_do_local_backup_bootstrap
                      the_remote_bootstrap_snapshot
                     );
  
                   ####################################
                   #            SUBROUTINES           #
                   ####################################
  
  sub do_local_backup {
  
      # Perform a $tframe local_backup for $local_backup.
  
      arg_count_or_die(3, 3, @_);
  
      my $local_backup = shift;
      my $tframe       = shift;
      my $config_ref   = shift;
  
      # We can't perform a backup if the bootstrap process is currently being
      # performed.
      if (bootstrap_lock_file($local_backup, 'local', $config_ref)) {
          return undef;
      }
  
      my $backup_dir = local_backup_dir($local_backup, $tframe, $config_ref);
  
      unless (is_btrfs_dir($backup_dir) && -r $backup_dir) {
          my $username = getpwuid $<;
          die "yabsm: error: '$backup_dir' is not a directory residing on a btrfs filesystem that is readable by user '$username'\n";
      }
  
      my $tmp_snapshot       = take_tmp_snapshot($local_backup, 'local', $tframe, $config_ref);
      my $bootstrap_snapshot = maybe_do_local_backup_bootstrap($local_backup, $config_ref);
  
      system_or_die("sudo -n btrfs send -p '$bootstrap_snapshot' '$tmp_snapshot' | sudo -n btrfs receive '$backup_dir' >/dev/null 2>&1");
  
      # @backups is sorted from newest to oldest
      my @backups = sort_snapshots(do {
          opendir my $dh, $backup_dir or confess("yabsm: internal error: cannot opendir '$backup_dir'");
          my @backups = grep { is_snapshot_name($_) } readdir($dh);
          closedir $dh;
          map { $_ = "$backup_dir/$_" } @backups;
          \@backups;
      });
      my $num_backups = scalar @backups;
      my $to_keep     = local_backup_timeframe_keep($local_backup, $tframe, $config_ref);
  
      # There is 1 more backup than should be kept because we just performed a
      # backup.
      if ($num_backups == $to_keep + 1) {
          my $oldest = pop @backups;
          delete_snapshot($oldest);
      }
      # We have not reached the backup quota yet so we don't delete anything.
      elsif ($num_backups <= $to_keep) {
          ;
      }
      # User changed their settings to keep less backups than they were keeping
      # prior.
      else {
          for (; $num_backups > $to_keep; $num_backups--) {
              my $oldest = pop @backups;
              delete_snapshot($oldest);
          }
      }
  
      return "$backup_dir/" . basename($tmp_snapshot);
  }
  
  sub do_local_backup_bootstrap {
  
      # Perform the bootstrap phase of an incremental backup for $local_backup.
  
      arg_count_or_die(2, 2, @_);
  
      my $local_backup = shift;
      my $config_ref   = shift;
  
      if (bootstrap_lock_file($local_backup, 'local', $config_ref)) {
          return undef;
      }
  
      # The lock file will be deleted when $lock_fh goes out of scope (uses File::Temp).
      my $lock_fh = create_bootstrap_lock_file($local_backup, 'local', $config_ref);
  
      if (my $local_boot_snap = the_local_bootstrap_snapshot($local_backup, 'local', $config_ref)) {
          delete_snapshot($local_boot_snap);
      }
      if (my $remote_boot_snap = the_remote_bootstrap_snapshot($local_backup, $config_ref)) {
          delete_snapshot($remote_boot_snap);
      }
  
      my $local_boot_snap = take_bootstrap_snapshot($local_backup, 'local', $config_ref);
  
      my $backup_dir_base = local_backup_dir($local_backup, undef, $config_ref);
  
      system_or_die("sudo -n btrfs send '$local_boot_snap' | sudo -n btrfs receive '$backup_dir_base' >/dev/null 2>&1");
  
      return $local_boot_snap;
  }
  
  sub maybe_do_local_backup_bootstrap {
  
      # Like &do_local_backup_bootstrap but only perform the bootstrap if it hasn't
      # been performed yet.
  
      arg_count_or_die(2, 2, @_);
  
      my $local_backup = shift;
      my $config_ref   = shift;
  
      my $local_boot_snap  = the_local_bootstrap_snapshot($local_backup, 'local', $config_ref);
      my $remote_boot_snap = the_remote_bootstrap_snapshot($local_backup, $config_ref);
  
      unless ($local_boot_snap && $remote_boot_snap) {
          $local_boot_snap = do_local_backup_bootstrap($local_backup, $config_ref);
      }
  
      return $local_boot_snap;
  }
  
  sub the_remote_bootstrap_snapshot {
  
      # Return the remote bootstrap snapshot for $local_backup if it exists and
      # return undef otherwise. Die if we find multiple bootstrap snapshots.
  
      arg_count_or_die(2, 2, @_);
  
      my $local_backup = shift;
      my $config_ref   = shift;
  
      my $backup_dir_base = local_backup_dir($local_backup, undef, $config_ref);
  
      unless (-d $backup_dir_base && -r $backup_dir_base) {
          my $username = getpwuid $<;
          die "yabsm: error: no directory '$backup_dir_base' that is readable by user '$username'\n";
      }
  
      opendir my $dh, $backup_dir_base or confess("yabsm: internal error: cannot opendir '$backup_dir_base'");
      my @boot_snaps = grep { is_snapshot_name($_, ONLY_BOOTSTRAP => 1) } readdir($dh);
      closedir $dh;
  
      map { $_ = "$backup_dir_base/$_" } @boot_snaps;
  
      if (0 == @boot_snaps) {
          return undef;
      }
      elsif (1 == @boot_snaps) {
          return $boot_snaps[0];
      }
      else {
          die "yabsm: error: found multiple remote bootstrap snapshots for local_backup '$local_backup' in '$backup_dir_base'\n";
      }
  }
  
  1;
APP_YABSM_BACKUP_LOCAL

$fatpacked{"App/Yabsm/Backup/SSH.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_YABSM_BACKUP_SSH';
  #  Author:    Nicholas Hubbard
  #  Copyright: Nicholas Hubbard
  #  License:   GPL_3
  #  WWW:       https://github.com/NicholasBHubbard/Yabsm
  
  #  Provides the &do_ssh_backup subroutine, which performs a single
  #  ssh_backup. This is a top-level subroutine that is directly scheduled to be
  #  run by the daemon.
  
  use strict;
  use warnings;
  use v5.34.0;
  
  package App::Yabsm::Backup::SSH;
  
  use App::Yabsm::Tools qw( :ALL );
  use App::Yabsm::Config::Query qw( :ALL );
  use App::Yabsm::Snapshot qw(delete_snapshot
                              sort_snapshots
                              is_snapshot_name
                             );
  use App::Yabsm::Backup::Generic qw(take_bootstrap_snapshot
                                     the_local_bootstrap_snapshot
                                     take_tmp_snapshot
                                     bootstrap_lock_file
                                     create_bootstrap_lock_file
                                    );
  
  use Net::OpenSSH;
  use Carp qw(confess);
  use File::Basename qw(basename);
  
  use Exporter 'import';
  our @EXPORT_OK = qw(do_ssh_backup
                      do_ssh_backup_bootstrap
                      maybe_do_ssh_backup_bootstrap
                      the_remote_bootstrap_snapshot
                      new_ssh_conn
                      ssh_system_or_die
                      check_ssh_backup_config_or_die
                     );
  
                   ####################################
                   #            SUBROUTINES           #
                   ####################################
  
  sub do_ssh_backup {
  
      # Perform a $tframe ssh_backup for $ssh_backup.
  
      arg_count_or_die(4, 4, @_);
  
      my $ssh        = shift;
      my $ssh_backup = shift;
      my $tframe     = shift;
      my $config_ref = shift;
  
      # We can't do a backup if the bootstrap process is currently being performed.
      if (bootstrap_lock_file($ssh_backup, 'ssh', $config_ref)) {
          return undef;
      }
  
      $ssh //= new_ssh_conn($ssh_backup, $config_ref);
  
      check_ssh_backup_config_or_die($ssh, $ssh_backup, $config_ref);
  
      my $tmp_snapshot       = take_tmp_snapshot($ssh_backup, 'ssh', $tframe, $config_ref);
      my $bootstrap_snapshot = maybe_do_ssh_backup_bootstrap($ssh, $ssh_backup, $config_ref);
      my $backup_dir         = ssh_backup_dir($ssh_backup, $tframe, $config_ref);
      my $backup_dir_base    = ssh_backup_dir($ssh_backup, undef, $config_ref);
  
      ssh_system_or_die(
          $ssh,
          # This is why we need the remote user to have write permission on the
          # backup dir
          "if ! [ -d '$backup_dir' ]; then mkdir '$backup_dir'; fi"
      );
  
      ssh_system_or_die(
          $ssh,
          {stdin_file => ['-|', "sudo -n btrfs send -p '$bootstrap_snapshot' '$tmp_snapshot'"]},
          "sudo -n btrfs receive '$backup_dir'"
      );
  
      # The tmp snapshot is irrelevant now
      delete_snapshot($tmp_snapshot);
  
      # Delete old backups
  
      my @remote_backups = grep { is_snapshot_name($_) } ssh_system_or_die($ssh, "ls -1 '$backup_dir'");
      map { chomp $_ ; $_ = "$backup_dir/$_" } @remote_backups;
      # sorted from newest to oldest
      @remote_backups = sort_snapshots(\@remote_backups);
  
      my $num_backups    = scalar @remote_backups;
      my $to_keep        = ssh_backup_timeframe_keep($ssh_backup, $tframe, $config_ref);
  
      # There is 1 more backup than should be kept because we just performed a
      # backup.
      if ($num_backups == $to_keep + 1) {
          my $oldest = pop @remote_backups;
          ssh_system_or_die($ssh, "sudo -n btrfs subvolume delete '$oldest'");
      }
      # We havent reached the backup quota yet so we don't delete anything
      elsif ($num_backups <= $to_keep) {
          ;
      }
      # User changed their settings to keep less backups than they were keeping
      # prior.
      else {
          for (; $num_backups > $to_keep; $num_backups--) {
              my $oldest = pop @remote_backups;
              ssh_system_or_die($ssh, "sudo -n btrfs subvolume delete '$oldest'");
          }
      }
  
      return "$backup_dir/" . basename($tmp_snapshot);
  }
  
  sub do_ssh_backup_bootstrap {
  
      # Perform the bootstrap phase of an incremental backup for $ssh_backup.
  
      arg_count_or_die(3, 3, @_);
  
      my $ssh        = shift;
      my $ssh_backup = shift;
      my $config_ref = shift;
  
      if (bootstrap_lock_file($ssh_backup, 'ssh', $config_ref)) {
          return undef;
      }
  
      # The lock file will be deleted when $lock_fh goes out of scope (uses File::Temp).
      my $lock_fh = create_bootstrap_lock_file($ssh_backup, 'ssh', $config_ref);
  
      $ssh //= new_ssh_conn($ssh_backup, $config_ref);
  
      if (my $local_boot_snap = the_local_bootstrap_snapshot($ssh_backup, 'ssh', $config_ref)) {
          delete_snapshot($local_boot_snap);
      }
      if (my $remote_boot_snap = the_remote_bootstrap_snapshot($ssh, $ssh_backup, $config_ref)) {
          ssh_system_or_die($ssh, "sudo -n btrfs subvolume delete '$remote_boot_snap'");
      }
  
      my $local_boot_snap = take_bootstrap_snapshot($ssh_backup, 'ssh', $config_ref);
  
      my $remote_backup_dir = ssh_backup_dir($ssh_backup, undef, $config_ref);
  
      ssh_system_or_die(
          $ssh,
          {stdin_file => ['-|', "sudo -n btrfs send '$local_boot_snap'"]},
          "sudo -n btrfs receive '$remote_backup_dir'"
      );
  
      return $local_boot_snap;
  }
  
  sub maybe_do_ssh_backup_bootstrap {
  
      # Like &do_ssh_backup_bootstrap but only perform the bootstrap if it hasn't
      # been performed yet.
  
      arg_count_or_die(3, 3, @_);
  
      my $ssh        = shift;
      my $ssh_backup = shift;
      my $config_ref = shift;
  
      $ssh //= new_ssh_conn($ssh_backup, $config_ref);
  
      my $local_boot_snap  = the_local_bootstrap_snapshot($ssh_backup, 'ssh', $config_ref);
      my $remote_boot_snap = the_remote_bootstrap_snapshot($ssh, $ssh_backup, $config_ref);
  
      unless ($local_boot_snap && $remote_boot_snap) {
          $local_boot_snap = do_ssh_backup_bootstrap($ssh, $ssh_backup, $config_ref);
      }
  
      return $local_boot_snap;
  }
  
  sub the_remote_bootstrap_snapshot {
  
      # Return the remote bootstrap snapshot for $ssh_backup if it exists and
      # return undef otherwise. Die if we find multiple bootstrap snapshots.
  
      arg_count_or_die(3, 3, @_);
  
      my $ssh        = shift;
      my $ssh_backup = shift;
      my $config_ref = shift;
  
      $ssh //= new_ssh_conn($ssh_backup, $config_ref);
  
      my $remote_backup_dir = ssh_backup_dir($ssh_backup, undef, $config_ref);
      my @boot_snaps = grep { is_snapshot_name($_, ONLY_BOOTSTRAP => 1) } ssh_system_or_die($ssh, "ls -1 -a '$remote_backup_dir'");
      map { chomp $_ ; $_ = "$remote_backup_dir/$_" } @boot_snaps;
  
      if (0 == @boot_snaps) {
          return undef;
      }
      elsif (1 == @boot_snaps) {
          return $boot_snaps[0];
      }
      else {
          my $ssh_dest = ssh_backup_ssh_dest($ssh_backup, $config_ref);
          die "yabsm: ssh error: $ssh_dest: found multiple remote bootstrap snapshots in '$remote_backup_dir'\n";
      }
  }
  
  sub new_ssh_conn {
  
      # Return a Net::OpenSSH connection object to $ssh_backup's ssh destination or
      # die if a connection cannot be established.
  
      arg_count_or_die(2, 2, @_);
  
      my $ssh_backup = shift;
      my $config_ref = shift;
  
      my $home_dir = (getpwuid $<)[7]
        or die q(yabsm: error: user ').scalar(getpwuid $<).q(' does not have a home directory to hold SSH keys);
  
      my $pub_key  = "$home_dir/.ssh/id_ed25519.pub";
      my $priv_key = "$home_dir/.ssh/id_ed25519";
  
      unless (-f $pub_key) {
          my $username = getpwuid $<;
          die "yabsm: error: cannot not find '$username' users SSH public SSH key '$pub_key'\n";
      }
  
      unless (-f $priv_key) {
          my $username = getpwuid $<;
          die "yabsm: error: cannot not find '$username' users private SSH key '$priv_key'\n";
      }
  
      my $ssh_dest = ssh_backup_ssh_dest($ssh_backup, $config_ref);
  
      my $ssh = Net::OpenSSH->new(
          $ssh_dest,
          master_opts  => [ '-q' ], # quiet
          batch_mode   => 1, # Key based auth only
          ctl_dir      => '/tmp',
          remote_shell => 'sh',
      );
  
      if ($ssh->error) {
          die "yabsm: ssh error: $ssh_dest: cannot establish SSH connection: ".$ssh->error."\n";
      }
  
      return $ssh;
  }
  
  sub ssh_system_or_die {
  
      # Like Net::OpenSSH::capture but die if the command fails.
  
      arg_count_or_die(2, 3, @_);
  
      my $ssh  = shift;
      my %opts = ref $_[0] eq 'HASH' ? %{ shift() } : ();
      my $cmd  = shift;
  
      wantarray ? my @out = $ssh->capture(\%opts, $cmd) : my $out = $ssh->capture(\%opts, $cmd);
  
      if ($ssh->error) {
          my $host = $ssh->get_host;
          die "yabsm: ssh error: $host: remote command '$cmd' failed:".$ssh->error."\n";
      }
  
      return wantarray ? @out : $out;
  }
  
  sub check_ssh_backup_config_or_die {
  
      # Ensure that the $ssh_backup's ssh destination server is configured
      # properly and die with useful errors if not.
  
      arg_count_or_die(3, 3, @_);
  
      my $ssh        = shift;
      my $ssh_backup = shift;
      my $config_ref = shift;
  
      $ssh //= new_ssh_conn($ssh_backup, $config_ref);
  
      my $remote_backup_dir = ssh_backup_dir($ssh_backup, undef, $config_ref);
      my $ssh_dest          = ssh_backup_ssh_dest($ssh_backup, $config_ref);
  
      my (undef, $stderr) = $ssh->capture2(qq(
  ERRORS=''
  
  add_error() {
      if [ -z "\$ERRORS" ]; then
          ERRORS="yabsm: ssh error: $ssh_dest: \$1"
      else
          ERRORS="\${ERRORS}\nyabsm: ssh error: $ssh_dest: \$1"
      fi
  }
  
  HAVE_BTRFS=true
  
  if ! which btrfs >/dev/null 2>&1; then
     HAVE_BTRFS=false
     add_error "btrfs-progs not in '\$(whoami)'s path"
  fi
  
  if [ "\$HAVE_BTRFS" = true ] && ! sudo -n btrfs --help >/dev/null 2>&1; then
      add_error "user '\$(whoami)' does not have root sudo access to btrfs-progs"
  fi
  
  if ! [ -d '$remote_backup_dir' ] || ! [ -r '$remote_backup_dir' ] || ! [ -w '$remote_backup_dir' ]; then
      add_error "no directory '$remote_backup_dir' that is readable+writable by user '\$(whoami)'"
  else
      if [ "\$HAVE_BTRFS" = true ] && ! btrfs property list '$remote_backup_dir' >/dev/null 2>&1; then
          add_error "'$remote_backup_dir' is not a directory residing on a btrfs filesystem"
      fi
  fi
  
  if [ -n '\$ERRORS' ]; then
      1>&2 printf %s "\$ERRORS"
      exit 1
  else
      exit 0
  fi
  ));
  
      if ($stderr) {
          die "$stderr\n";
      }
  
      return 1;
  }
  
  1;
APP_YABSM_BACKUP_SSH

$fatpacked{"App/Yabsm/Command/Config.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_YABSM_COMMAND_CONFIG';
  #  Author:    Nicholas Hubbard
  #  Copyright: Nicholas Hubbard
  #  License:   GPL_3
  #  WWW:       https://github.com/NicholasBHubbard/Yabsm
  
  #  Provides functionality for querying information about the users config.
  
  use strict;
  use warnings;
  use v5.34.0;
  
  package App::Yabsm::Command::Config;
  
  use App::Yabsm::Tools qw( :ALL );
  use App::Yabsm::Config::Query qw( :ALL );
  use App::Yabsm::Config::Parser qw(parse_config_or_die);
  use App::Yabsm::Backup::SSH;
  use App::Yabsm::Command::Daemon;
  
  sub usage {
      arg_count_or_die(0, 0, @_);
      return <<'END_USAGE';
  usage: yabsm <config|c> [--help] [check ?file] [ssh-check <SSH_BACKUP>] [ssh-key]
                          [yabsm-user-home] [yabsm_dir] [subvols] [snaps]
                          [ssh_backups] [local_backups] [backups]
  END_USAGE
  }
  
  sub help {
      @_ == 0 or die usage();
      my $usage = usage();
      $usage =~ s/\s+$//;
      print <<"END_HELP";
  $usage
  
  --help                 Print this help message.
  
  check ?file            Check ?file for errors and print their messages. If ?file
                         is omitted it defaults to /etc/yabsm.conf.
  
  ssh-check <SSH_BACKUP> Check that backups for <SSH_BACKUP> are able to be
                         performed and if not print useful error messages.
  
  ssh-key                Print the 'yabsm' users public SSH key.
  
  yabsm-user-home        Print the 'yabsm' users home directory.
  
  yabsm_dir              Print the value of yabsm_dir in /etc/yabsm.conf.
  
  subvols                Print names of all subvols defined in /etc/yabsm.conf.
  
  snaps                  Print names of all snaps defined in /etc/yabsm.conf.
  
  ssh_backups            Print names of all ssh_backups defined in /etc/yabsm.conf.
  
  local_backups          Print the of all local_backups defined in /etc/yabsm.conf.
  
  backups                Print names of all ssh_backups and local_backups defined
                         in /etc/yabsm.conf.
  
  END_HELP
  }
  
                   ####################################
                   #               MAIN               #
                   ####################################
  
  sub main {
  
      my $cmd = shift or die usage();
  
      if    ($cmd =~ /^(-h|--help)$/  ) { help(@_)                     }
      elsif ($cmd eq 'check'          ) { check_config(@_)             }
      elsif ($cmd eq 'ssh-check'      ) { check_ssh_backup(@_)         }
      elsif ($cmd eq 'ssh-key'        ) { print_yabsm_user_ssh_key(@_) }
      elsif ($cmd eq 'yabsm_user_home') { print_yabsm_user_home(@_)    }
      elsif ($cmd eq 'yabsm_dir'      ) { print_yabsm_dir(@_)          }
      elsif ($cmd eq 'subvols'        ) { print_subvols(@_)            }
      elsif ($cmd eq 'snaps'          ) { print_snaps(@_)              }
      elsif ($cmd eq 'ssh_backups'    ) { print_ssh_backups(@_)        }
      elsif ($cmd eq 'local_backups'  ) { print_local_backups(@_)      }
      elsif ($cmd eq 'backups'        ) { print_backups(@_)            }
      else {
          die usage();
      }
  }
  
                   ####################################
                   #            SUBCOMMANDS           #
                   ####################################
  
  sub check_config {
      @_ <= 1 or die usage();
      my $file = shift // '/etc/yabsm.conf';
      parse_config_or_die($file);
      say 'all good';
  }
  
  sub print_subvols {
      @_ == 0 or die usage();
      my $config_ref = parse_config_or_die();
      say for all_subvols($config_ref);
  }
  
  sub print_snaps {
      @_ == 0 or die usage();
      my $config_ref = parse_config_or_die();
      say for all_snaps($config_ref);
  }
  
  sub print_ssh_backups {
      @_ == 0 or die usage();
      my $config_ref = parse_config_or_die();
      say for all_ssh_backups($config_ref);
  }
  
  sub print_local_backups {
      @_ == 0 or die usage();
      my $config_ref = parse_config_or_die();
      say for all_local_backups($config_ref);
  }
  
  sub print_backups {
      @_ == 0 or die usage();
      my $config_ref = parse_config_or_die();
      my @ssh_backups = all_ssh_backups($config_ref);
      my @local_backups = all_local_backups($config_ref);
      say for sort @ssh_backups, @local_backups;
  }
  
  sub print_yabsm_dir {
      @_ == 0 or die usage();
      my $config_ref = parse_config_or_die();
      my $yabsm_dir = yabsm_dir($config_ref);
      say $yabsm_dir;
  }
  
  sub print_yabsm_user_home {
      @_ == 0 or die usage();
      my $config_ref = parse_config_or_die();
      my $yabsm_user_home = yabsm_user_home($config_ref);
      say $yabsm_user_home;
  }
  
  sub check_ssh_backup {
  
      # This is mostly just a wrapper around
      # &App::Yabsm::Backup::SSH::check_ssh_backup_config_or_die.
  
      @_ == 1 or die usage();
  
      die 'yabsm: error: permission denied'."\n" unless i_am_root();
  
      my $ssh_backup = shift;
  
      my $config_ref = parse_config_or_die();
  
      unless (ssh_backup_exists($ssh_backup, $config_ref)) {
          die "yabsm: error: no such ssh_backup named '$ssh_backup'\n";
      }
  
      unless (App::Yabsm::Command::Daemon::yabsm_user_exists()) {
          die q(yabsm: error: cannot find user named 'yabsm')."\n";
      }
  
      unless (App::Yabsm::Command::Daemon::yabsm_group_exists()) {
          die q(yabsm: error: cannot find group named 'yabsm')."\n";
      }
  
      POSIX::setgid(scalar(getgrnam 'yabsm'));
      POSIX::setuid(scalar(getpwnam 'yabsm'));
  
      App::Yabsm::Backup::SSH::check_ssh_backup_config_or_die(undef, $ssh_backup, $config_ref);
  
      say 'all good';
  }
  
  sub print_yabsm_user_ssh_key {
  
      # Print the yabsm users public key to STDOUT.
  
      @_ == 0 or die usage();
  
      die 'yabsm: error: permission denied'."\n" unless i_am_root();
  
      my $config_ref = parse_config_or_die();
  
      my $yabsm_user_ssh_dir = yabsm_user_home($config_ref) . '/.ssh';
  
      my $priv_key = "$yabsm_user_ssh_dir/id_ed25519";
      my $pub_key  = "$yabsm_user_ssh_dir/id_ed25519.pub";
  
      unless (-f $priv_key) {
          die "yabsm: error: could not find user 'yabsm' users SSH private key '$priv_key'\n";
      }
  
      unless (-f $pub_key) {
          die "yabsm: error: could not find user 'yabsm' users SSH public key '$pub_key'\n";
      }
  
      open my $fh, '<', $pub_key
        or die "yabsm: internal error: could not open '$pub_key' for reading\n";
  
      print <$fh>;
  
      close $fh
  }
  
  1;
APP_YABSM_COMMAND_CONFIG

$fatpacked{"App/Yabsm/Command/Daemon.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_YABSM_COMMAND_DAEMON';
  #  Author:    Nicholas Hubbard
  #  Copyright: Nicholas Hubbard
  #  License:   GPL_3
  #  WWW:       https://github.com/NicholasBHubbard/Yabsm
  
  #  The Yabsm daemon.
  
  use strict;
  use warnings;
  use v5.34.0;
  
  package App::Yabsm::Command::Daemon;
  
  use App::Yabsm::Tools qw( :ALL );
  use App::Yabsm::Config::Query qw( :ALL );
  use App::Yabsm::Config::Parser qw(parse_config_or_die);
  use App::Yabsm::Snap;
  use App::Yabsm::Backup::SSH;
  use App::Yabsm::Backup::Local;
  
  use Schedule::Cron;
  use POSIX ();
  
  use Carp qw(confess);
  
  sub usage {
      arg_count_or_die(0, 0, @_);
      return 'usage: yabsm <daemon|d> [--help] [start] [stop] [restart] [status] [init]'."\n";
  }
  
                   ####################################
                   #               MAIN               #
                   ####################################
  sub main {
  
      my $cmd = shift // die usage();
      @_ and die usage();
  
      if    ($cmd =~ /^(-h|--help)$/) { help()           }
      elsif ($cmd eq 'start'        ) { yabsmd_start()   }
      elsif ($cmd eq 'stop'         ) { yabsmd_stop()    }
      elsif ($cmd eq 'restart'      ) { yabsmd_restart() }
      elsif ($cmd eq 'status'       ) { yabsmd_status()  }
      elsif ($cmd eq 'init'         ) { yabsmd_init()    }
      else {
          die usage();
      }
  }
  
                   ####################################
                   #            SUBCOMMANDS           #
                   ####################################
  
  sub help {
      arg_count_or_die(0, 0, @_);
      my $usage = usage();
      $usage =~ s/\s+$//;
      print <<"END_HELP";
  $usage
  
  --help       Print this help message.
  
  start        Start the Yabsm daemon.
  
  stop         Stop the Yabsm daemon.
  
  restart      Restart the Yabsm daemon.
  
  status       Print the Yabsm daemons PID if it is running.
  
  init         Initialize the Yabsm daemons runtime environment without starting
               the daemon.
  
  END_HELP
  }
  
  sub yabsmd_start {
  
      # Start the yabsm daemon.
  
      arg_count_or_die(0, 0, @_);
  
      die 'yabsm: error: permission denied'."\n" unless i_am_root();
  
      # There can only ever be one running instance of yabsmd.
      if (my $yabsmd_pid = yabsmd_pid()) {
          die "yabsm: error: yabsmd is already running as pid $yabsmd_pid\n";
      }
  
      my $config_ref = parse_config_or_die();
  
      initialize_yabsmd_runtime_environment(1, 1, $config_ref);
  
      my $pid = create_cron_scheduler($config_ref)->run(
          detach => 1,
          pid_file => '/run/yabsmd.pid'
      );
  
      say "started yabsmd as pid $pid";
  }
  
  sub yabsmd_stop {
  
      # Stop the yabsm daemon if it is running and exit.
  
      arg_count_or_die(0, 0, @_);
  
      die 'yabsm: error: permission denied'."\n" unless i_am_root();
  
      if (my $pid = yabsmd_pid()) {
          if (kill 'TERM', $pid) {
              say "terminated yabsmd process running as pid $pid";
          }
          else {
              die "yabsm: error: cannot terminate yabsmd process running as pid $pid\n";
          }
      }
      else { die 'no running instance of yabsmd'."\n" }
  }
  
  sub yabsmd_restart {
  
      # Restart the yabsm daemon if it is running and exit.
  
      arg_count_or_die(0, 0, @_);
  
      die 'yabsm: error: permission denied'."\n" unless i_am_root();
  
      yabsmd_stop();
  
      sleep 1;
  
      yabsmd_start();
  }
  
  sub yabsmd_status {
  
      # If the yabsm daemon is running print its pid.
  
      arg_count_or_die(0, 0, @_);
  
      if (my $pid = yabsmd_pid()) {
          say $pid;
      }
      else {
          die "no running instance of yabsmd\n";
      }
  }
  
  sub yabsmd_init {
  
      # Subcommand to allow user to yabsmd's runtime environment without having to
      # start yabsmd.
  
      arg_count_or_die(0, 0, @_);
  
      die 'yabsm: error: permission denied'."\n" unless i_am_root();
  
      my $config_ref = parse_config_or_die();
  
      initialize_yabsmd_runtime_environment(0, 0, $config_ref);
  
      say 'all good';
  }
  
                   ####################################
                   #              HELPERS             #
                   ####################################
  
  sub initialize_yabsmd_runtime_environment {
  
      # Initialize yabsmd's runtime environment:
      #
      # * Install the signal handlers that remove the PID file before exiting
      # * Create dirs needed for performing snaps, ssh_backups, and local_backups
      # * Create the yabsm user and group if they don't already exists
      # * If $create_log_file, create /var/log/yabsm if it does not exist and chown it to yabsm:yabsm
      # * If $create_pid_file, create the (empty) file /run/yabsmd.pid and chown it to yabsm:yabsm
      # * Create the yabsm users SSH keys if they don't already exist
      # * Set this processes UID and GID to yabsm:yabsm
  
      arg_count_or_die(3, 3, @_);
  
      my $create_log_file = shift;
      my $create_pid_file = shift;
      my $config_ref      = shift;
  
      i_am_root_or_die();
  
      os_dependencies_satisfied_or_die();
  
      install_signal_handlers();
  
      create_yabsmd_runtime_dirs($config_ref);
  
      my ($yabsm_uid, $yabsm_gid) = create_yabsm_user_and_group($config_ref);
  
      open my $sudoer_fh, '>', '/etc/sudoers.d/yabsm-btrfs'
        or die "yabsm: error: cannot open '/etc/sudoers.d/yabsm-btrfs' for writing";
      my $btrfs_bin = `which btrfs 2>/dev/null`;
      print $sudoer_fh "yabsm ALL=(root) NOPASSWD: $btrfs_bin";
      close $sudoer_fh;
  
      if ($create_log_file) {
          open my $log_fh, '>>', '/var/log/yabsm'
            or confess q(yabsm: internal error: cannot open file '/var/log/yabsm' for writing);
          close $log_fh;
          chown $yabsm_uid, $yabsm_gid, '/var/log/yabsm';
          chmod 0644, '/var/log/yabsm';
      }
  
      if ($create_pid_file) {
          open my $pid_fh, '>', '/run/yabsmd.pid'
            or confess q(yabsm: internal error: cannot not open file '/run/yabsmd.pid' for writing);
          close $pid_fh;
          chown $yabsm_uid, $yabsm_gid, '/run/yabsmd.pid';
          chmod 0644, '/run/yabsmd.pid';
      }
  
      POSIX::setgid($yabsm_gid);
      POSIX::setuid($yabsm_uid);
  
      create_yabsm_user_ssh_key(0, $config_ref);
  
      return 1;
  }
  
  sub create_cron_scheduler {
  
      # Return a Schedule::Cron object that schedules every snap, ssh_backup, and
      # local_backup that is defined in the users config.
  
      arg_count_or_die(1, 1, @_);
  
      my $config_ref = shift;
  
      my $cron_scheduler = Schedule::Cron->new(
          sub { confess('yabsm: internal error: default Schedule::Cron dispatcher was invoked') },
          processname => 'yabsmd'
      );
  
      for my $snap (all_snaps($config_ref)) {
          if (snap_wants_timeframe($snap, '5minute', $config_ref)) {
              $cron_scheduler->add_entry(
                  '*/5 * * * *',
                  sub { with_error_catch_log(\&App::Yabsm::Snap::do_snap, $snap, '5minute', $config_ref) }
              );
          }
          if (snap_wants_timeframe($snap, 'hourly', $config_ref)) {
              $cron_scheduler->add_entry(
                  '0 */1 * * *',
                  sub { with_error_catch_log(\&App::Yabsm::Snap::do_snap, $snap, 'hourly', $config_ref) }
              );
          }
          if (snap_wants_timeframe($snap, 'daily', $config_ref)) {
              for my $time (snap_daily_times($snap, $config_ref)) {
                  my $hr   = time_hour($time);
                  my $min  = time_minute($time);
                  $cron_scheduler->add_entry(
                      "$min $hr * * *",
                      sub { with_error_catch_log(\&App::Yabsm::Snap::do_snap, $snap, 'daily', $config_ref) }
                  );
              }
          }
          if (snap_wants_timeframe($snap, 'weekly', $config_ref)) {
              my $time = snap_weekly_time($snap, $config_ref);
              my $hr   = time_hour($time);
              my $min  = time_minute($time);
              my $day  = weekday_number(snap_weekly_day($snap, $config_ref));
              $cron_scheduler->add_entry(
                  "$min $hr * * $day",
                  sub { with_error_catch_log(\&App::Yabsm::Snap::do_snap, $snap, 'weekly', $config_ref) }
              );
          }
          if (snap_wants_timeframe($snap, 'monthly', $config_ref)) {
              my $time = snap_monthly_time($snap, $config_ref);
              my $hr   = time_hour($time);
              my $min  = time_minute($time);
              my $day  = snap_monthly_day($snap, $config_ref);
              $cron_scheduler->add_entry(
                  "$min $hr $day * *",
                  sub { with_error_catch_log(\&App::Yabsm::Snap::do_snap, $snap, 'monthly', $config_ref) }
              );
          }
      }
  
      for my $ssh_backup (all_ssh_backups($config_ref)) {
          if (ssh_backup_wants_timeframe($ssh_backup, '5minute', $config_ref)) {
              $cron_scheduler->add_entry(
                  '*/5 * * * *',
                  sub { with_error_catch_log(\&App::Yabsm::Backup::SSH::do_ssh_backup, undef, $ssh_backup, '5minute', $config_ref) }
              );
          }
          if (ssh_backup_wants_timeframe($ssh_backup, 'hourly', $config_ref)) {
              $cron_scheduler->add_entry(
                  '0 */1 * * *',
                  sub { with_error_catch_log(\&App::Yabsm::Backup::SSH::do_ssh_backup, undef, $ssh_backup, 'hourly', $config_ref) }
              );
          }
          if (ssh_backup_wants_timeframe($ssh_backup, 'daily', $config_ref)) {
              for my $time (ssh_backup_daily_times($ssh_backup, $config_ref)) {
                  my $hr   = time_hour($time);
                  my $min  = time_minute($time);
                  $cron_scheduler->add_entry(
                      "$min $hr * * *",
                      sub { with_error_catch_log(\&App::Yabsm::Backup::SSH::do_ssh_backup, undef, $ssh_backup, 'daily', $config_ref) }
                  );
              }
          }
          if (ssh_backup_wants_timeframe($ssh_backup, 'weekly', $config_ref)) {
              my $time = ssh_backup_weekly_time($ssh_backup, $config_ref);
              my $hr   = time_hour($time);
              my $min  = time_minute($time);
              my $day  = weekday_number(ssh_backup_weekly_day($ssh_backup, $config_ref));
              $cron_scheduler->add_entry(
                  "$min $hr * * $day",
                  sub { with_error_catch_log(\&App::Yabsm::Backup::SSH::do_ssh_backup, undef, $ssh_backup, 'weekly', $config_ref) }
              );
          }
          if (ssh_backup_wants_timeframe($ssh_backup, 'monthly', $config_ref)) {
              my $time = ssh_backup_monthly_time($ssh_backup, $config_ref);
              my $hr   = time_hour($time);
              my $min  = time_minute($time);
              my $day  = ssh_backup_monthly_day($ssh_backup, $config_ref);
              $cron_scheduler->add_entry(
                  "$min $hr $day * *",
                  sub { with_error_catch_log(\&App::Yabsm::Backup::SSH::do_ssh_backup, undef, $ssh_backup, 'monthly', $config_ref) }
              );
          }
      }
  
      for my $local_backup (all_local_backups($config_ref)) {
          if (local_backup_wants_timeframe($local_backup, '5minute', $config_ref)) {
              $cron_scheduler->add_entry(
                  '*/5 * * * *',
                  sub { with_error_catch_log(\&App::Yabsm::Backup::Local::do_local_backup, $local_backup, '5minute', $config_ref) }
              );
          }
          if (local_backup_wants_timeframe($local_backup, 'hourly', $config_ref)) {
              $cron_scheduler->add_entry(
                  '0 */1 * * *',
                  sub { with_error_catch_log(\&App::Yabsm::Backup::Local::do_local_backup, $local_backup, 'hourly', $config_ref) }
              );
          }
          if (local_backup_wants_timeframe($local_backup, 'daily', $config_ref)) {
              for my $time (local_backup_daily_times($local_backup, $config_ref)) {
                  my $hr   = time_hour($time);
                  my $min  = time_minute($time);
                  $cron_scheduler->add_entry(
                      "$min $hr * * *",
                      sub { with_error_catch_log(\&App::Yabsm::Backup::Local::do_local_backup, $local_backup, 'daily', $config_ref) }
                  );
              }
          }
          if (local_backup_wants_timeframe($local_backup, 'weekly', $config_ref)) {
              my $time = local_backup_weekly_time($local_backup, $config_ref);
              my $hr   = time_hour($time);
              my $min  = time_minute($time);
              my $day  = weekday_number(local_backup_weekly_day($local_backup, $config_ref));
              $cron_scheduler->add_entry(
                  "$min $hr * * $day",
                  sub { with_error_catch_log(\&App::Yabsm::Backup::Local::do_local_backup, $local_backup, 'weekly', $config_ref) }
              );
          }
          if (local_backup_wants_timeframe($local_backup, 'monthly', $config_ref)) {
              my $time = local_backup_monthly_time($local_backup, $config_ref);
              my $hr   = time_hour($time);
              my $min  = time_minute($time);
              my $day  = local_backup_monthly_day($local_backup, $config_ref);
              $cron_scheduler->add_entry(
                  "$min $hr $day * *",
                  sub { with_error_catch_log(\&App::Yabsm::Backup::Local::do_local_backup, $local_backup, 'monthly', $config_ref) }
              );
          }
      }
  
      return $cron_scheduler;
  }
  
  sub create_yabsmd_runtime_dirs {
  
      # Create the directories needed for the daemon to perform every snap,
      # ssh_backup, and local_backup.
  
      arg_count_or_die(1, 1, @_);
  
      my $config_ref = shift;
  
      i_am_root_or_die();
  
      for my $snap (all_snaps($config_ref)) {
          for my $tframe (snap_timeframes($snap, $config_ref)) {
              make_path_or_die(snap_dest($snap, $tframe, $config_ref));
          }
      }
  
      for my $ssh_backup (all_ssh_backups($config_ref)) {
          make_path_or_die(App::Yabsm::Backup::Generic::bootstrap_snapshot_dir($ssh_backup, 'ssh', $config_ref));
          for my $tframe (ssh_backup_timeframes($ssh_backup, $config_ref)) {
              make_path_or_die(App::Yabsm::Backup::Generic::tmp_snapshot_dir($ssh_backup, 'ssh', $tframe, $config_ref));
          }
      }
  
      for my $local_backup (all_local_backups($config_ref)) {
          make_path_or_die(App::Yabsm::Backup::Generic::bootstrap_snapshot_dir($local_backup, 'local', $config_ref));
          my $backup_dir_exists = -d local_backup_dir($local_backup, undef, $config_ref);
          for my $tframe (local_backup_timeframes($local_backup, $config_ref)) {
              make_path_or_die(App::Yabsm::Backup::Generic::tmp_snapshot_dir($local_backup, 'local', $tframe, $config_ref));
              if ($backup_dir_exists) {
                  make_path_or_die(local_backup_dir($local_backup, $tframe, $config_ref));
              }
          }
      }
      return 1;
  }
  
  sub yabsmd_pid {
  
      # If there is a running instance of yabsmd return its pid and otherwise
      # return 0.
  
      arg_count_or_die(0, 0, @_);
  
      chomp for my @pids = `pgrep ^yabsmd\$`;
  
      my $pid_file_pid;
      if (open my $fh, '<', '/run/yabsmd.pid') {
          $pid_file_pid = <$fh>;
          chomp $pid_file_pid if $pid_file_pid;
          close $fh;
      }
  
      my $is_running = $pid_file_pid && @pids && grep({$_ eq $pid_file_pid} @pids);
  
      return $is_running ? $pid_file_pid : 0;
  }
  
  sub install_signal_handlers {
  
      # Install a handler for all signals with a default action of terminate or
      # dump to ensure we remove /run/yabsmd.pid before exiting.
      #
      # Handle SIGHUP by restarting yabsmd.
  
      # Restart the daemon on a SIGHUP.
      $SIG{HUP} = \&yabsmd_restart;
  
      # Gracefully exit on any signal that has a default action of terminate or
      # dump.
      my $cleanup_and_exit = sub {
          # clear the PID file
          if (open my $fh, '>', '/run/yabsmd.pid') {
              close $fh;
          }
          exit 0;
      };
  
      $SIG{ABRT}   = $cleanup_and_exit;
      $SIG{ALRM}   = $cleanup_and_exit;
      $SIG{BUS}    = $cleanup_and_exit;
      $SIG{FPE}    = $cleanup_and_exit;
      $SIG{ILL}    = $cleanup_and_exit;
      $SIG{INT}    = $cleanup_and_exit;
      $SIG{IO}     = $cleanup_and_exit;
      $SIG{KILL}   = $cleanup_and_exit;
      $SIG{PIPE}   = $cleanup_and_exit;
      $SIG{PROF}   = $cleanup_and_exit;
      $SIG{PWR}    = $cleanup_and_exit;
      $SIG{QUIT}   = $cleanup_and_exit;
      $SIG{SEGV}   = $cleanup_and_exit;
      $SIG{STKFLT} = $cleanup_and_exit;
      $SIG{SYS}    = $cleanup_and_exit;
      $SIG{TERM}   = $cleanup_and_exit;
      $SIG{TRAP}   = $cleanup_and_exit;
      $SIG{USR1}   = $cleanup_and_exit;
      $SIG{USR2}   = $cleanup_and_exit;
      $SIG{VTALRM} = $cleanup_and_exit;
      $SIG{XCPU}   = $cleanup_and_exit;
      $SIG{XFSZ}   = $cleanup_and_exit;
  }
  
  sub create_yabsm_user_ssh_key {
  
      # Create an SSH key for the yabsm user if one doesn't already exist. This
      # function dies unless the processes ruid and rgid are that of the yabsm user
      # and group.
      #
      # If the $force value is false then only create the key if the users
      # configuration defines at least one ssh_backup, and if it is true then
      # create the key even if no ssh_backup's are defined.
  
      arg_count_or_die(2, 2, @_);
  
      my $force      = shift;
      my $config_ref = shift;
  
      if ($force || all_ssh_backups($config_ref)) {
  
          my $yabsm_uid = getpwnam('yabsm') or confess(q(yabsm: internal error: cannot find user named 'yabsm'));
          my $yabsm_gid = getgrnam('yabsm') or confess(q(yabsm: internal error: cannot find group named 'yabsm'));
  
          unless (POSIX::getuid() == $yabsm_uid && POSIX::getgid() == $yabsm_gid) {
              my $username  = getpwuid POSIX::getuid();
              my $groupname = getgrgid POSIX::getgid();
              confess "yabsm: internal error: expected to be running as user and group yabsm but instead running as user '$username' and group '$groupname'";
          }
  
          my $yabsm_user_home = yabsm_user_home($config_ref);
  
          my $ssh_dir  = "$yabsm_user_home/.ssh";
          my $priv_key = "$ssh_dir/id_ed25519";
          my $pub_key  = "$ssh_dir/id_ed25519.pub";
  
          unless (-f $priv_key && -f $pub_key) {
              system_or_die('ssh-keygen', '-t', 'ed25519', '-f', $priv_key, '-N', '');
              chown $yabsm_uid, $yabsm_gid, $priv_key, $pub_key;
              chmod 0600, $priv_key;
              chmod 0644, $pub_key;
          }
  
          return 1;
      }
  
      return 0;
  }
  
  sub add_yabsm_user_btrfs_sudoer_rule {
  
      # Add sudoer rule to '/etc/sudoers.d/yabsm-btrfs' to grant the 'yabsm' user
      # sudo access to btrfs-progs.
  
      arg_count_or_die(0, 0, @_);
  
      i_am_root_or_die();
  
      my $file = '/etc/sudoers.d/yabsm-btrfs';
  
      unless (-f $file) {
          my $btrfs_bin = `which btrfs 2>/dev/null`
            or confess('yabsm: internal error: btrfs-progs not in root users path');
  
          my $sudoer_rule = "yabsm ALL=(root) NOPASSWD $btrfs_bin";
  
          open my $fh, '>', $file
            or confess("yabsm: internal error: could not open '$file' for writing");
  
          print $fh $sudoer_rule;
  
          close $fh
      }
  
      return $file;
  }
  
  sub create_yabsm_user_and_group {
  
      # Create a locked-user and group named 'yabsm' if they do not already exist.
  
      arg_count_or_die(1, 1, @_);
  
      my $config_ref = shift;
  
      i_am_root_or_die();
  
      unless (yabsm_user_exists()) {
          system_or_die('useradd', '-m', '-d', yabsm_user_home($config_ref), '-s', '/bin/sh', '-k', '/dev/null', 'yabsm');
          system_or_die('passwd', '--lock', 'yabsm');
      }
  
      unless (yabsm_group_exists()) {
          system_or_die('groupadd', 'yabsm');
      }
  
      # The yabsm users home dir must be reinitialized in case the user changed
      # their yabsm_dir since the last time we ran the daemon.
      system_or_die('usermod', '-m', '-d', yabsm_user_home($config_ref), 'yabsm');
  
      my $yabsm_uid = getpwnam('yabsm');
      my $yabsm_gid = getgrnam('yabsm');
  
      return wantarray ? ($yabsm_uid, $yabsm_gid) : 1;
  }
  
  sub yabsm_user_exists {
  
      # Return 1 if there exists a locked user on the system named 'yabsm'.
  
      arg_count_or_die(0, 0, @_);
  
      i_am_root_or_die();
  
      unless (0 == system('getent passwd yabsm >/dev/null 2>&1')) {
          return 0;
      }
  
      unless ('L' eq (split ' ', `passwd -S yabsm`)[1]) {
          die q(yabsm: error: found non-locked user named 'yabsm')."\n";
      }
  
      return 1;
  }
  
  sub yabsm_group_exists {
  
      # Return 1 if there exists on the system a user and group named 'yabsm' and
      # return 0 otherwise.
  
      arg_count_or_die(0, 0, @_);
  
      return 0+(0 == system('getent group yabsm >/dev/null 2>&1'));
  }
  
  1;
APP_YABSM_COMMAND_DAEMON

$fatpacked{"App/Yabsm/Command/Find.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_YABSM_COMMAND_FIND';
  #  Author:    Nicholas Hubbard
  #  Copyright: Nicholas Hubbard
  #  License:   GPL_3
  #  WWW:       https://github.com/NicholasBHubbard/Yabsm
  
  #  Provides functionality for finding snapshots via a snapshot finding DSL.
  #
  #  See t/Yabsm/Snapshot.pm for this libraries tests.
  
  use strict;
  use warnings;
  use v5.34.0;
  
  package App::Yabsm::Command::Find;
  
  use App::Yabsm::Tools qw( :ALL );
  use App::Yabsm::Config::Query qw ( :ALL );
  use App::Yabsm::Config::Parser qw(parse_config_or_die);
  use App::Yabsm::Backup::SSH;
  use App::Yabsm::Snapshot qw(nums_to_snapshot_name
                              snapshot_name_nums
                              current_time_snapshot_name
                              sort_snapshots
                              is_snapshot_name
                              snapshots_eq
                              snapshot_newer
                              snapshot_older
                              snapshot_newer_or_eq
                              snapshot_older_or_eq
                             );
  
  use Feature::Compat::Try;
  use Net::OpenSSH;
  use Time::Piece;
  use File::Basename qw(basename);
  use Carp qw(confess);
  use POSIX ();
  
  use Parser::MGC;
  use base qw(Parser::MGC);
  
  sub usage {
      arg_count_or_die(0, 0, @_);
      return 'usage: yabsm <find|f> [--help] [<SNAP|SSH_BACKUP|LOCAL_BACKUP> <QUERY>]'."\n";
  }
  
  sub help {
      @_ == 0 or die usage();
      my $usage = usage();
      $usage =~ s/\s+$//;
      print <<"END_HELP";
  $usage
  
  see the section "Finding Snapshots" in 'man yabsm' for a detailed explanation on
  how to find snapshots and backups.
  
  examples:
      yabsm find home_snap back-10-hours
      yabsm f root_ssh_backup newest
      yabsm f home_local_backup oldest
      yabsm f home_snap 'between b-10-mins 15:45'
      yabsm f root_snap 'after back-2-days'
      yabsm f root_local_backup 'before b-14-d'
  
  END_HELP
  }
  
                   ####################################
                   #               MAIN               #
                   ####################################
  
  sub main {
  
      if (@_ == 1) {
          shift =~ /^(-h|--help)$/ or die usage();
          help();
      }
  
      elsif (@_ == 2) {
  
          my $thing = shift;
          my $query = shift;
  
          my $config_ref = parse_config_or_die();
  
          unless (snap_exists($thing, $config_ref) || ssh_backup_exists($thing, $config_ref) || local_backup_exists($thing, $config_ref)) {
              die "yabsm: error: no such snap, ssh_backup, or local_backup named '$thing'\n";
          }
  
          my @snapshots = answer_query($thing, parse_query_or_die($query), $config_ref);
  
          say for @snapshots;
      }
  
      else {
          die usage()
      }
  }
  
                   ####################################
                   #           QUERY ANSWERING        #
                   ####################################
  
  sub answer_query {
  
      # Return a subset of all the snapshots/backups of $thing that satisfy
      # $query.
  
      arg_count_or_die(3, 3, @_);
  
      my $thing      = shift;
      my %query      = %{+shift};
      my $config_ref = shift;
  
      my @snapshots;
  
      if (snap_exists($thing, $config_ref)) {
          for my $tframe (snap_timeframes($thing, $config_ref)) {
              my $dir = snap_dest($thing, $tframe, $config_ref);
              unless (-r $dir) {
                  die "yabsm: error: do not have read permission on '$dir'\n";
              }
              opendir my $dh, $dir or confess "yabsm: internal error: could not opendir '$dir'";
              push @snapshots, map { $_ = "$dir/$_" } grep { is_snapshot_name($_) } readdir($dh);
              closedir $dh;
          }
      }
  
      elsif (ssh_backup_exists($thing, $config_ref)) {
  
          die 'yabsm: error: permission denied'."\n" unless i_am_root();
  
          my $yabsm_uid = getpwnam('yabsm') or die q(yabsm: error: no user named 'yabsm')."\n";
  
          POSIX::setuid($yabsm_uid);
  
          my $ssh = App::Yabsm::Backup::SSH::new_ssh_conn($thing, $config_ref);
  
          my $ssh_dest = ssh_backup_ssh_dest($thing, $config_ref);
  
          if ($ssh->error) {
              die "yabsm: ssh error: $ssh_dest: ".$ssh->error."\n";
          }
          for my $tframe (ssh_backup_timeframes($thing, $config_ref)) {
              my $dir  = ssh_backup_dir($thing, $tframe, $config_ref);
              unless ($ssh->system("[ -r '$dir' ]")) {
                  die "yabsm: ssh error: $ssh_dest: remote user does not have read permission on '$dir'\n";
              }
              push @snapshots, grep { chomp $_; is_snapshot_name($_) } App::Yabsm::Backup::SSH::ssh_system_or_die($ssh, "ls -1 '$dir'");
              map { $_ = "$dir/$_" } @snapshots;
          }
      }
  
      elsif (local_backup_exists($thing, $config_ref)) {
          for my $tframe (local_backup_timeframes($thing, $config_ref)) {
              my $dir = local_backup_dir($thing, $tframe, $config_ref);
              unless (-r $dir) {
                  die "yabsm: error: do not have read permission on '$dir'\n";
              }
              opendir my $dh, $dir or confess "yabsm: internal error: could not opendir '$dir'";
              push @snapshots, map { $_ = "$dir/$_" } grep { is_snapshot_name($_) } readdir($dh);
              closedir $dh;
          }
      }
  
      else {
          die "yabsm: internal error: no such snap, ssh_backup, or local_backup named '$thing'";
      }
  
      @snapshots = sort_snapshots(\@snapshots);
  
      if ($query{type} eq 'all') {
          ;
      }
  
      elsif ($query{type} eq 'newest') {
          @snapshots = answer_newest_query(\@snapshots);
      }
  
      elsif ($query{type} eq 'oldest') {
          @snapshots = answer_oldest_query(\@snapshots);
      }
  
      elsif ($query{type} eq 'after') {
          @snapshots = answer_after_query($query{target}, \@snapshots);
      }
  
      elsif ($query{type} eq 'before') {
          @snapshots = answer_before_query($query{target}, \@snapshots);
      }
  
      elsif ($query{type} eq 'between') {
          @snapshots = answer_between_query($query{target1}, $query{target2}, \@snapshots);
      }
  
      elsif ($query{type} eq 'closest') {
          @snapshots = answer_closest_query($query{target}, \@snapshots);
      }
  
      else {
          confess("yabsm: internal error: no such query type $query{type}");
      }
  
      return wantarray ? @snapshots : \@snapshots;
  }
  
  sub answer_newest_query {
  
      # Return the newest snapshot in @snapshots. Because @snapshots is assumed to
      # be sorted from newest to oldest we know the newest snapshot is the first
      # snapshot in @snapshots.
  
      arg_count_or_die(1, 1, @_);
  
      my @newest;
  
      push @newest, shift->[0];
  
      return wantarray ? @newest : \@newest;
  }
  
  sub answer_oldest_query {
  
      # Return the oldest snapshot in @snapshots. Because @snapshots is assumed to
      # be sorted from newest to oldest we know the oldest snapshot is the last
      # snapshot in @snapshots.
  
      arg_count_or_die(1, 1, @_);
  
      my @oldest;
  
      push @oldest, shift->[-1];
  
      return wantarray ? @oldest : \@oldest;
  }
  
  sub answer_after_query {
  
      # Return all snapshots in @snapshots that are newer than the target snapshot
      # $target. This subroutine assumes that @snapshots is sorted from newest to
      # oldest.
  
      arg_count_or_die(2, 2, @_);
  
      my $target    = shift;
      my @snapshots = @{+shift};
  
      my @after;
  
      foreach my $this_snapshot (@snapshots) {
          if (snapshot_newer($this_snapshot, $target)) {
              push @after, $this_snapshot;
          }
          else {
              last;
          }
      }
  
      return wantarray ? @after : \@after;
  }
  
  sub answer_before_query {
  
      # Return all snapshots in @snapshots that are older than the target snapshot
      # $target. This subroutine assumes that @snapshots is sorted from newest to
      # oldest.
  
      arg_count_or_die(2, 2, @_);
  
      my $target    = shift;
      my @snapshots = @{+shift};
  
      my @before;
  
      for (my $i = $#snapshots; $i >= 0; $i--) {
          my $this_snapshot = $snapshots[$i];
          if (snapshot_older($this_snapshot, $target)) {
              unshift @before, $this_snapshot;
          }
          else {
              last;
          }
      }
  
      return wantarray ? @before : \@before;
  }
  
  sub answer_between_query {
  
      # Return all snapshots in @snapshots that are between $newer and $older
      # (inclusive). This subroutine assumes that @snapshots is sorted from newest
      # to oldest.
  
      arg_count_or_die(3, 3, @_);
  
      my $newer     = shift;
      my $older     = shift;
      my @snapshots = @{+shift};
  
      ($newer, $older) = ($older, $newer) if snapshot_newer($older, $newer);
  
      my @between;
  
      for (my $i = 0; $i <= $#snapshots; $i++) {
          if (snapshot_older_or_eq($snapshots[$i], $newer)) {
              for (my $j = $i; $j <= $#snapshots; $j++) {
                  my $this_snapshot = $snapshots[$j];
                  if (snapshot_newer_or_eq($this_snapshot, $older)) {
                      push @between, $this_snapshot;
                  }
                  else {
                      last;
                  }
              }
              last;
          }
      }
  
      return wantarray ? @between : \@between;
  }
  
  sub answer_closest_query {
  
      # Return the snapshot in @snapshots that is closest to the snapshot $target.
      # This subroutine assumes that @snapshots is sorted from newest to oldest.
  
      arg_count_or_die(2, 2, @_);
  
      my $target    = shift;
      my @snapshots = @{+shift};
  
      my @closest;
  
      for (my $i = 0; $i <= $#snapshots; $i++) {
          my $this_snapshot = $snapshots[$i];
          if (snapshot_older_or_eq($this_snapshot, $target)) {
              if (snapshots_eq($this_snapshot, $target)) {
                  @closest = ($this_snapshot);
              }
              elsif ($i == 0) {
                  @closest = ($this_snapshot);
              }
              else {
                  my $last_snapshot = $snapshots[$i - 1];
                  my $target_epoch = Time::Piece->strptime(join('/', snapshot_name_nums(basename($target))), '%Y/%m/%d/%H/%M')->epoch;
                  my $this_epoch = Time::Piece->strptime(join('/', snapshot_name_nums(basename($this_snapshot))), '%Y/%m/%d/%H/%M')->epoch;
                  my $last_epoch = Time::Piece->strptime(join('/', snapshot_name_nums(basename($last_snapshot))), '%Y/%m/%d/%H/%M')->epoch;
                  my $last_target_diff = abs($last_epoch - $target_epoch);
                  my $this_target_diff = abs($this_epoch - $target_epoch);
                  if ($last_target_diff <= $this_target_diff) {
                      @closest = ($last_snapshot);
                  }
                  else {
                      @closest = ($this_snapshot);
                  }
              }
              last;
          }
          elsif ($i == $#snapshots) {
              @closest = ($this_snapshot);
          }
      }
  
      return wantarray ? @closest : \@closest;
  }
  
                   ####################################
                   #            QUERY PARSER          #
                   ####################################
  
  sub parse_query_or_die {
  
      # Parse $query into a query production or die with a useful error message
      # about about what is wrong with the query.
  
      arg_count_or_die(1, 1, @_);
  
      my $query = shift =~ s/^\s+|\s+$//gr;
  
      my $query_parser = __PACKAGE__->new( toplevel => 'query_parser' );
  
      my $query_production = do {
          try { $query_parser->from_string($query) }
          catch ($e) {
              $e =~ s/on line \d+ //g;
              die "yabsm: query error: $e";
          }
      };
  
      return $query_production;
  }
  
  sub query_parser {
  
      # Top level parser
  
      arg_count_or_die(1, 1, @_);
  
      my $self = shift;
  
      # return this
      my %query;
  
      my $type = $self->any_of(
          sub {
              $self->expect( 'all' );
              $query{type} = 'all';
          },
          sub {
              $self->expect( 'newest' );
              $query{type} = 'newest';
          },
          sub {
              $self->expect( 'oldest' );
              $query{type} = 'oldest';
          },
          sub {
              $self->expect( 'before' );
              $self->commit;
              $self->skip_ws;
              $query{type} = 'before';
              $query{target} = $self->time_abbreviation_parser;
          },
          sub {
              $self->expect( 'after' );
              $self->commit;
              $self->skip_ws;
              $query{type} = 'after';
              $query{target} = $self->time_abbreviation_parser;
          },
          sub {
              $self->expect( 'between' );
              $self->commit;
              $self->skip_ws;
              $query{type} = 'between';
              $query{target1} = $self->time_abbreviation_parser;
              $self->commit;
              $self->skip_ws;
              $query{target2} = $self->time_abbreviation_parser;
          },
          sub {
              my $time = $self->time_abbreviation_parser;
              $query{type} = 'closest';
              $query{target} = $time;
          },
          sub {
              $self->commit;
              $self->skip_ws;
              $self->fail(q(expected <time-abbreviation> or one of 'all', 'newest', 'oldest', 'before', 'after', 'between'))
          }
      );
  
      return \%query;
  }
  
  sub time_abbreviation_parser {
  
      # A time abbreviation is either a relative time or an immediate time.
  
      arg_count_or_die(1, 1, @_);
  
      my $self = shift;
  
      my $snapshot_name =
        $self->any_of( 'relative_time_abbreviation_parser'
                     , 'immediate_time_abbreviation_parser'
                     , sub {
                         $self->commit;
                         $self->skip_ws;
                         $self->fail('expected time abbreviation');
                       }
                     );
  
      return $snapshot_name;
  }
  
  sub relative_time_abbreviation_parser {
  
      # A relative time comes in the form <back-AMOUNT-UNIT> where
      # AMOUNT is a positive integer and UNIT is one of 'days', 'hours',
      # or 'minutes' (or one of their abbreviations). 'back' can always
      # be abbreviated to 'b'.
  
      arg_count_or_die(1, 1, @_);
  
      my $self = shift;
  
      $self->expect( qr/b(ack)?/ );
      $self->expect('-');
      my $amount = $self->expect(qr/[1-9][0-9]*/);
      $self->expect('-');
      my $unit = $self->expect(qr/days|d|hours|hrs|h|minutes|mins|m/);
  
      return n_units_ago_snapshot_name($amount, $unit);
  }
  
  sub immediate_time_abbreviation_parser {
  
      # An immediate time
  
      arg_count_or_die(1, 1, @_);
  
      my $self = shift;
  
      my $yr;
      my $mon;
      my $day;
      my $hr;
      my $min;
  
      my %time_regex = ( yr  => qr/2[0-9]{3}/
                       , mon => qr/[1][0-2]|0?[1-9]/
                       , day => qr/3[01]|[12][0-9]|0?[1-9]/
                       , hr  => qr/2[0123]|1[0-9]|0?[0-9]/
                       , min => qr/[1-5][0-9]|0?[0-9]/
                       );
  
      $self->any_of(
          sub { # yr_mon_day_hr:min
              my $yr_ = $self->expect($time_regex{yr});
              $self->expect('_');
              my $mon_ = $self->expect($time_regex{mon});
              $self->expect('_');
              my $day_ = $self->expect($time_regex{day});
              $self->expect('_');
              my $hr_ = $self->expect($time_regex{hr});
              $self->expect(':');
              my $min_ = $self->expect($time_regex{min});
              $self->any_of(
                  sub { $self->expect(qr/[ ]+/) },
                  sub { $self->at_eos or $self->fail; }
              );
  
              $yr  = $yr_;
              $mon = $mon_;
              $day = $day_;
              $hr  = $hr_;
              $min = $min_;
          },
  
          sub { # yr_mon_day
              my $yr_ = $self->expect($time_regex{yr});
              $self->expect('_');
              my $mon_ = $self->expect($time_regex{mon});
              $self->expect('_');
              my $day_ = $self->expect($time_regex{day});
              $self->any_of(
                  sub { $self->expect(qr/[ ]+/) },
                  sub { $self->at_eos or $self->fail; }
              );
  
              $yr  = $yr_;
              $mon = $mon_;
              $day = $day_;
          },
  
          sub { # mon_day_hr:min
              my $mon_ = $self->expect($time_regex{mon});
              $self->expect('_');
              my $day_ = $self->expect($time_regex{day});
              $self->expect('_');
              my $hr_ = $self->expect($time_regex{hr});
              $self->expect(':');
              my $min_ = $self->expect($time_regex{min});
              $self->any_of(
                  sub { $self->expect(qr/[ ]+/) },
                  sub { $self->at_eos or $self->fail; }
              );
  
              $mon = $mon_;
              $day = $day_;
              $hr  = $hr_;
              $min = $min_;
          },
  
          sub { # mon_day_hr
              my $mon_ = $self->expect($time_regex{mon});
              $self->expect('_');
              my $day_ = $self->expect($time_regex{day});
              $self->expect('_');
              my $hr_ = $self->expect($time_regex{hr});
              $self->any_of(
                  sub { $self->expect(qr/[ ]+/) },
                  sub { $self->at_eos or $self->fail; }
              );
  
              $mon = $mon_;
              $day = $day_;
              $hr  = $hr_;
          },
  
          sub { # mon_day
              my $mon_ = $self->expect($time_regex{mon});
              $self->expect('_');
              my $day_ = $self->expect($time_regex{day});
              $self->any_of(
                  sub { $self->expect(qr/[ ]+/) },
                  sub { $self->at_eos or $self->fail; }
              );
  
              $mon = $mon_;
              $day = $day_;
          },
  
          sub { # day_hr:min
              my $day_ = $self->expect($time_regex{day});
              $self->expect('_');
              my $hr_ = $self->expect($time_regex{hr});
              $self->expect(':');
              my $min_ = $self->expect($time_regex{min});
              $self->any_of(
                  sub { $self->expect(qr/[ ]+/) },
                  sub { $self->at_eos or $self->fail; }
              );
  
              $day = $day_;
              $hr  = $hr_;
              $min = $min_;
          },
  
          sub { # hr:min
              my $hr_ = $self->expect($time_regex{hr});
              $self->expect(':');
              my $min_ = $self->expect($time_regex{min});
              $self->any_of(
                  sub { $self->expect(qr/[ ]+/) },
                  sub { $self->at_eos or $self->fail; }
              );
  
              $hr  = $hr_;
              $min = $min_;
          }
      );
  
      my $t = localtime;
  
      $yr  //= $t->year;
      $mon //= $t->mon;
      $day //= $t->mday;
      $hr  //= 0;
      $min //= 0;
  
      return nums_to_snapshot_name($yr, $mon, $day, $hr, $min);
  }
  
                   ####################################
                   #           TIME FUNCTIONS         #
                   ####################################
  
  sub n_units_ago_snapshot_name {
  
      # Return a snapshot name representing the time $n $unit's ago from now.
  
      arg_count_or_die(2, 2, @_);
  
      my $n    = shift;
      my $unit = shift;
  
      unless ($n =~ /^\d+$/ && $n > 0) {
          confess "yabsm: internal error: '$n' is not a positive integer";
      }
  
      my $seconds_per_unit;
  
      if    ($unit =~ /^(?:minutes|mins|m)$/) { $seconds_per_unit = 60    }
      elsif ($unit =~ /^(?:hours|hrs|h)$/   ) { $seconds_per_unit = 3600  }
      elsif ($unit =~ /^(?:days|d)$/        ) { $seconds_per_unit = 86400 }
      else {
          confess "yabsm: internal error: '$unit' is not a valid time unit";
      }
  
      my $t = localtime;
  
      my ($yr, $mon, $day, $hr, $min) = ($t->year, $t->mon, $t->mday, $t->hour, $t->min);
  
      my $tp = Time::Piece->strptime("$yr/$mon/$day/$hr/$min", '%Y/%m/%d/%H/%M');
  
      $tp -= $n * $seconds_per_unit;
  
      return nums_to_snapshot_name($tp->year, $tp->mon, $tp->mday, $tp->hour, $tp->min);
  }
  
  1;
APP_YABSM_COMMAND_FIND

$fatpacked{"App/Yabsm/Config/Parser.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_YABSM_CONFIG_PARSER';
  #  Author:    Nicholas Hubbard
  #  Copyright: Nicholas Hubbard
  #  License:   GPL_3
  #  WWW:       https://github.com/NicholasBHubbard/Yabsm
  
  #  Provides functionality for Yabsm configuration parsing using the
  #  Parser::MGC library. Tests for the parser are located at
  #  src/t/Config.t.
  #
  #  This parser produces a multi-dimensional hash data structure with
  #  the following skeleton:
  #
  #  %config = ( yabsm_dir     => '/.snapshots/yabsm'
  #
  #              subvols       => { foo => { mountpoint=/foo_dir }
  #                               , bar => { mountpoint=/bar_dir }
  #                               , ...
  #                               },
  #              snaps         => { foo_snap => { key=val, ... }
  #                               , bar_snap => { key=val, ... }
  #                               , ...
  #                               },
  #              ssh_backups   => { foo_ssh_backup => { key=val, ... }
  #                               , bar_ssh_backup => { key=val, ... }
  #                               ,  ...
  #                               },
  #              local_backups => { foo_local_backup => { key=val, ... }
  #                               , bar_local_backup => { key=val, ... }
  #                               , ...
  #                               }
  #            );
  
  use strict;
  use warnings;
  use v5.34.0;
  
  package App::Yabsm::Config::Parser;
  
  use App::Yabsm::Tools qw(arg_count_or_die);
  
  use Carp qw(confess);
  use Array::Utils qw(array_minus);
  use Regexp::Common qw(net);
  use Feature::Compat::Try;
  
  use Parser::MGC;
  use base 'Parser::MGC';
  
                   ####################################
                   #              EXPORTED            #
                   ####################################
  
  use Exporter qw(import);
  our @EXPORT_OK = qw(parse_config_or_die);
  
  sub parse_config_or_die {
  
      # Attempt to parse $file into a yabsm configuration data structure.
  
      arg_count_or_die(0, 1, @_);
  
      my $file = shift // '/etc/yabsm.conf';
  
      -f $file or die "yabsm: config error: no such file '$file'\n";
      -r $file or die "yabsm: config error: can not read file '$file'\n";
  
      # Initialize the Parser::MGC parser object
      my $parser = __PACKAGE__->new( toplevel => 'config_parser'
                                   , patterns => { comment => &grammar->{comment}
                                                 , ws      => &grammar->{whitespace}
                                                 }
                                   );
  
      my $config_ref = do {
          try { $parser->from_file($file) }
          catch ($e) { $e =~ s/\s+$// ; die "yabsm: config error: $e\n" }
      };
  
      my ($config_valid, @error_msgs) = check_config($config_ref);
  
      if ($config_valid) {
          return wantarray ? %{ $config_ref} : $config_ref;
      }
      else {
          my $error_msg = join '', map { $_ = "$_\n" } @error_msgs;
          die $error_msg;
      }
  }
  
                   ####################################
                   #              GRAMMAR             #
                   ####################################
  
  sub grammar {
  
      # Return a hash of all the atomic grammar elements of the yabsm config
      # language.
  
      arg_count_or_die(0, 0, @_);
  
      my %grammar = (
          name          => qr/[a-zA-Z][-_a-zA-Z0-9]*/,
          subvol        => qr/[a-zA-Z][-_a-zA-Z0-9]*/,
          dir           => qr/\/[a-zA-Z0-9._:\-\/]*/,
          mountpoint    => qr/\/[a-zA-Z0-9._:\-\/]*/,
          # timeframes example: hourly,monthly,daily
          timeframes    => qr/((5minute|hourly|daily|weekly|monthly),)+(5minute|hourly|daily|weekly|monthly)|(5minute|hourly|daily|weekly|monthly)/,
          ssh_dest      => qr/([a-z_]([a-z0-9_-]{0,31}|[a-z0-9_-]{0,30}\$)@)?(([A-Za-z][A-Za-z0-9_-]*)|$RE{net}{IPv4}{strict}|$RE{net}{IPv6})/,
          opening_brace => qr/{/,
          closing_brace => qr/}/,
          equals_sign   => qr/=/,
          comment       => qr/[\s\t]*#.*/,
          whitespace    => qr/[\s\t\n]+/,
          timeframe_sub_grammar => {
  
              '5minute_keep' => qr/[1-9][0-9]*/,
              hourly_keep    => qr/[1-9][0-9]*/,
              daily_keep     => qr/[1-9][0-9]*/,
              weekly_keep    => qr/[1-9][0-9]*/,
              monthly_keep   => qr/[1-9][0-9]*/,
  
              # comma seperated hh:mm's
              daily_times    => qr/(((0[0-9]|1[0-9]|2[0-3]):[0-5][0-9]),)+((0[0-9]|1[0-9]|2[0-3]):[0-5][0-9])|(0[0-9]|1[0-9]|2[0-3]):[0-5][0-9]/,
  
              # hh:mm
              weekly_time    => qr/(0[0-9]|1[0-9]|2[0-3]):[0-5][0-9]/,
              monthly_time   => qr/(0[0-9]|1[0-9]|2[0-3]):[0-5][0-9]/,
  
              weekly_day     => qr/[1-7]|monday|tuesday|wednesday|thursday|friday|saturday|sunday/,
              monthly_day    => qr/3[01]|[12][0-9]|[1-9]/ # 1-31
          }
      );
  
      return wantarray ? %grammar : \%grammar;
  }
  
  sub grammar_msg {
  
      # Return a hash that associates grammar non-terminals to a linguistic
      # description of their expected value. Used for generating meaningful error
      # messages.
  
      arg_count_or_die(0, 0, @_);
  
      my %grammar_msg = (
          name           => 'thing name',
          subvol         => 'subvol name',
          dir            => 'absolute path',
          mountpoint     => 'absolute path',
          timeframes     => 'comma separated timeframes',
          ssh_dest       => 'SSH destination',
          opening_brace  => q('{'}),
          closing_brace  => q('}'),
          equals_sign    => q('='),
          comment        => 'comment',
          whitespace     => 'whitespace',
          #keep
          '5minute_keep' => 'positive integer',
          hourly_keep    => 'positive integer',
          daily_keep     => 'positive integer',
          weekly_keep    => 'positive integer',
          monthly_keep   => 'positive integer',
          #time
          daily_times    => q(comma seperated list of times in 'hh:mm' form'),
          weekly_time    => q(time in 'hh:mm' form),
          monthly_time   => q(time in 'hh:mm' form),
          #day
          weekly_day     => 'week day',
          monthly_day    => 'month day'
      );
  
      return wantarray ? %grammar_msg : \%grammar_msg;
  }
  
  sub subvol_settings_grammar {
  
      # Return a hash of a subvols key=val grammar.
  
      arg_count_or_die(0, 0, @_);
  
      my %grammar = grammar();
  
      my %subvol_settings_grammar = (
          mountpoint => $grammar{mountpoint}
      );
  
      return wantarray ? %subvol_settings_grammar : \%subvol_settings_grammar;
  }
  
  sub snap_settings_grammar {
  
      # Return a hash of a snaps key=val grammar. Optionally takes a false value
      # to exclude the timeframe subgrammar from the returned grammar.
  
      arg_count_or_die(0, 1, @_);
  
      my $include_tf = shift // 1;
  
      my %grammar = grammar();
  
      my %timeframe_sub_grammar =
        $include_tf ? %{ $grammar{timeframe_sub_grammar} } : ();
  
      my %snap_settings_grammar = (
          subvol     => $grammar{subvol},
          timeframes => $grammar{timeframes},
          %timeframe_sub_grammar
      );
  
      return wantarray ? %snap_settings_grammar : \%snap_settings_grammar;
  }
  
  sub ssh_backup_settings_grammar {
  
      # Return a hash of a ssh_backups key=val grammar. Optionally takes a false
      # value to exclude the timeframe subgrammar from the returned grammar.
  
      arg_count_or_die(0, 1, @_);
  
      my $include_tf = shift // 1;
  
      my %grammar = grammar();
  
      my %timeframe_sub_grammar =
        $include_tf ? %{ $grammar{timeframe_sub_grammar} } : ();
  
      my %ssh_backup_settings_grammar = (
          subvol     => $grammar{subvol},
          ssh_dest   => $grammar{ssh_dest},
          dir        => $grammar{dir},
          timeframes => $grammar{timeframes},
          %timeframe_sub_grammar
      );
  
      return wantarray ? %ssh_backup_settings_grammar : \%ssh_backup_settings_grammar;
  }
  
  sub local_backup_settings_grammar {
  
      # Return a hash of a local_backups key=val grammar. Optionally takes a false
      # value to exclude the timeframe subgrammar from the returned grammar.
  
      arg_count_or_die(0, 1, @_);
  
      my $include_tf = shift // 1;
  
      my %grammar = grammar();
  
      my %timeframe_sub_grammar =
        $include_tf ? %{ $grammar{timeframe_sub_grammar} } : ();
  
      my %local_backup_settings_grammar = (
          subvol     => $grammar{subvol},
          dir        => $grammar{dir},
          timeframes => $grammar{timeframes},
          %timeframe_sub_grammar
      );
  
      return wantarray ? %local_backup_settings_grammar : \%local_backup_settings_grammar;
  }
  
                   ####################################
                   #              PARSER              #
                   ####################################
  
  sub config_parser {
  
      # Top level parser
  
      arg_count_or_die(1, 1, @_);
  
      my $self = shift;
  
      # return this
      my %config;
  
      # Define the parser
  
      my %grammar = grammar();
  
      $self->sequence_of( sub {
          $self->commit;
          $self->any_of(
              sub {
                  $self->expect( 'yabsm_dir' );
                  $self->commit;
                  exists $config{yabsm_dir} and $self->fail('yabsm_dir is already defined');
                  $self->maybe_expect('=') // $self->fail(q(expected '='));
                  my $dir = $self->maybe_expect($grammar{dir}) // $self->fail(grammar_msg->{dir});
                  $config{yabsm_dir} = $dir;
              },
              sub {
                  $self->expect( 'subvol' );
                  $self->commit;
                  my $name = $self->maybe_expect( $grammar{name} );
                  $name // $self->fail('expected subvol name');
                  exists $config{subvols}{$name}       and $self->fail("already have a subvol named '$name'");
                  exists $config{snaps}{$name}         and $self->fail("already have a snap named '$name'");
                  exists $config{ssh_backups}{$name}   and $self->fail("already have a ssh_backup named '$name'");
                  exists $config{local_backups}{$name} and $self->fail("already have a local_backup named '$name'");
                  my $kvs = $self->scope_of('{', 'subvol_settings_parser' ,'}');
                  $config{subvols}{$name} = $kvs;
              },
              sub {
                  $self->expect( 'snap' );
                  $self->commit;
                  my $name = $self->maybe_expect( $grammar{name} );
                  $name // $self->fail('expected snap name');
                  exists $config{subvols}{$name}       and $self->fail("already have a subvol named '$name'");
                  exists $config{snaps}{$name}         and $self->fail("already have a snap named '$name'");
                  exists $config{ssh_backups}{$name}   and $self->fail("already have a ssh_backup named '$name'");
                  exists $config{local_backups}{$name} and $self->fail("already have a local_backup named '$name'");
                  my $kvs = $self->scope_of('{', 'snap_settings_parser', '}');
                  $config{snaps}{$name} = $kvs;
              },
              sub {
                  $self->expect( 'ssh_backup' );
                  $self->commit;
                  my $name = $self->maybe_expect( $grammar{name} );
                  $name // $self->fail('expected ssh_backup name');
                  exists $config{subvols}{$name}       and $self->fail("already have a subvol named '$name'");
                  exists $config{snaps}{$name}         and $self->fail("already have a snap named '$name'");
                  exists $config{ssh_backups}{$name}   and $self->fail("already have a ssh_backup named '$name'");
                  exists $config{local_backups}{$name} and $self->fail("already have a local_backup named '$name'");
                  my $kvs = $self->scope_of('{', 'ssh_backup_settings_parser', '}');
                  $config{ssh_backups}{$name} = $kvs;
              },
              sub {
                  $self->expect( 'local_backup' );
                  $self->commit;
                  my $name = $self->maybe_expect( $grammar{name} );
                  $name // $self->fail('expected local_backup name');
                  exists $config{subvols}{$name}       and $self->fail("already have a subvol named '$name'");
                  exists $config{snaps}{$name}         and $self->fail("already have a snap named '$name'");
                  exists $config{ssh_backups}{$name}   and $self->fail("already have a ssh_backup named '$name'");
                  exists $config{local_backups}{$name} and $self->fail("already have a local_backup named '$name'");
                  my $kvs = $self->scope_of('{', 'local_backup_settings_parser', '}');
                  $config{local_backups}{$name} = $kvs;
              },
              sub {
                  $self->commit;
                  $self->skip_ws; # skip_ws also skips comments
                  $self->fail(q(expected one of 'subvol', 'snap', 'ssh_backup', or 'local_backup'));
              }
          );
      });
  
      return wantarray ? %config : \%config;
  }
  
  sub settings_parser {
  
      # Abstract method that parses a sequence of key=val pairs based off of the
      # input grammar %grammar. The arg $type is simply a string that is either
      # 'subvol', 'snap', 'ssh_backup', or 'local_backup' and is only used for
      # error message generation. This method should be called from a wrapper
      # method.
  
      arg_count_or_die(3, 3, @_);
  
      my $self    = shift;
      my $type    = shift;
      my $grammar = shift;
  
      my @settings = keys %{ $grammar };
      my $setting_regex = join '|', @settings;
  
      # return this
      my %kvs;
  
      $self->sequence_of( sub {
          $self->commit;
  
          my $setting = $self->maybe_expect( qr/$setting_regex/ )
            // $self->fail("expected a $type setting");
  
          $self->maybe_expect('=') // $self->fail('expected "="');
  
          my $value = $self->maybe_expect($grammar->{$setting})
            // $self->fail('expected ' . grammar_msg->{$setting});
  
          $kvs{$setting} = $value;
      });
  
      return wantarray ? %kvs : \%kvs;
  }
  
  sub subvol_settings_parser {
      arg_count_or_die(1, 1, @_);
      my $self = shift;
      my $subvol_settings_grammar = subvol_settings_grammar();
      $self->settings_parser('subvol', $subvol_settings_grammar);
  }
  
  sub snap_settings_parser {
      arg_count_or_die(1, 1, @_);
      my $self = shift;
      my $snap_settings_grammar = snap_settings_grammar();
      $self->settings_parser('snap', $snap_settings_grammar);
  }
  
  sub ssh_backup_settings_parser {
      arg_count_or_die(1, 1, @_);
      my $self = shift;
      my $ssh_backup_settings_grammar = ssh_backup_settings_grammar();
      $self->settings_parser('ssh_backup', $ssh_backup_settings_grammar);
  }
  
  sub local_backup_settings_parser {
      arg_count_or_die(1, 1, @_);
      my $self = shift;
      my $local_backup_settings_grammar = local_backup_settings_grammar();
      $self->settings_parser('local_backup', $local_backup_settings_grammar);
  }
  
                   ####################################
                   #          ERROR ANALYSIS          #
                   ####################################
  
  sub check_config {
  
      # Ensure that $config_ref references a valid yabsm configuration.  If the
      # config is valid return a list containing only the value 1, otherwise
      # return multiple values where the first value is 0 and the rest of the
      # values are the corresponding error messages.
  
      arg_count_or_die(1, 1, @_);
  
      my $config_ref = shift;
  
      my @error_msgs;
  
      unless ($config_ref->{yabsm_dir}) {
          push @error_msgs, q(yabsm: config error: missing required setting 'yabsm_dir');
      }
  
      unless ($config_ref->{snaps} || $config_ref->{ssh_backups} || $config_ref->{local_backups}) {
          push @error_msgs, 'yabsm: config error: no defined snaps, ssh_backups, or local_backups';
      }
  
      push @error_msgs, snap_errors($config_ref);
      push @error_msgs, ssh_backup_errors($config_ref);
      push @error_msgs, local_backup_errors($config_ref);
  
      if (@error_msgs) {
          return (0, @error_msgs);
      }
      else {
          return (1);
      }
  }
  
  sub snap_errors {
  
      # Ensure that all the snaps defined in the config referenced by $config_ref
      # are not missing required snap settings and are snapshotting a defined
      # subvol.
  
      arg_count_or_die(1, 1, @_);
  
      my $config_ref = shift;
  
      # return this
      my @error_msgs;
  
      # Base required settings. Passing 0 to snap_settings_grammar excludes
      # timeframe settings from the returned hash.
      my @base_required_settings = keys %{ snap_settings_grammar(0) };
  
      foreach my $snap (keys %{ $config_ref->{snaps} }) {
  
          # Make sure that the subvol being snapped exists
          my $subvol = $config_ref->{snaps}{$snap}{subvol};
          if (defined $subvol) {
              unless (grep { $subvol eq $_ } keys %{ $config_ref->{subvols} }) {
                  push @error_msgs, "yabsm: config error: snap '$snap' is snapshotting up a non-existent subvol '$subvol'";
              }
          }
  
          # Make sure all required settings are defined
          my @required_settings = @base_required_settings;
          my $timeframes = $config_ref->{snaps}{$snap}{timeframes};
          if (defined $timeframes) {
              push @required_settings, required_timeframe_settings($timeframes);
          }
          my @defined_settings = keys %{ $config_ref->{snaps}{$snap} };
          my @missing_settings = array_minus(@required_settings, @defined_settings);
          foreach my $missing (@missing_settings) {
              push @error_msgs, "yabsm: config error: snap '$snap' missing required setting '$missing'";
          }
      }
  
      return wantarray ? @error_msgs : \@error_msgs;
  }
  
  sub ssh_backup_errors {
  
      # Ensure that all the ssh_backups defined in the config referenced by
      # $config_ref are not missing required ssh_backup settings and are backing
      # up a defined subvol.
  
      arg_count_or_die(1, 1, @_);
  
      my $config_ref = shift;
  
      # return this
      my @error_msgs;
  
      # Base required settings. Passing 0 to ssh_backup_settings_grammar excludes
      # timeframe settings from the returned hash.
      my @base_required_settings = keys %{ ssh_backup_settings_grammar(0) };
  
      foreach my $ssh_backup (keys %{ $config_ref->{ssh_backups} }) {
  
          # Make sure that the subvol being backed up exists
          my $subvol = $config_ref->{ssh_backups}{$ssh_backup}{subvol};
          if (defined $subvol) {
              unless (grep { $subvol eq $_ } keys %{ $config_ref->{subvols} }) {
                  push @error_msgs, "yabsm: config error: ssh_backup '$ssh_backup' is backing up a non-existent subvol '$subvol'";
              }
          }
  
          # Make sure all required settings are defined
          my @required_settings = @base_required_settings;
          my $timeframes = $config_ref->{ssh_backups}{$ssh_backup}{timeframes};
          if (defined $timeframes) {
              push @required_settings, required_timeframe_settings($timeframes);
          }
          my @defined_settings = keys %{ $config_ref->{ssh_backups}{$ssh_backup} };
          my @missing_settings = array_minus(@required_settings, @defined_settings);
          foreach my $missing (@missing_settings) {
              push @error_msgs, "yabsm: config error: ssh_backup '$ssh_backup' missing required setting '$missing'";
          }
      }
  
      return wantarray ? @error_msgs : \@error_msgs;
  }
  
  sub local_backup_errors {
  
      # Ensure that all the local_backups defined in the config referenced by
      # $config_ref are not missing required local_backup settings and are backing
      # up a defined subvol
  
      arg_count_or_die(1, 1, @_);
  
      my $config_ref = shift;
  
      # return this
      my @error_msgs;
  
      # Base required settings. Passing 0 to local_backup_settings_grammar
      # excludes timeframe settings from the returned hash.
      my @base_required_settings = keys %{ local_backup_settings_grammar(0) };
  
      foreach my $local_backup (keys %{ $config_ref->{local_backups} }) {
  
          # Make sure that the subvol being backed up exists
          my $subvol = $config_ref->{local_backups}{$local_backup}{subvol};
          if (defined $subvol) {
              unless (grep { $subvol eq $_ } keys %{ $config_ref->{subvols} }) {
                  push @error_msgs, "yabsm: config error: local_backup '$local_backup' is backing up a non-existent subvol '$subvol'";
              }
          }
  
          # Make sure all required settings are defined
          my @required_settings = @base_required_settings;
          my $timeframes = $config_ref->{local_backups}{$local_backup}{timeframes};
          if (defined $timeframes) {
              push @required_settings, required_timeframe_settings($timeframes);
          }
          my @defined_settings = keys %{ $config_ref->{local_backups}{$local_backup} };
          my @missing_settings = array_minus(@required_settings, @defined_settings);
          foreach my $missing (@missing_settings) {
              push @error_msgs, "yabsm: config error: local_backup '$local_backup' missing required setting '$missing'";
          }
      }
  
      return wantarray ? @error_msgs : \@error_msgs;
  }
  
  sub required_timeframe_settings {
  
      # Given a timeframes value like 'hourly,daily,monthly' returns a list of
      # required settings. This subroutine is used to dynamically determine what
      # settings are required for certain config entities.
  
      arg_count_or_die(1, 1, @_);
  
      my $tframes = shift;
  
      my @timeframes = split ',', $tframes;
  
      # return this
      my @required;
  
      foreach my $tframe (@timeframes) {
          if    ($tframe eq '5minute') { push @required, qw(5minute_keep) }
          elsif ($tframe eq 'hourly')  { push @required, qw(hourly_keep) }
          elsif ($tframe eq 'daily')   { push @required, qw(daily_keep daily_times) }
          elsif ($tframe eq 'weekly')  { push @required, qw(weekly_keep weekly_time weekly_day) }
          elsif ($tframe eq 'monthly') { push @required, qw(monthly_keep monthly_time monthly_day) }
          else {
              confess("yabsm: internal error: no such timeframe '$tframe'");
          }
      }
  
      return @required;
  }
  
  1;
APP_YABSM_CONFIG_PARSER

$fatpacked{"App/Yabsm/Config/Query.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_YABSM_CONFIG_QUERY';
  #  Author:    Nicholas Hubbard
  #  Copyright: Nicholas Hubbard
  #  License:   GPL_3
  #  WWW:       https://github.com/NicholasBHubbard/Yabsm
  
  #  Provides functions for querying the Yabsm configuration hash that is produced
  #  by Yabsm::Config::Parser::parse_config_or_die().
  
  use strict;
  use warnings;
  use v5.34.0;
  
  package App::Yabsm::Config::Query;
  
  use App::Yabsm::Tools qw(arg_count_or_die);
  
  use Carp qw(confess);
  
  use Exporter qw(import);
  our @EXPORT_OK = qw(is_timeframe
                      is_timeframe_or_die
                      is_weekday
                      is_weekday_or_die
                      time_hour
                      time_minute
                      yabsm_dir
                      yabsm_user_home
                      subvol_exists
                      subvol_exists_or_die
                      snap_exists
                      snap_exists_or_die
                      ssh_backup_exists
                      ssh_backup_exists_or_die
                      local_backup_exists
                      local_backup_exists_or_die
                      backup_exists
                      backup_exists_or_die
                      all_subvols
                      all_snaps
                      all_ssh_backups
                      all_local_backups
                      subvol_mountpoint
                      snap_subvol
                      snap_mountpoint
                      snap_dest
                      snap_dir
                      snap_timeframes
                      ssh_backup_subvol
                      ssh_backup_mountpoint
                      ssh_backup_dir
                      ssh_backup_timeframes
                      ssh_backup_ssh_dest
                      local_backup_subvol
                      local_backup_mountpoint
                      local_backup_dir
                      local_backup_timeframes
                      all_snaps_of_subvol
                      all_ssh_backups_of_subvol
                      all_local_backups_of_subvol
                      snap_wants_timeframe
                      snap_wants_timeframe_or_die
                      ssh_backup_wants_timeframe
                      ssh_backup_wants_timeframe_or_die
                      local_backup_wants_timeframe
                      local_backup_wants_timeframe_or_die
                      snap_timeframe_keep
                      snap_5minute_keep
                      snap_hourly_keep
                      snap_daily_keep
                      snap_daily_times
                      snap_weekly_keep
                      snap_weekly_time
                      snap_weekly_day
                      snap_monthly_keep
                      snap_monthly_time
                      snap_monthly_day
                      ssh_backup_timeframe_keep
                      ssh_backup_5minute_keep
                      ssh_backup_hourly_keep
                      ssh_backup_daily_keep
                      ssh_backup_daily_times
                      ssh_backup_weekly_keep
                      ssh_backup_weekly_time
                      ssh_backup_weekly_day
                      ssh_backup_monthly_keep
                      ssh_backup_monthly_time
                      ssh_backup_monthly_day
                      local_backup_timeframe_keep
                      local_backup_5minute_keep
                      local_backup_hourly_keep
                      local_backup_daily_keep
                      local_backup_daily_times
                      local_backup_weekly_keep
                      local_backup_weekly_time
                      local_backup_weekly_day
                      local_backup_monthly_keep
                      local_backup_monthly_time
                      local_backup_monthly_day
                     );
  our %EXPORT_TAGS = ( ALL => [ @EXPORT_OK ] );
  
                   ####################################
                   #            SUBROUTINES           #
                   ####################################
  
  sub is_timeframe {
  
      # Return 1 if given a valid timeframe and return 0 otherwise.
  
      arg_count_or_die(1, 1, @_);
  
      return 0+(shift =~ /^(5minute|hourly|daily|weekly|monthly)$/);
  }
  
  sub is_timeframe_or_die {
  
      # Wrapper around &is_timeframe that Carp::Confess's if it returns false.
  
      arg_count_or_die(1, 1, @_);
  
      my $tframe = shift;
  
      unless ( is_timeframe($tframe) ) {
          confess("yabsm: internal error: no such timeframe '$tframe'");
      }
  
      return 1;
  }
  
  sub is_weekday {
  
      # Return 1 if given a valid week day and return 0 otherwise.
  
      arg_count_or_die(1, 1, @_);
  
      return 0+(shift =~ /^(monday|tuesday|wednesday|thursday|friday|saturday|sunday)$/);
  }
  
  sub is_weekday_or_die {
  
      # Wrapper around &is_weekday that Carp::Confess's if it returns false.
  
      arg_count_or_die(1, 1, @_);
  
      my $weekday = shift;
  
      unless ( is_weekday($weekday) ) {
          confess("yabsm: internal error: no such weekday '$weekday'");
      }
  
      return 1;
  }
  
  sub weekday_number {
  
      # Return the number associated with $weekday which is a string representation
      # of a weekday. Monday is considered the first day of the week.
  
      arg_count_or_die(1, 1, @_);
  
      my $weekday = shift;
  
      is_weekday_or_die($weekday);
  
      $weekday eq 'monday'    and return 1;
      $weekday eq 'tuesday'   and return 2;
      $weekday eq 'wednesday' and return 3;
      $weekday eq 'thursday'  and return 4;
      $weekday eq 'friday'    and return 5;
      $weekday eq 'saturday'  and return 6;
      $weekday eq 'sunday'    and return 7;
  }
  
  sub is_time {
  
      # Return 1 if passed a valid 'hh:mm' time and return 0 otherwise.
  
      arg_count_or_die(1, 1, @_);
  
      my ($hr, $min) = shift =~ /^(\d\d):(\d\d)$/
        or return 0;
  
      $hr  >= 0 && $hr  <= 23 or return 0;
      $min >= 0 && $min <= 59 or return 0;
  
      return 1;
  }
  
  sub is_time_or_die {
  
      # Wrapper around &is_time that Carp::Confess's if it returns false.
  
      arg_count_or_die(1, 1, @_);
  
      my $time = shift;
  
      unless ( is_time($time) ) {
          confess("yabsm: internal error: '$time' is not a valid 'hh:mm' time");
      }
  
      return 1;
  }
  
  sub time_hour {
  
      # Return the hour of a 'hh:mm' time.
  
      arg_count_or_die(1, 1, @_);
  
      my $time = shift;
  
      is_time_or_die($time);
  
      my ($hr) = $time =~ /^(\d\d):\d\d$/;
  
      return 0+$hr;
  }
  
  sub time_minute {
  
      # Return the minute of a 'hh:mm' time.
  
      arg_count_or_die(1, 1, @_);
  
      my $time = shift;
  
      is_time_or_die($time);
  
      my ($min) = $time =~ /^\d\d:(\d\d)$/;
  
      return 0+$min;
  }
  
  sub yabsm_dir {
  
      # Return the users yabsm_dir without trailing /'s.
  
      arg_count_or_die(1, 1, @_);
  
      my $config_ref = shift;
  
      return $config_ref->{yabsm_dir} =~ s/\/+$//r;
  }
  
  sub yabsm_user_home {
  
      # Return the yabsm users home directory.
  
      arg_count_or_die(1, 1, @_);
  
      return yabsm_dir( shift ) . '/.yabsm-var/yabsm-user-home';
  }
  
  sub subvol_exists {
  
      # Return 1 if $subvol is a subvol defined in $config_ref and return 0
      # otherwise.
  
      arg_count_or_die(2, 2, @_);
  
      my $subvol     = shift;
      my $config_ref = shift;
  
      return 0+(exists $config_ref->{subvols}{$subvol});
  }
  
  sub subvol_exists_or_die {
  
      # Wrapper around &subvol_exists that Carp::Confess's if it returns false.
  
      arg_count_or_die(2, 2, @_);
  
      my $subvol     = shift;
      my $config_ref = shift;
  
      unless ( subvol_exists($subvol, $config_ref) ) {
          confess("yabsm: internal error: no subvol named '$subvol'");
      }
  
      return 1;
  }
  
  sub snap_exists {
  
      # Return 1 if $snap is a snap defined in $config_ref and return 0 otherwise.
  
      arg_count_or_die(2, 2, @_);
  
      my $snap     = shift;
      my $config_ref = shift;
  
      return 0+(exists $config_ref->{snaps}{$snap});
  }
  
  sub snap_exists_or_die {
  
      # Wrapper around &snap_exists that Carp::Confess's if it returns false.
  
      arg_count_or_die(2, 2, @_);
  
      my $snap       = shift;
      my $config_ref = shift;
  
      unless ( snap_exists($snap, $config_ref) ) {
          confess("yabsm: internal error: no snap named '$snap'");
      }
  
      return 1;
  }
  
  sub ssh_backup_exists {
  
      # Return 1 if $ssh_backup is a ssh_backup defined in $config_ref and return 0
      # otherwise.
  
      arg_count_or_die(2, 2, @_);
  
      my $ssh_backup = shift;
      my $config_ref = shift;
  
      return 0+(exists $config_ref->{ssh_backups}{$ssh_backup});
  }
  
  sub ssh_backup_exists_or_die {
  
      # Wrapper around &ssh_backup_exists that Carp::Confess's if it returns false.
  
      arg_count_or_die(2, 2, @_);
  
      my $ssh_backup = shift;
      my $config_ref = shift;
  
      unless ( ssh_backup_exists($ssh_backup, $config_ref) ) {
          confess("yabsm: internal error: no ssh_backup named '$ssh_backup'");
      }
  
      return 1;
  }
  
  sub local_backup_exists {
  
      # Return 1 if $local_backup is a lcoal_backup defined in $config_ref and
      # return 0 otherwise.
  
      arg_count_or_die(2, 2, @_);
  
      my $local_backup = shift;
      my $config_ref   = shift;
  
      return 0+(exists $config_ref->{local_backups}{$local_backup});
  }
  
  sub local_backup_exists_or_die {
  
      # Wrapper around &local_backup_exists that Carp::Confess's if it returns
      # false.
  
      arg_count_or_die(2, 2, @_);
  
      my $local_backup = shift;
      my $config_ref   = shift;
  
      unless ( local_backup_exists($local_backup, $config_ref) ) {
          confess("yabsm: internal error: no local_backup named '$local_backup'");
      }
  
      return 1;
  }
  
  sub backup_exists {
  
      # Return 1 if $backup is either an ssh_backup or a local_backup and return 0
      # otherwise.
  
      arg_count_or_die(2, 2, @_);
  
      my $backup     = shift;
      my $config_ref = shift;
  
      return 1 if ssh_backup_exists($backup, $config_ref);
      return local_backup_exists($backup, $config_ref);
  }
  
  sub backup_exists_or_die {
  
      # Wrapper around &backup_exists that Carp::Confess's if it returns false.
  
      arg_count_or_die(2, 2, @_);
  
      my $backup     = shift;
      my $config_ref = shift;
  
      unless ( backup_exists($backup, $config_ref) ) {
          confess("yabsm: internal error: no ssh_backup or local_backup named '$backup'");
      }
  
      return 1;
  }
  
  sub all_subvols {
  
      # Return a list of all the subvol names defined in $config_ref.
  
      arg_count_or_die(1, 1, @_);
  
      my $config_ref = shift;
  
      my @subvols = sort keys %{ $config_ref->{subvols} };
  
      return @subvols;
  }
  
  sub all_snaps {
  
      # Return a list of all the snap names defined in $config_ref.
  
      arg_count_or_die(1, 1, @_);
  
      my $config_ref = shift;
  
      my @snaps = sort keys %{ $config_ref->{snaps} };
  
      return @snaps;
  }
  
  sub all_ssh_backups {
  
      # Return a list of all the ssh_backup names defined in $config_ref.
  
      arg_count_or_die(1, 1, @_);
  
      my $config_ref = shift;
  
      my @ssh_backups = sort keys %{ $config_ref->{ssh_backups} };
  
      return @ssh_backups;
  }
  
  sub all_local_backups {
  
      # Return a list of all the local_backup names defined in $config_ref.
  
      arg_count_or_die(1, 1, @_);
  
      my $config_ref = shift;
  
      my @all_local_backups = sort keys %{ $config_ref->{local_backups} };
  
      return @all_local_backups;
  }
  
  sub subvol_mountpoint {
  
      # Return the the subvol $subvol's mountpoint value.
  
      arg_count_or_die(2, 2, @_);
  
      my $subvol     = shift;
      my $config_ref = shift;
  
      subvol_exists_or_die($subvol, $config_ref);
  
      return $config_ref->{subvols}{$subvol}{mountpoint};
  }
  
  sub snap_subvol {
  
      # Return the name of the subvol that $snap is snapshotting.
  
      arg_count_or_die(2, 2, @_);
  
      my $snap       = shift;
      my $config_ref = shift;
  
      snap_exists_or_die($snap, $config_ref);
  
      return $config_ref->{snaps}{$snap}{subvol};
  }
  
  sub snap_mountpoint {
  
      # Return the mountpoint of the subvol that $snap is snapshotting.
  
      arg_count_or_die(2, 2, @_);
  
      my $snap       = shift;
      my $config_ref = shift;
  
      snap_exists_or_die($snap, $config_ref);
  
      my $subvol = snap_subvol($snap, $config_ref);
  
      return subvol_mountpoint($subvol, $config_ref);
  }
  
  sub snap_dest {
  
      # Return $snap's destination. Optionally pass a timeframe via the $tframe
      # value to append "/$tframe" to the returned dir.
  
      arg_count_or_die(3, 3, @_);
  
      my $snap       = shift;
      my $tframe     = shift;
      my $config_ref = shift;
  
      snap_exists_or_die($snap, $config_ref);
  
      my $dest = yabsm_dir($config_ref) . "/$snap";
  
      if ($tframe) {
          snap_wants_timeframe_or_die($snap, $tframe, $config_ref);
          return "$dest/$tframe";
      }
      else {
          return $dest;
      }
  }
  
  sub snap_timeframes {
  
      # Return a list of $snap's timeframes.
  
      arg_count_or_die(2, 2, @_);
  
      my $snap       = shift;
      my $config_ref = shift;
  
      snap_exists_or_die($snap, $config_ref);
  
      return sort split ',', $config_ref->{snaps}{$snap}{timeframes};
  }
  
  sub ssh_backup_subvol {
  
      # Return the name of the subvol that $ssh_backup is backing up.
  
      arg_count_or_die(2, 2, @_);
  
      my $ssh_backup = shift;
      my $config_ref = shift;
  
      ssh_backup_exists_or_die($ssh_backup, $config_ref);
  
      return $config_ref->{ssh_backups}{$ssh_backup}{subvol};
  }
  
  sub ssh_backup_mountpoint {
  
      # Return the mountpoint of the subvol that $ssh_backup is backing up.
  
      arg_count_or_die(2, 2, @_);
  
      my $ssh_backup = shift;
      my $config_ref = shift;
  
      ssh_backup_exists_or_die($ssh_backup, $config_ref);
  
      my $subvol = ssh_backup_subvol($ssh_backup, $config_ref);
  
      return subvol_mountpoint($subvol, $config_ref);
  }
  
  sub ssh_backup_dir {
  
      # Return $ssh_backup's ssh_backup dir value. Optionally pass a timeframe via
      # the $tframe value to append "/$tframe" to the returned dir.
  
      arg_count_or_die(3, 3, @_);
  
      my $ssh_backup = shift;
      my $tframe     = shift;
      my $config_ref = shift;
  
      ssh_backup_exists_or_die($ssh_backup, $config_ref);
  
      my $dir = $config_ref->{ssh_backups}{$ssh_backup}{dir} =~ s/\/+$//r;
  
      if ($tframe) {
          ssh_backup_wants_timeframe_or_die($ssh_backup, $tframe, $config_ref);
          return "$dir/$tframe";
      }
      else {
          return $dir;
      }
  }
  
  sub ssh_backup_timeframes {
  
      # Return a list of $ssh_backups's timeframes.
  
      arg_count_or_die(2, 2, @_);
  
      my $ssh_backup = shift;
      my $config_ref = shift;
  
      ssh_backup_exists_or_die($ssh_backup, $config_ref);
  
      return sort split ',', $config_ref->{ssh_backups}{$ssh_backup}{timeframes};
  }
  
  sub ssh_backup_ssh_dest {
  
      # Return $ssh_backup's ssh_dest value.
  
      arg_count_or_die(2, 2, @_);
  
      my $ssh_backup = shift;
      my $config_ref = shift;
  
      ssh_backup_exists_or_die($ssh_backup, $config_ref);
  
      return $config_ref->{ssh_backups}{$ssh_backup}{ssh_dest};
  }
  
  sub local_backup_subvol {
  
      # Return the name of the subvol that $local_backup is backing up.
  
      arg_count_or_die(2, 2, @_);
  
      my $local_backup = shift;
      my $config_ref   = shift;
  
      local_backup_exists_or_die($local_backup, $config_ref);
  
      return $config_ref->{local_backups}{$local_backup}{subvol};
  }
  
  sub local_backup_mountpoint {
  
      # Return the mountpoint of the subvol that $local_backup is backing up.
  
      arg_count_or_die(2, 2, @_);
  
      my $local_backup = shift;
      my $config_ref   = shift;
  
      local_backup_exists_or_die($local_backup, $config_ref);
  
      my $subvol = local_backup_subvol($local_backup, $config_ref);
  
      return subvol_mountpoint($subvol, $config_ref);
  }
  
  sub local_backup_dir {
  
      # Return $local_backup's local_backup dir value. Optionally pass a timeframe
      # via the $tframe value to append "/$tframe" to the returned dir.
  
      arg_count_or_die(3, 3, @_);
  
      my $local_backup = shift;
      my $tframe       = shift;
      my $config_ref   = shift;
  
      local_backup_exists_or_die($local_backup, $config_ref);
  
      my $dir = $config_ref->{local_backups}{$local_backup}{dir} =~ s/\/+$//r;
  
      if ($tframe) {
          local_backup_wants_timeframe_or_die($local_backup, $tframe, $config_ref);
          return "$dir/$tframe";
      }
      else {
          return $dir;
      }
  }
  
  sub local_backup_timeframes {
  
      # Return a list of $local_backups's timeframes.
  
      arg_count_or_die(2, 2, @_);
  
      my $local_backup = shift;
      my $config_ref   = shift;
  
      local_backup_exists_or_die($local_backup, $config_ref);
  
      return sort split ',', $config_ref->{local_backups}{$local_backup}{timeframes};
  }
  
  sub all_snaps_of_subvol {
  
      # Return a list of all the snaps in $config_ref that are snapshotting
      # $subvol.
  
      arg_count_or_die(2, 2, @_);
  
      my $subvol     = shift;
      my $config_ref = shift;
  
      my @snaps;
  
      for my $snap ( all_snaps($config_ref) ) {
          push @snaps, $snap
            if ($subvol eq $config_ref->{snaps}{$snap}{subvol});
      }
  
      return sort @snaps;
  }
  
  sub all_ssh_backups_of_subvol {
  
      # Return a list of all the ssh_backups in $config_ref that are backing up
      # $subvol.
  
      arg_count_or_die(2, 2, @_);
  
      my $subvol     = shift;
      my $config_ref = shift;
  
      my @ssh_backups;
  
      for my $ssh_backup ( all_ssh_backups($config_ref) ) {
          push @ssh_backups, $ssh_backup
            if ($subvol eq $config_ref->{ssh_backups}{$ssh_backup}{subvol});
      }
  
      return sort @ssh_backups;
  }
  
  sub all_local_backups_of_subvol {
  
      # Return a list of all the local_backups in $config_ref that are backing up
      # $subvol.
  
      arg_count_or_die(2, 2, @_);
  
      my $subvol     = shift;
      my $config_ref = shift;
  
      my @local_backups;
  
      for my $local_backup ( all_local_backups($config_ref) ) {
          push @local_backups, $local_backup
            if ($subvol eq $config_ref->{local_backups}{$local_backup}{subvol});
      }
  
      return sort @local_backups;
  }
  
  sub snap_wants_timeframe {
  
      # Return 1 if the snap $snap wants snapshots in timeframe $tframe and return
      # 0 otherwise;
  
      arg_count_or_die(3, 3, @_);
  
      my $snap       = shift;
      my $tframe     = shift;
      my $config_ref = shift;
  
      snap_exists_or_die($snap, $config_ref);
      is_timeframe_or_die($tframe);
  
      return 1 if grep { $tframe eq $_ } snap_timeframes($snap, $config_ref);
      return 0;
  }
  
  sub snap_wants_timeframe_or_die {
  
      # Wrapper around &snap_wants_timeframe that Carp::Confess's if it returns
      # false.
  
      arg_count_or_die(3, 3, @_);
  
      my $snap       = shift;
      my $tframe     = shift;
      my $config_ref = shift;
  
      unless ( snap_wants_timeframe($snap, $tframe, $config_ref) ) {
          confess("yabsm: internal error: snap '$snap' is not taking $tframe snapshots");
      }
  
      return 1;
  }
  
  sub ssh_backup_wants_timeframe {
  
      # Return 1 if the ssh_backup $ssh_backup wants backups in timeframe $tframe
      # and return 0 otherwise.
  
      arg_count_or_die(3, 3, @_);
  
      my $ssh_backup = shift;
      my $tframe     = shift;
      my $config_ref = shift;
  
      ssh_backup_exists_or_die($ssh_backup, $config_ref);
      is_timeframe_or_die($tframe);
  
      return 1 if grep { $tframe eq $_ } ssh_backup_timeframes($ssh_backup, $config_ref);
      return 0;
  }
  
  sub ssh_backup_wants_timeframe_or_die {
  
      # Wrapper around &ssh_backup_wants_timeframe that Carp::Confess's if it
      # returns false.
  
      arg_count_or_die(3, 3, @_);
  
      my $ssh_backup = shift;
      my $tframe     = shift;
      my $config_ref = shift;
  
      unless ( ssh_backup_wants_timeframe($ssh_backup, $tframe, $config_ref) ) {
          confess("yabsm: internal error: ssh_backup '$ssh_backup' is not taking $tframe backups");
      }
  
      return 1;
  }
  
  sub local_backup_wants_timeframe {
  
      # Return 1 if the local_backup $local_backup wants backups in timeframe
      # $tframe and return 0 otherwise.
  
      arg_count_or_die(3, 3, @_);
  
      my $local_backup = shift;
      my $tframe       = shift;
      my $config_ref   = shift;
  
      local_backup_exists_or_die($local_backup, $config_ref);
  
      is_timeframe_or_die($tframe);
  
      return 1 if grep { $tframe eq $_ } local_backup_timeframes($local_backup, $config_ref);
      return 0;
  }
  
  sub local_backup_wants_timeframe_or_die {
  
      # Wrapper around &local_backup_wants_timeframe that Carp::Confess's if it
      # returns false.
  
      arg_count_or_die(3, 3, @_);
  
      my $local_backup = shift;
      my $tframe       = shift;
      my $config_ref   = shift;
  
      unless ( local_backup_wants_timeframe($local_backup, $tframe, $config_ref) ) {
          confess("yabsm: internal error: local_backup '$local_backup' is not taking $tframe backups");
      }
  
      return 1;
  }
  
  sub snap_timeframe_keep {
  
      # Return snap $snap's ${tframe}_keep value.
  
      arg_count_or_die(3, 3, @_);
  
      my $snap       = shift;
      my $tframe     = shift;
      my $config_ref = shift;
  
      snap_exists_or_die($snap, $config_ref);
      is_timeframe_or_die($tframe);
  
      $tframe eq '5minute' and return snap_5minute_keep($snap, $config_ref);
      $tframe eq 'hourly'  and return snap_hourly_keep($snap, $config_ref);
      $tframe eq 'daily'   and return snap_daily_keep($snap, $config_ref);
      $tframe eq 'weekly'  and return snap_weekly_keep($snap, $config_ref);
      $tframe eq 'monthly' and return snap_monthly_keep($snap, $config_ref);
  }
  
  sub snap_5minute_keep {
  
      # Return snap $snap's 5minute_keep value.
  
      arg_count_or_die(2, 2, @_);
  
      my $snap       = shift;
      my $config_ref = shift;
  
      snap_exists_or_die($snap, $config_ref);
      snap_wants_timeframe_or_die($snap, '5minute', $config_ref);
  
      return $config_ref->{snaps}{$snap}{'5minute_keep'};
  }
  
  sub snap_hourly_keep {
  
      # Return snap $snap's hourly_keep value.
  
      arg_count_or_die(2, 2, @_);
  
      my $snap       = shift;
      my $config_ref = shift;
  
      snap_exists_or_die($snap, $config_ref);
      snap_wants_timeframe_or_die($snap, 'hourly', $config_ref);
  
      return $config_ref->{snaps}{$snap}{hourly_keep};
  }
  
  sub snap_daily_keep {
  
      # Return snap $snap's daily_keep value.
  
      arg_count_or_die(2, 2, @_);
  
      my $snap       = shift;
      my $config_ref = shift;
  
      snap_exists_or_die($snap, $config_ref);
      snap_wants_timeframe_or_die($snap, 'daily', $config_ref);
  
      return $config_ref->{snaps}{$snap}{daily_keep};
  }
  
  sub snap_daily_times {
  
      # Return a list of snap $snap's daily_times values.
  
      arg_count_or_die(2, 2, @_);
  
      my $snap       = shift;
      my $config_ref = shift;
  
      snap_exists_or_die($snap, $config_ref);
      snap_wants_timeframe_or_die($snap, 'daily', $config_ref);
  
      my @times = split ',', $config_ref->{snaps}{$snap}{daily_times};
  
      # removes duplicates
      @times = sort keys %{{ map { $_ => 1 } @times }};
  
      return @times
  }
  
  sub snap_weekly_keep {
  
      # Return snap $snap's weekly_keep value.
  
      arg_count_or_die(2, 2, @_);
  
      my $snap       = shift;
      my $config_ref = shift;
  
      snap_exists_or_die($snap, $config_ref);
      snap_wants_timeframe_or_die($snap, 'weekly', $config_ref);
  
      return $config_ref->{snaps}{$snap}{weekly_keep};
  }
  
  sub snap_weekly_time {
  
      # Return snap $snap's weekly_time value.
  
      arg_count_or_die(2, 2, @_);
  
      my $snap       = shift;
      my $config_ref = shift;
  
      snap_exists_or_die($snap, $config_ref);
      snap_wants_timeframe_or_die($snap, 'weekly', $config_ref);
  
      return $config_ref->{snaps}{$snap}{weekly_time};
  }
  
  sub snap_weekly_day {
  
      # Return snap $snap's weekly_day value.
  
      arg_count_or_die(2, 2, @_);
  
      my $snap       = shift;
      my $config_ref = shift;
  
      snap_exists_or_die($snap, $config_ref);
      snap_wants_timeframe_or_die($snap, 'weekly', $config_ref);
  
      return $config_ref->{snaps}{$snap}{weekly_day};
  }
  
  sub snap_monthly_keep {
  
      # Return snap $snap's monthly_keep value.
  
      arg_count_or_die(2, 2, @_);
  
      my $snap       = shift;
      my $config_ref = shift;
  
      snap_exists_or_die($snap, $config_ref);
      snap_wants_timeframe_or_die($snap, 'monthly', $config_ref);
  
      return $config_ref->{snaps}{$snap}{monthly_keep};
  }
  
  sub snap_monthly_time {
  
      # Return snap $snap's monthly_time value.
  
      arg_count_or_die(2, 2, @_);
  
      my $snap       = shift;
      my $config_ref = shift;
  
      snap_exists_or_die($snap, $config_ref);
      snap_wants_timeframe_or_die($snap, 'monthly', $config_ref);
  
      return $config_ref->{snaps}{$snap}{monthly_time};
  }
  
  sub snap_monthly_day {
  
      # Return snap $snap's monthly_day value.
  
      arg_count_or_die(2, 2, @_);
  
      my $snap       = shift;
      my $config_ref = shift;
  
      snap_exists_or_die($snap, $config_ref);
      snap_wants_timeframe_or_die($snap, 'monthly', $config_ref);
  
      return $config_ref->{snaps}{$snap}{monthly_day};
  }
  
  sub ssh_backup_timeframe_keep {
  
      # Return ssh_backup $ssh_backup's ${tframe}_keep value.
  
      arg_count_or_die(3, 3, @_);
  
      my $ssh_backup = shift;
      my $tframe     = shift;
      my $config_ref = shift;
  
      ssh_backup_exists_or_die($ssh_backup, $config_ref);
      is_timeframe_or_die($tframe);
  
      $tframe eq '5minute' and return ssh_backup_5minute_keep($ssh_backup, $config_ref);
      $tframe eq 'hourly'  and return ssh_backup_hourly_keep($ssh_backup, $config_ref);
      $tframe eq 'daily'   and return ssh_backup_daily_keep($ssh_backup, $config_ref);
      $tframe eq 'weekly'  and return ssh_backup_weekly_keep($ssh_backup, $config_ref);
      $tframe eq 'monthly' and return ssh_backup_monthly_keep($ssh_backup, $config_ref);
  }
  
  sub ssh_backup_5minute_keep {
  
      # Return ssh_backup $ssh_backup's 5minute_keep value.
  
      arg_count_or_die(2, 2, @_);
  
      my $ssh_backup = shift;
      my $config_ref = shift;
  
      ssh_backup_exists_or_die($ssh_backup, $config_ref);
      ssh_backup_wants_timeframe_or_die($ssh_backup, '5minute', $config_ref);
  
      return $config_ref->{ssh_backups}{$ssh_backup}{'5minute_keep'};
  }
  
  sub ssh_backup_hourly_keep {
  
      # Return ssh_backup $ssh_backup's hourly_keep value.
  
      arg_count_or_die(2, 2, @_);
  
      my $ssh_backup = shift;
      my $config_ref = shift;
  
      ssh_backup_exists_or_die($ssh_backup, $config_ref);
      ssh_backup_wants_timeframe_or_die($ssh_backup, 'hourly', $config_ref);
  
      return $config_ref->{ssh_backups}{$ssh_backup}{hourly_keep};
  }
  
  sub ssh_backup_daily_keep {
  
      # Return ssh_backup $ssh_backup's daily_keep value.
  
      arg_count_or_die(2, 2, @_);
  
      my $ssh_backup = shift;
      my $config_ref = shift;
  
      ssh_backup_exists_or_die($ssh_backup, $config_ref);
      ssh_backup_wants_timeframe_or_die($ssh_backup, 'daily', $config_ref);
  
      return $config_ref->{ssh_backups}{$ssh_backup}{daily_keep};
  }
  
  sub ssh_backup_daily_times {
  
      # Return a list of ssh_backup $ssh_backup's daily_times values.
  
      arg_count_or_die(2, 2, @_);
  
      my $ssh_backup = shift;
      my $config_ref = shift;
  
      ssh_backup_exists_or_die($ssh_backup, $config_ref);
      ssh_backup_wants_timeframe_or_die($ssh_backup, 'daily', $config_ref);
  
      my @times = split ',', $config_ref->{ssh_backups}{$ssh_backup}{daily_times};
  
      # removes duplicates
      @times = sort keys %{{ map { $_ => 1 } @times }};
  
      return @times;
  }
  
  sub ssh_backup_weekly_keep {
  
      # Return ssh_backup $ssh_backup's weekly_keep value.
  
      arg_count_or_die(2, 2, @_);
  
      my $ssh_backup = shift;
      my $config_ref = shift;
  
      ssh_backup_exists_or_die($ssh_backup, $config_ref);
      ssh_backup_wants_timeframe_or_die($ssh_backup, 'weekly', $config_ref);
  
      return $config_ref->{ssh_backups}{$ssh_backup}{weekly_keep};
  }
  
  sub ssh_backup_weekly_time {
  
      # Return ssh_backup $ssh_backup's weekly_time value.
  
      arg_count_or_die(2, 2, @_);
  
      my $ssh_backup = shift;
      my $config_ref = shift;
  
      ssh_backup_exists_or_die($ssh_backup, $config_ref);
      ssh_backup_wants_timeframe_or_die($ssh_backup, 'weekly', $config_ref);
  
      return $config_ref->{ssh_backups}{$ssh_backup}{weekly_time};
  }
  
  sub ssh_backup_weekly_day {
  
      # Return ssh_backup $ssh_backup's weekly_day value.
  
      arg_count_or_die(2, 2, @_);
  
      my $ssh_backup = shift;
      my $config_ref = shift;
  
      ssh_backup_exists_or_die($ssh_backup, $config_ref);
      ssh_backup_wants_timeframe_or_die($ssh_backup, 'weekly', $config_ref);
  
      return $config_ref->{ssh_backups}{$ssh_backup}{weekly_day};
  }
  
  sub ssh_backup_monthly_keep {
  
      # Return ssh_backup $ssh_backup's monthly_keep value.
  
      arg_count_or_die(2, 2, @_);
  
      my $ssh_backup = shift;
      my $config_ref = shift;
  
      ssh_backup_exists_or_die($ssh_backup, $config_ref);
      ssh_backup_wants_timeframe_or_die($ssh_backup, 'monthly', $config_ref);
  
      return $config_ref->{ssh_backups}{$ssh_backup}{monthly_keep};
  }
  
  sub ssh_backup_monthly_time {
  
      # Return ssh_backup $ssh_backup's monthly_time value.
  
      arg_count_or_die(2, 2, @_);
  
      my $ssh_backup = shift;
      my $config_ref = shift;
  
      ssh_backup_exists_or_die($ssh_backup, $config_ref);
      ssh_backup_wants_timeframe_or_die($ssh_backup, 'monthly', $config_ref);
  
      return $config_ref->{ssh_backups}{$ssh_backup}{monthly_time};
  }
  
  sub ssh_backup_monthly_day {
  
      # Return ssh_backup $ssh_backup's monthly_day value.
  
      arg_count_or_die(2, 2, @_);
  
      my $ssh_backup = shift;
      my $config_ref = shift;
  
      ssh_backup_exists_or_die($ssh_backup, $config_ref);
      ssh_backup_wants_timeframe_or_die($ssh_backup, 'monthly', $config_ref);
  
      return $config_ref->{ssh_backups}{$ssh_backup}{monthly_day};
  }
  
  sub local_backup_timeframe_keep {
  
      # Return local_backup $local_backup's ${tframe}_keep value.
  
      arg_count_or_die(3, 3, @_);
  
      my $local_backup = shift;
      my $tframe       = shift;
      my $config_ref   = shift;
  
      local_backup_exists_or_die($local_backup, $config_ref);
      is_timeframe_or_die($tframe);
  
      $tframe eq '5minute' and return local_backup_5minute_keep($local_backup, $config_ref);
      $tframe eq 'hourly'  and return local_backup_hourly_keep($local_backup, $config_ref);
      $tframe eq 'daily'   and return local_backup_daily_keep($local_backup, $config_ref);
      $tframe eq 'weekly'  and return local_backup_weekly_keep($local_backup, $config_ref);
      $tframe eq 'monthly' and return local_backup_monthly_keep($local_backup, $config_ref);
  }
  
  sub local_backup_5minute_keep {
  
      # Return local_backup $local_backup's 5minute_keep value.
  
      arg_count_or_die(2, 2, @_);
  
      my $local_backup = shift;
      my $config_ref   = shift;
  
      local_backup_exists_or_die($local_backup, $config_ref);
      local_backup_wants_timeframe_or_die($local_backup, '5minute', $config_ref);
  
      return $config_ref->{local_backups}{$local_backup}{'5minute_keep'};
  }
  
  sub local_backup_hourly_keep {
  
      # Return local_backup $local_backup's hourly_keep value.
  
      arg_count_or_die(2, 2, @_);
  
      my $local_backup = shift;
      my $config_ref   = shift;
  
      local_backup_exists_or_die($local_backup, $config_ref);
      local_backup_wants_timeframe_or_die($local_backup, 'hourly', $config_ref);
  
      return $config_ref->{local_backups}{$local_backup}{hourly_keep};
  }
  
  sub local_backup_daily_keep {
  
      # Return local_backup $local_backup's daily_keep value.
  
      arg_count_or_die(2, 2, @_);
  
      my $local_backup = shift;
      my $config_ref   = shift;
  
      local_backup_exists_or_die($local_backup, $config_ref);
      local_backup_wants_timeframe_or_die($local_backup, 'daily', $config_ref);
  
      return $config_ref->{local_backups}{$local_backup}{daily_keep};
  }
  
  sub local_backup_daily_times {
  
      # Return a list of local_backup $local_backup's daily_times values.
  
      arg_count_or_die(2, 2, @_);
  
      my $local_backup = shift;
      my $config_ref = shift;
  
      local_backup_exists_or_die($local_backup, $config_ref);
      local_backup_wants_timeframe_or_die($local_backup, 'daily', $config_ref);
  
      my @times = split ',', $config_ref->{local_backups}{$local_backup}{daily_times};
  
      # removes duplicates
      @times = sort keys %{{ map { $_ => 1 } @times }};
  
      return @times;
  }
  
  sub local_backup_weekly_keep {
  
      # Return local_backup $local_backup's weekly_keep value.
  
      arg_count_or_die(2, 2, @_);
  
      my $local_backup = shift;
      my $config_ref   = shift;
  
      local_backup_exists_or_die($local_backup, $config_ref);
      local_backup_wants_timeframe_or_die($local_backup, 'weekly', $config_ref);
  
      return $config_ref->{local_backups}{$local_backup}{weekly_keep};
  }
  
  sub local_backup_weekly_time {
  
      # Return local_backup $local_backup's weekly_time value.
  
      arg_count_or_die(2, 2, @_);
  
      my $local_backup = shift;
      my $config_ref   = shift;
  
      local_backup_exists_or_die($local_backup, $config_ref);
      local_backup_wants_timeframe_or_die($local_backup, 'weekly', $config_ref);
  
      return $config_ref->{local_backups}{$local_backup}{weekly_time};
  }
  
  sub local_backup_weekly_day {
  
      # Return local_backup $local_backup's weekly_day value.
  
      arg_count_or_die(2, 2, @_);
  
      my $local_backup = shift;
      my $config_ref   = shift;
  
      local_backup_exists_or_die($local_backup, $config_ref);
      local_backup_wants_timeframe_or_die($local_backup, 'weekly', $config_ref);
  
      return $config_ref->{local_backups}{$local_backup}{weekly_day};
  }
  
  sub local_backup_monthly_keep {
  
      # Return local_backup $local_backup's monthly_keep value.
  
      arg_count_or_die(2, 2, @_);
  
      my $local_backup = shift;
      my $config_ref   = shift;
  
      local_backup_exists_or_die($local_backup, $config_ref);
      local_backup_wants_timeframe_or_die($local_backup, 'monthly', $config_ref);
  
      return $config_ref->{local_backups}{$local_backup}{monthly_keep};
  }
  
  sub local_backup_monthly_time {
  
      # Return local_backup $local_backup's monthly_time value.
  
      arg_count_or_die(2, 2, @_);
  
      my $local_backup = shift;
      my $config_ref   = shift;
  
      local_backup_exists_or_die($local_backup, $config_ref);
      local_backup_wants_timeframe_or_die($local_backup, 'monthly', $config_ref);
  
      return $config_ref->{local_backups}{$local_backup}{monthly_time};
  }
  
  sub local_backup_monthly_day {
  
      # Return local_backup $local_backup's monthly_day value.
  
      arg_count_or_die(2, 2, @_);
  
      my $local_backup = shift;
      my $config_ref   = shift;
  
      local_backup_exists_or_die($local_backup, $config_ref);
      local_backup_wants_timeframe_or_die($local_backup, 'monthly', $config_ref);
  
      return $config_ref->{local_backups}{$local_backup}{monthly_day};
  }
  
  1;
APP_YABSM_CONFIG_QUERY

$fatpacked{"App/Yabsm/Snap.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_YABSM_SNAP';
  #  Author:    Nicholas Hubbard
  #  Copyright: Nicholas Hubbard
  #  License:   GPL_3
  #  WWW:       https://github.com/NicholasBHubbard/Yabsm
  
  #  Provides the &do_snap subroutine which performs a single snapshot. This is a
  #  top-level subroutine that is directly scheduled to be run by the daemon.
  
  use strict;
  use warnings;
  use v5.34.0;
  
  package App::Yabsm::Snap;
  
  use App::Yabsm::Config::Query qw ( :ALL );
  use App::Yabsm::Snapshot qw(take_snapshot
                              delete_snapshot
                              sort_snapshots
                              is_snapshot_name
                             );
  
  use Exporter qw(import);
  our @EXPORT_OK = qw(do_snap);
  
                   ####################################
                   #            SUBROUTINES           #
                   ####################################
  
  sub do_snap {
  
      # Perform a single $tframe snap of $snap.
  
      my $snap       = shift;
      my $tframe     = shift;
      my $config_ref = shift;
  
      my $mountpoint = snap_mountpoint($snap, $config_ref);
      my $snap_dest  = snap_dest($snap, $tframe, $config_ref);
  
      my $snapshot = take_snapshot($mountpoint, $snap_dest);
  
      # @snapshots is sorted from newest to oldest
      my @snapshots = sort_snapshots(do {
          opendir my $dh, $snap_dest or confess("yabsm: internal error: cannot opendir '$snap_dest'");
          my @snapshots = grep { is_snapshot_name($_, ALLOW_BOOTSTRAP => 0) } readdir($dh);
          map { $_ = "$snap_dest/$_" } @snapshots;
          closedir $dh;
          \@snapshots;
      });
  
      my $num_snaps = scalar @snapshots;
      my $to_keep   = snap_timeframe_keep($snap, $tframe, $config_ref);
  
      # There is 1 more snap than should be kept because we just performed a snap.
      if ($num_snaps == $to_keep + 1) {
          my $oldest = pop @snapshots;
          delete_snapshot($oldest);
      }
      # We havent reached the quota yet so we don't delete anything
      elsif ($num_snaps <= $to_keep) {
          ;
      }
      # User changed their settings to keep less snaps than they were keeping
      # prior.
      else {
          for (; $num_snaps > $to_keep; $num_snaps--) {
              my $oldest = pop @snapshots;
              delete_snapshot($oldest);
          }
      }
  
      return $snapshot;
  }
  
  1;
APP_YABSM_SNAP

$fatpacked{"App/Yabsm/Snapshot.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_YABSM_SNAPSHOT';
  #  Author:    Nicholas Hubbard
  #  Copyright: Nicholas Hubbard
  #  License:   GPL_3
  #  WWW:       https://github.com/NicholasBHubbard/Yabsm
  
  #  Provides functions for taking and cycling snapshots based off of
  #  the user config.
  #
  #  See t/Snapshot.t for this libraries tests.
  
  use strict;
  use warnings;
  use v5.34.0;
  
  package App::Yabsm::Snapshot;
  
  use App::Yabsm::Tools qw( :ALL );
  use App::Yabsm::Config::Query qw( :ALL );
  
  use Carp qw(confess);
  use File::Basename qw(basename);
  use Time::Piece;
  
  use Exporter qw(import);
  our @EXPORT_OK = qw(take_snapshot
                      delete_snapshot
                      is_snapshot_name
                      is_snapshot_name_or_die
                      is_bootstrap_snapshot_name
                      is_yabsm_snapshot
                      is_yabsm_snapshot_or_die
                      snapshot_name_nums
                      nums_to_snapshot_name
                      current_time_snapshot_name
                      sort_snapshots
                      cmp_snapshots
                      snapshots_eq
                      snapshot_newer
                      snapshot_older
                      snapshot_newer_or_eq
                      snapshot_older_or_eq
                     );
  
                   ####################################
                   #            SUBROUTINES           #
                   ####################################
  
  sub take_snapshot {
  
      # This is the lowest level function for taking a snapshot. Given the path to
      # a btrfs subvolume ($subvolume) and the destination path for the snapshot
      # ($dest), takes a snapshot of $subvolume, names it after the current time
      # (or an inputted name), and places it in $dest. Returns the path of the new
      # snapshot.
      #
      # Performs sanity checking and dies unless $subvolume is a btrfs subvolume,
      # $dest is a directory residing on a btrfs filesystem, and the current user
      # can call the btrfs program using sudo without the need for password
      # authentication.
  
      arg_count_or_die(2, 3, @_);
  
      my $subvolume     = shift;
      my $dest          = shift;
      my $snapshot_name = shift // current_time_snapshot_name();
  
      is_btrfs_subvolume_or_die($subvolume);
      is_btrfs_dir_or_die($dest);
      is_snapshot_name_or_die($snapshot_name, ALLOW_BOOTSTRAP => 1);
      have_sudo_access_to_btrfs_or_die();
  
      my $snapshot = "$dest/" . $snapshot_name;
  
      system_or_die('sudo', '-n', 'btrfs', 'subvolume', 'snapshot', '-r', $subvolume, $snapshot);
  
      return $snapshot;
  }
  
  sub delete_snapshot {
  
      # This is the lowest level function for deleting a snapshot. Takes the path
      # to a yabsm snapshot ($snapshot), deletes it and returns it back.
      #
      # Performs sanity checking and dies unless $snapshot is a yabsm snapshot,
      # and the current user can call the btrfs program with sudo without the need
      # for password authentication.
  
      arg_count_or_die(1, 1, @_);
  
      my $snapshot = shift;
  
      is_yabsm_snapshot_or_die($snapshot);
      have_sudo_access_to_btrfs_or_die();
  
      system_or_die('sudo', '-n', 'btrfs', 'subvolume', 'delete', $snapshot);
  
      return $snapshot;
  }
  
  sub is_snapshot_name {
  
      # Return 1 if passed a valid yabsm snapshot name and return 0 otherwise. Does
      # checking to ensure that the denoted date is a valid date.
      #
      # Optionally pass 'ALLOW_BOOTSTRAP => 1' to accept bootstrap snapshot names
      # and 'ONLY_BOOTSTRAP => 1' to only accept bootstrap snapshot names.
      #
      # It is important to note that this function rejects directory paths even if
      # their basename is a valid snapshot name.
  
      arg_count_or_die(1, 5, @_);
  
      my $snapshot_name = shift;
      my %opts = (ALLOW_BOOTSTRAP => 0, ONLY_BOOTSTRAP  => 0, @_);
  
      my $rx = do {
          my $base = 'yabsm-(\d{4})_(\d{2})_(\d{2})_(\d{2}):(\d{2})';
          my $prefix = '';
          if ($opts{ALLOW_BOOTSTRAP}) {
              $prefix = '(?:\.BOOTSTRAP-)?';
          }
          if ($opts{ONLY_BOOTSTRAP}) {
              $prefix = '(?:\.BOOTSTRAP-)';
          }
          qr/^$prefix$base$/;
      };
  
      return 0 unless my @date_nums = $snapshot_name =~ $rx;
  
      return 0 unless nums_denote_valid_date(@date_nums);
  
      return 1;
  }
  
  sub is_snapshot_name_or_die {
  
      # Wrapper around &is_snapshot_name that will Carp::confess if it returns
      # false.
  
      arg_count_or_die(1, 5, @_);
  
      unless (is_snapshot_name(@_)) {
          confess q(yabsm: internal error: ').shift(@_).q(' is not a valid yabsm snapshot name);
      }
  
      return 1;
  }
  
  sub is_yabsm_snapshot {
  
      # Return 1 if $snapshot is a yabsm snapshot (including bootstrap) and return
      # 0 otherwise.
  
      my $snapshot = shift;
  
      return is_btrfs_subvolume($snapshot) && is_snapshot_name(basename($snapshot), ALLOW_BOOTSTRAP => 1);
  }
  
  sub is_yabsm_snapshot_or_die {
  
      # Wrapper around is_yabsm_snapshot_name() that Carp::Confess's if it returns
      # false.
  
      my $snapshot = shift;
  
      unless ( is_btrfs_subvolume($snapshot) ) {
          confess("yabsm: internal error: '$snapshot' is not a btrfs subvolume");
      }
  
      unless ( is_snapshot_name(basename($snapshot), ALLOW_BOOTSTRAP => 1) ) {
          confess("yabsm: internal error: '$snapshot' does not have a valid yabsm snapshot name");
      }
  
      return 1;
  }
  
  sub snapshot_name_nums {
  
      # Take a snapshot name and return a list containing, in order, the
      # corresponding year, month, day, hour, and minute. Kill program if
      # $snapshot_name is not a valid yabsm snapshot name.
  
      arg_count_or_die(1, 1, @_);
  
      my $snapshot_name = shift;
  
      is_snapshot_name_or_die($snapshot_name, ALLOW_BOOTSTRAP => 1);
  
      my ($yr, $mon, $day, $hr, $min) = map { 0 + $_ } $snapshot_name =~ /^yabsm-(\d{4})_(\d{2})_(\d{2})_(\d{2}):(\d{2})$/;
  
      return ($yr, $mon, $day, $hr, $min);
  }
  
  sub nums_to_snapshot_name {
  
      # Take 5 integer arguments representing in order the year, month,
      # day, hour, and minute and return a snapshot name of the
      # corresponding time.
  
      arg_count_or_die(5, 5, @_);
  
      my ($yr, $mon, $day, $hr, $min) = map { sprintf '%02d', $_ } @_;
  
      nums_denote_valid_date_or_die($yr, $mon, $day, $hr, $min);
  
      my $snapshot_name = "yabsm-${yr}_${mon}_${day}_$hr:$min";
  
      return $snapshot_name;
  }
  
  sub current_time_snapshot_name {
  
      # Return a snapshot name corresponding to the current time.
  
      arg_count_or_die(0, 0, @_);
  
      my $t = localtime();
  
      return nums_to_snapshot_name($t->year, $t->mon, $t->mday, $t->hour, $t->min);
  }
  
  sub sort_snapshots {
  
      # Takes a reference to an array of snapshots and returns a list of the
      # snapshots sorted from newest to oldest. This function works with both
      # paths to snapshots and plain snapshots names.
      #
      # If called in list context returns list of sorted snapshots. If called in
      # scalar context returns a reference to the list of sorted snapshots.
  
      arg_count_or_die(1, 1, @_);
  
      my @sorted = sort { cmp_snapshots($a, $b) } @{ +shift };
  
      return wantarray ? @sorted : \@sorted;
  }
  
  sub cmp_snapshots {
  
      # Compare two yabsm snapshots based off their times. Works with both a path
      # to a snapshot and just a snapshot name.
      #
      # Return -1 if $snapshot1 is newer than $snapshot2
      # Return 1  if $snapshot1 is older than $snapshot2
      # Return 0  if $snapshot1 and $snapshot2 are the same
  
      arg_count_or_die(2, 2, @_);
  
      my $snapshot1 = shift;
      my $snapshot2 = shift;
  
      my @nums1 = snapshot_name_nums(basename($snapshot1));
      my @nums2 = snapshot_name_nums(basename($snapshot2));
  
      for (my $i = 0; $i <= $#nums1; $i++) {
          return -1 if $nums1[$i] > $nums2[$i];
          return 1  if $nums1[$i] < $nums2[$i];
      }
  
      return 0;
  }
  
  sub snapshots_eq {
  
      # Return 1 if $snapshot1 and $snapshot2 denote the same time and return 0
      # otherwise.
  
      arg_count_or_die(2, 2, @_);
  
      my $snapshot1 = shift;
      my $snapshot2 = shift;
  
      return 0+(0 == cmp_snapshots($snapshot1, $snapshot2));
  }
  
  sub snapshot_newer {
  
      # Return 1 if $snapshot1 is newer than $snapshot2 and return 0 otherwise.
  
      arg_count_or_die(2, 2, @_);
  
      my $snapshot1 = shift;
      my $snapshot2 = shift;
  
      return 0+(-1 == cmp_snapshots($snapshot1, $snapshot2));
  }
  
  sub snapshot_older {
  
      # Return 1 if $snapshot1 is older than $snapshot2 and return 0 otherwise.
  
      arg_count_or_die(2, 2, @_);
  
      my $snapshot1 = shift;
      my $snapshot2 = shift;
  
      return 0+(1 == cmp_snapshots($snapshot1, $snapshot2));
  }
  
  sub snapshot_newer_or_eq {
  
      # Return 1 if $snapshot1 is newer or equal to $snapshot2 and return 0
      # otherwise.
  
      arg_count_or_die(2, 2, @_);
  
      my $snapshot1 = shift;
      my $snapshot2 = shift;
  
      return 0+(cmp_snapshots($snapshot1, $snapshot2) <= 0);
  }
  
  sub snapshot_older_or_eq {
  
      # Return 1 if $snapshot1 is newer or equal to $snapshot2 and return 0
      # otherwise.
  
      arg_count_or_die(2, 2, @_);
  
      my $snapshot1 = shift;
      my $snapshot2 = shift;
  
      return 0+(cmp_snapshots($snapshot1, $snapshot2) >= 0);
  }
  
  1;
APP_YABSM_SNAPSHOT

$fatpacked{"App/Yabsm/Tools.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_YABSM_TOOLS';
  #  Author:    Nicholas Hubbard
  #  Copyright: Nicholas Hubbard
  #  License:   GPL_3
  #  WWW:       https://github.com/NicholasBHubbard/Yabsm
  
  #  Miscellaneous tools to aid in the development of Yabsm.
  #
  #  See t/Tools.t for this modules tests.
  
  use strict;
  use warnings;
  use v5.34.0;
  
  package App::Yabsm::Tools;
  
  use Time::Piece;
  use Feature::Compat::Try;
  use IPC::Run3 qw(run3);
  use Carp qw(confess);
  use File::Path qw(make_path);
  use File::Basename qw(dirname);
  
  use Exporter qw(import);
  our @EXPORT_OK = qw(os_dependencies_satisfied
                      os_dependencies_satisfied_or_die
                      arg_count_or_die
                      with_error_catch_log
                      have_sudo_access_to_btrfs
                      have_sudo_access_to_btrfs_or_die
                      is_btrfs_dir
                      is_btrfs_dir_or_die
                      is_btrfs_subvolume
                      is_btrfs_subvolume_or_die
                      nums_denote_valid_date
                      nums_denote_valid_date_or_die
                      system_or_die
                      make_path_or_die
                      i_am_root
                      i_am_root_or_die
                     );
  our %EXPORT_TAGS = ( ALL => [ @EXPORT_OK ] );
  
                   ####################################
                   #            SUBROUTINES           #
                   ####################################
  
  sub os_dependencies_satisfied {
  
      # Return 1 if we are running on a Linux OS and have sudo, OpenSSH, and
      # btrfs-progs installed.
  
      return 0 unless $^O =~ /linux/i;
      return 0 unless 0 == system('which btrfs >/dev/null 2>&1');
      return 0 unless `ssh -V 2>&1` =~ /^OpenSSH/; # there could be a different SSH implementation.
      return 0 unless 0 == system('which sudo >/dev/null 2>&1');
  
      return 1;
  }
  
  sub os_dependencies_satisfied_or_die {
  
      # Kill the program unless we are running on a Linux OS and have sudo,
      # OpenSSH, and btrfs-progs installed.
  
      unless ($^O =~ /linux/i) {
          die "yabsm: internal error: This not a Linux OS, this is a '$^O' OS\n";
      }
  
      unless (0 == system('which btrfs >/dev/null 2>&1')) {
          die 'yabsm: internal error: btrfs-progs not installed', "\n";
      }
  
      unless (`ssh -V 2>&1` =~ /^openssh/i) {
          die 'yabsm: internal error: OpenSSH not installed', "\n";
      }
  
      unless (0 == system('which sudo >/dev/null 2>&1')) {
          die 'yabsm: internal error: sudo not installed', "\n";
      }
  
      return 1;
  }
  
  sub arg_count_or_die {
  
      # Carp::Confess unless $num_args is in range $lower-$upper. If $lower equals
      # '_' then it is assumed to be 0 and if $upper equals '_' it is assumed to
      # be infinity.
  
      my $lower    = shift;
      my $upper    = shift;
      my $num_args = scalar @_;
  
      $lower = 0 if $lower eq '_';
  
      my $lower_ok = $lower <= $num_args;
      my $upper_ok = $upper eq '_' ? 1 : $upper >= $num_args;
  
      unless ($lower_ok && $upper_ok) {
          my $caller    = ( caller(1) )[3];
          my $err_msg_prefix = "yabsm: internal error: called '$caller' with $num_args args but it expects";
          my $range_msg;
          if    ($upper eq '_')    { $range_msg = "at least $lower args" }
          elsif ($lower == $upper) { $range_msg = "$lower args"          }
          else                     { $range_msg = "$lower-$upper args"   }
          confess("$err_msg_prefix $range_msg");
      }
  
      return 1;
  }
  
  sub with_error_catch_log {
  
      # Call $sub with @args within a Feature::Compat::Try try/catch block to catch
      # any exception and log it to /var/log/yabsm instead of killing the program.
  
      my $sub  = shift;
      my @args = @_;
  
      try {
          $sub->(@args);
      }
      catch ($e) {
          if (-f '/var/log/yabsm' && open(my $fh, '>>', '/var/log/yabsm')) {
              $e =~ s/^\s+|\s+$//g;
              my $t = localtime();
              my ($yr, $mon, $day, $hr, $min) = map { sprintf '%02d', $_ } $t->year, $t->mon, $t->mday, $t->hour, $t->min;
              say $fh "[${yr}_${mon}_${day}_$hr:$min]: $e";
              close $fh;
          }
      }
  }
  
  sub have_sudo_access_to_btrfs {
  
      # Return 1 if we can run 'btrfs' with 'sudo -n' and return 0 otherwise.
  
      arg_count_or_die(0, 0, @_);
  
      return 0+(0 == system('sudo -n btrfs --help >/dev/null 2>&1'));
  }
  
  sub have_sudo_access_to_btrfs_or_die {
  
      # Wrapper around have_sudo_access_to_btrfs() that Carp::Confess's if it
      # returns false.
  
      arg_count_or_die(0, 0, @_);
  
      my $username = getpwuid $<;
  
      have_sudo_access_to_btrfs() ? return 1 : die("yabsm: internal error: no sudo access rights to 'btrfs' while running as user '$username'\n");
  }
  
  sub is_btrfs_dir {
  
      # Return 1 if $dir is a directory residing on a btrfs subvolume
      # and return 0 otherwise.
  
      arg_count_or_die(1, 1, @_);
  
      my $dir = shift;
  
      return 0 unless -d $dir;
  
      return 0+(0 == system("btrfs property list '$dir' >/dev/null 2>&1"));
  }
  
  sub is_btrfs_dir_or_die {
  
      # Wrapper around is_btrfs_dir() that Carp::Confess's if it returns false.
  
      arg_count_or_die(1, 1, @_);
  
      my $dir = shift;
  
      is_btrfs_dir($dir) ? return 1 : die("yabsm: internal error: '$dir' is not a directory residing on a btrfs filesystem\n")
  }
  
  sub is_btrfs_subvolume {
  
      # Return 1 if $dir is a btrfs subvolume on this OS and return 0
      # otherwise.
      #
      # A btrfs subvolume is identified by inode number 256
  
      arg_count_or_die(1, 1, @_);
  
      my $dir = shift;
  
      return 0 unless is_btrfs_dir($dir);
  
      my $inode_num = (split /\s+/, `ls -di '$dir' 2>/dev/null`, 2)[0];
  
      return 0+(256 == $inode_num);
  }
  
  sub is_btrfs_subvolume_or_die {
  
      # Wrapper around is_btrfs_subvolume() that Carp::Confess's if it returns
      # false.
  
      arg_count_or_die(1, 1, @_);
  
      my $dir = shift;
  
      is_btrfs_subvolume($dir) ? return 1 : die("yabsm: internal error: '$dir' is not a btrfs subvolume")
  }
  
  sub nums_denote_valid_date {
  
      # Return 1 if passed a year, month, month-day, hour, and minute
      # that denote a valid date and return 0 otherwise.
  
      arg_count_or_die(5, 5, @_);
  
      my ($yr, $mon, $day, $hr, $min) = @_;
  
      return 0 unless $yr  >= 1;
      return 0 unless $mon >= 1 && $mon <= 12;
      return 0 unless $hr  >= 0 && $hr  <= 23;
      return 0 unless $min >= 0 && $min <= 59;
  
      # month days are a bit more complicated to figure out
  
      if ($mon == 1 || $mon == 3 || $mon == 5 || $mon == 7 || $mon == 8 || $mon == 10 || $mon == 12) {
          return 0 unless $day >= 1 && $day <= 31;
      }
      elsif ($mon == 4 || $mon == 6 || $mon == 9 || $mon == 11) {
          return 0 unless $day >= 1 && $day <= 30;
      }
      else { # February
          my $is_leap_yr;
  
          if    ($yr % 400 == 0) { $is_leap_yr = 1 }
          elsif ($yr % 100 == 0) { $is_leap_yr = 0 }
          elsif ($yr % 4   == 0) { $is_leap_yr = 1 }
          else                   { $is_leap_yr = 0 }
  
          my $upper = $is_leap_yr ? 29 : 28;
  
          return 0 unless $day >= 1 && $day <= $upper;
      }
  
      return 1;
  }
  
  sub nums_denote_valid_date_or_die {
  
      # Wrapper around &nums_denote_valid_date that Carp::Confess's if it
      # returns false.
  
      arg_count_or_die(5, 5, @_);
  
      unless ( nums_denote_valid_date(@_) ) {
          my ($yr, $mon, $day, $hr, $min) = @_;
          confess("yabsm: internal error: '${yr}_${mon}_${day}_$hr:$min' does not denote a valid yr_mon_day_hr:min date");
      }
  
      return 1;
  }
  
  sub system_or_die {
  
      # Wrapper around system that Carp::Confess's if the system command exits
      # with a non-zero status.
  
      arg_count_or_die(1, '_', @_);
  
      run3(@_ == 1 ? $_[0] : \@_, \undef, \undef, \my $stderr);
  
      unless (0 == $?) {
          chomp $stderr;
          $? >>= 8;
          confess("yabsm: internal error: system command '@_' exited with non-zero status '$?': captured stderr '$stderr'");
      }
  
      return 1;
  }
  
  sub make_path_or_die {
  
      # Wrapper around File::Path::make_path() that Carp::Confess's if the path
      # cannot be created. The UID and GID of the $path will be set to that of the
      # deepest existing sub-directory in $path.
  
      my $path = shift;
  
      $path =~ /^\//
        or die "yabsm: internal error: '$path' is not an absolute path starting with '/'";
  
      my $dir = $path;
  
      until (-d $dir) {
          $dir = dirname($dir);
      }
  
      my ($uid, $gid) = (stat $dir)[4,5];
  
      -d $path and return 1;
  
      make_path($path, {uid => $uid, group => $gid}) and return 1;
  
      my $username = getpwuid $<;
  
      die "yabsm: error: could not create path '$path' while running as user '$username'\n";
  }
  
  sub i_am_root {
  
      # Return 1 if current user is root and return 0 otherwise.
  
      return 0+(0 == $<);
  }
  
  sub i_am_root_or_die {
  
      # Die unless running as the root user.
  
      arg_count_or_die(0, 0, @_);
  
      unless (i_am_root()) {
          my $username = getpwuid $<;
          confess("yabsm: internal error: not running as root - running as '$username'");
      }
  
      return 1;
  }
  
  1;
APP_YABSM_TOOLS

$fatpacked{"Array/Utils.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'ARRAY_UTILS';
  package Array::Utils;
  
  =head1 NAME
  
  Array::Utils - small utils for array manipulation
  
  =head1 SYNOPSIS
  
  	use Array::Utils qw(:all);
  	
  	my @a = qw( a b c d );
  	my @b = qw( c d e f );
  
  	# symmetric difference
  	my @diff = array_diff(@a, @b);
  
  	# intersection
  	my @isect = intersect(@a, @b);
  	
  	# unique union
  	my @unique = unique(@a, @b);
  	
  	# check if arrays contain same members
  	if ( !array_diff(@a, @b) ) {
  		# do something
  	}
  	
  	# get items from array @a that are not in array @b
  	my @minus = array_minus( @a, @b );
  	
  =head1 DESCRIPTION
  
  A small pure-perl module containing list manipulation routines. The module
  emerged because I was tired to include same utility routines in numerous projects.
  
  =head1 FUNCTIONS
  
  =over 4
  
  =item C<unique>
  
  Returns an array of unique items in the arguments list.
  
  =item C<intersect>
  
  Returns an intersection of two arrays passed as arguments, keeping the order of the
  second parameter. A nice side effect of this function can be exploited in situations as:
  
  	@atreides = qw( Leto Paul Alia 'Leto II' );
  	@mylist = qw( Alia Leto );
  	@mylist = intersect( @mylist, @atreides );  # and @mylist is ordered as Leto,Alia
  
  =item C<array_diff>
  
  Return symmetric difference of two arrays passed as arguments.
  
  =item C<array_minus>
  
  Returns the difference of the passed arrays A and B (only those 
  array elements that exist in A and do not exist in B). 
  If an empty array is returned, A is subset of B.
  
  Function was proposed by Laszlo Forro <salmonix@gmail.com>.
  
  =back
  
  =head1 BUGS
  
  None known yet
  
  =head1 AUTHOR
  
  Sergei A. Fedorov <zmij@cpan.org>
  
  I will be happy to have your feedback about the module.
  
  =head1 COPYRIGHT
  
  This module is Copyright (c) 2007 Sergei A. Fedorov.
  All rights reserved.
  
  You may distribute under the terms of either the GNU General Public
  License or the Artistic License, as specified in the Perl README file.
  
  =head1 WARRANTY
  
  This is free software. IT COMES WITHOUT WARRANTY OF ANY KIND.
  
  =cut
  
  use strict;
  
  require Exporter;
  our @ISA = qw(Exporter);
  
  our %EXPORT_TAGS = (
  	all	=> [ qw(
  		&unique
  		&intersect
  		&array_diff
  		&array_minus
  	) ],
  );
  our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
  
  our $VERSION = '0.5';
  
  sub unique(@) {
  	return keys %{ {map { $_ => undef } @_}}; 
  }
  
  sub intersect(\@\@) {
  	my %e = map { $_ => undef } @{$_[0]};
  	return grep { exists( $e{$_} ) } @{$_[1]};
  }
  
  sub array_diff(\@\@) {
  	my %e = map { $_ => undef } @{$_[1]};
  	return @{[ ( grep { (exists $e{$_}) ? ( delete $e{$_} ) : ( 1 ) } @{ $_[0] } ), keys %e ] };
  }
  
  sub array_minus(\@\@) {
  	my %e = map{ $_ => undef } @{$_[1]};
  	return grep( ! exists( $e{$_} ), @{$_[0]} ); 
  }
  
  1;
ARRAY_UTILS

$fatpacked{"Feature/Compat/Try.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'FEATURE_COMPAT_TRY';
  #  You may distribute under the terms of either the GNU General Public License
  #  or the Artistic License (the same terms as Perl itself)
  #
  #  (C) Paul Evans, 2021 -- leonerd@leonerd.org.uk
  
  package Feature::Compat::Try 0.04;
  
  use v5.14;
  use warnings;
  use feature ();
  
  use constant HAVE_FEATURE_TRY => defined $feature::feature{try};
  
  =head1 NAME
  
  C<Feature::Compat::Try> - make C<try/catch> syntax available
  
  =head1 SYNOPSIS
  
     use Feature::Compat::Try;
  
     sub foo
     {
        try {
           attempt_a_thing();
           return "success";
        }
        catch ($e) {
           warn "It failed - $e";
           return "failure";
        }
     }
  
  =head1 DESCRIPTION
  
  This module is written in preparation for when perl will gain true native
  syntax support for C<try/catch> control flow.
  
  Perl added such syntax in the development version 5.33.7, which is enabled
  by
  
     use feature 'try';
  
  On that version of perl or later, this module simply enables the core feature
  equivalent to using it directly. On such perls, this module will install with
  no non-core dependencies, and requires no C compiler.
  
  On older versions of perl before such syntax is available, it is currently
  provided instead using the L<Syntax::Keyword::Try> module, imported with a
  special set of options to configure it to recognise exactly and only the same
  syntax as the core perl feature, thus ensuring that any code using it will
  still continue to function on that newer perl.
  
  =cut
  
  =head1 KEYWORDS
  
  =head2 try
  
     try {
        STATEMENTS...
     }
     ...
  
  A C<try> statement provides the main body of code that will be invoked, and
  must be followed by a C<catch> statement.
  
  Execution of the C<try> statement itself begins from the block given to the
  statement and continues until either it throws an exception, or completes
  successfully by reaching the end of the block.
  
  The body of a C<try {}> block may contain a C<return> expression. If executed,
  such an expression will cause the entire containing function to return with
  the value provided. This is different from a plain C<eval {}> block, in which
  circumstance only the C<eval> itself would return, not the entire function.
  
  The body of a C<try {}> block may contain loop control expressions (C<redo>,
  C<next>, C<last>) which will have their usual effect on any loops that the
  C<try {}> block is contained by.
  
  The parsing rules for the set of statements (the C<try> block and its
  associated C<catch>) are such that they are parsed as a self-contained
  statement. Because of this, there is no need to end with a terminating
  semicolon.
  
  Even though it parses as a statement and not an expression, a C<try> block can
  still yield a value if it appears as the final statement in its containing
  C<sub> or C<do> block. For example:
  
     my $result = do {
        try { attempt_func() }
        catch ($e) { "Fallback Value" }
     };
  
  =head2 catch
  
     ...
     catch ($var) {
        STATEMENTS...
     }
  
  A C<catch> statement provides a block of code to the preceding C<try>
  statement that will be invoked in the case that the main block of code throws
  an exception. A new lexical variable is created to store the exception in.
  
  Presence of this C<catch> statement causes any exception thrown by the
  preceding C<try> block to be non-fatal to the surrounding code. If the
  C<catch> block wishes to optionally handle some exceptions but not others, it
  can re-raise it (or another exception) by calling C<die> in the usual manner.
  
  As with C<try>, the body of a C<catch {}> block may also contain a C<return>
  expression, which as before, has its usual meaning, causing the entire
  containing function to return with the given value. The body may also contain
  loop control expressions (C<redo>, C<next> or C<last>) which also have their
  usual effect.
  
  =cut
  
  sub import
  {
     if( HAVE_FEATURE_TRY ) {
        feature->import(qw( try ));
        require warnings;
        warnings->unimport(qw( experimental::try ));
     }
     else {
        require Syntax::Keyword::Try;
        Syntax::Keyword::Try->VERSION( '0.22' );
        Syntax::Keyword::Try->import(qw( try -no_finally -require_var ));
     }
  }
  
  =head1 COMPATIBILITY NOTES
  
  This module may use either L<Syntax::Keyword::Try> or the perl core C<try>
  feature to implement its syntax. While the two behave very similarly, and both
  conform to the description given above, the following differences should be
  noted.
  
  =over 4
  
  =item * Visibility to C<caller()>
  
  The C<Syntax::Keyword::Try> module implements C<try> blocks by using C<eval>
  frames. As a result, they are visible to the C<caller()> function and hence to
  things like C<Carp::longmess> when viewed as stack traces.
  
  By comparison, core's C<feature 'try'> creates a new kind of context stack
  entry that is ignored by C<caller()> and hence these blocks do not show up in
  stack traces.
  
  This should not matter to most use-cases - e.g. even C<Carp::croak> will be
  fine here. But if you are using C<caller()> with calculated indexes to inspect
  the state of callers to your code and there may be C<try> frames in the way,
  you will need to somehow account for the difference in stack height.
  
  =back
  
  =cut
  
  =head1 AUTHOR
  
  Paul Evans <leonerd@leonerd.org.uk>
  
  =cut
  
  0x55AA;
FEATURE_COMPAT_TRY

$fatpacked{"IPC/Run3.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'IPC_RUN3';
  package IPC::Run3;
  BEGIN { require 5.006_000; } # i.e. 5.6.0
  use strict;
  
  =head1 NAME
  
  IPC::Run3 - run a subprocess with input/ouput redirection
  
  =head1 VERSION
  
  version 0.048
  
  =cut
  
  our $VERSION = '0.048';
  
  =head1 SYNOPSIS
  
      use IPC::Run3;    # Exports run3() by default
  
      run3 \@cmd, \$in, \$out, \$err;
  
  =head1 DESCRIPTION
  
  This module allows you to run a subprocess and redirect stdin, stdout,
  and/or stderr to files and perl data structures.  It aims to satisfy 99% of the
  need for using C<system>, C<qx>, and C<open3>
  with a simple, extremely Perlish API.
  
  Speed, simplicity, and portability are paramount.  (That's speed of Perl code;
  which is often much slower than the kind of buffered I/O that this module uses
  to spool input to and output from the child command.)
  
  =cut
  
  use Exporter;
  our @ISA = qw(Exporter);
  our @EXPORT = qw( run3 );
  our %EXPORT_TAGS = ( all => \@EXPORT );
  
  use constant debugging => $ENV{IPCRUN3DEBUG} || $ENV{IPCRUNDEBUG} || 0;
  use constant profiling => $ENV{IPCRUN3PROFILE} || $ENV{IPCRUNPROFILE} || 0;
  use constant is_win32  => 0 <= index $^O, "Win32";
  
  BEGIN {
     if ( is_win32 ) {
        eval "use Win32 qw( GetOSName ); use Win32::ShellQuote qw(quote_native); 1" or die $@;
     }
  }
  
  #use constant is_win2k => is_win32 && GetOSName() =~ /Win2000/i;
  #use constant is_winXP => is_win32 && GetOSName() =~ /WinXP/i;
  
  use Carp qw( croak );
  use File::Temp qw( tempfile );
  use POSIX qw( dup dup2 );
  
  # We cache the handles of our temp files in order to
  # keep from having to incur the (largish) overhead of File::Temp
  my %fh_cache;
  my $fh_cache_pid = $$;
  
  my $profiler;
  
  sub _profiler { $profiler } # test suite access
  
  BEGIN {
      if ( profiling ) {
          eval "use Time::HiRes qw( gettimeofday ); 1" or die $@;
          if ( $ENV{IPCRUN3PROFILE} =~ /\A\d+\z/ ) {
              require IPC::Run3::ProfPP;
              IPC::Run3::ProfPP->import;
              $profiler = IPC::Run3::ProfPP->new(Level => $ENV{IPCRUN3PROFILE});
          } else {
              my ( $dest, undef, $class ) =
                 reverse split /(=)/, $ENV{IPCRUN3PROFILE}, 2;
              $class = "IPC::Run3::ProfLogger"
                  unless defined $class && length $class;
              if ( not eval "require $class" ) {
                  my $e = $@;
                  $class = "IPC::Run3::$class";
                  eval "require IPC::Run3::$class" or die $e;
              }
              $profiler = $class->new( Destination => $dest );
          }
          $profiler->app_call( [ $0, @ARGV ], scalar gettimeofday() );
      }
  }
  
  
  END {
      $profiler->app_exit( scalar gettimeofday() ) if profiling;
  }
  
  sub _binmode {
      my ( $fh, $mode, $what ) = @_;
      # if $mode is not given, then default to ":raw", except on Windows,
      # where we default to ":crlf";
      # otherwise if a proper layer string was given, use that,
      # else use ":raw"
      my $layer = !$mode
         ? (is_win32 ? ":crlf" : ":raw")
         : ($mode =~ /^:/ ? $mode : ":raw");
      warn "binmode $what, $layer\n" if debugging >= 2;
  
      binmode $fh, ":raw" unless $layer eq ":raw";      # remove all layers first
      binmode $fh, $layer or croak "binmode $layer failed: $!";
  }
  
  sub _spool_data_to_child {
      my ( $type, $source, $binmode_it ) = @_;
  
      # If undef (not \undef) passed, they want the child to inherit
      # the parent's STDIN.
      return undef unless defined $source;
  
      my $fh;
      if ( ! $type ) {
          open $fh, "<", $source or croak "$!: $source";
         _binmode($fh, $binmode_it, "STDIN");
          warn "run3(): feeding file '$source' to child STDIN\n"
              if debugging >= 2;
      } elsif ( $type eq "FH" ) {
          $fh = $source;
          warn "run3(): feeding filehandle '$source' to child STDIN\n"
              if debugging >= 2;
      } else {
          $fh = $fh_cache{in} ||= tempfile;
          truncate $fh, 0;
          seek $fh, 0, 0;
         _binmode($fh, $binmode_it, "STDIN");
          my $seekit;
          if ( $type eq "SCALAR" ) {
  
              # When the run3()'s caller asks to feed an empty file
              # to the child's stdin, we want to pass a live file
              # descriptor to an empty file (like /dev/null) so that
              # they don't get surprised by invalid fd errors and get
              # normal EOF behaviors.
              return $fh unless defined $$source;  # \undef passed
  
              warn "run3(): feeding SCALAR to child STDIN",
                  debugging >= 3
                     ? ( ": '", $$source, "' (", length $$source, " chars)" )
                     : (),
                  "\n"
                  if debugging >= 2;
  
              $seekit = length $$source;
              print $fh $$source or die "$! writing to temp file";
  
          } elsif ( $type eq "ARRAY" ) {
              warn "run3(): feeding ARRAY to child STDIN",
                  debugging >= 3 ? ( ": '", @$source, "'" ) : (),
                  "\n"
              if debugging >= 2;
  
              print $fh @$source or die "$! writing to temp file";
              $seekit = grep length, @$source;
          } elsif ( $type eq "CODE" ) {
              warn "run3(): feeding output of CODE ref '$source' to child STDIN\n"
                  if debugging >= 2;
              my $parms = [];  # TODO: get these from $options
              while (1) {
                  my $data = $source->( @$parms );
                  last unless defined $data;
                  print $fh $data or die "$! writing to temp file";
                  $seekit = length $data;
              }
          }
  
          seek $fh, 0, 0 or croak "$! seeking on temp file for child's stdin"
              if $seekit;
      }
  
      croak "run3() can't redirect $type to child stdin"
          unless defined $fh;
  
      return $fh;
  }
  
  sub _fh_for_child_output {
      my ( $what, $type, $dest, $options ) = @_;
  
      my $fh;
      if ( $type eq "SCALAR" && $dest == \undef ) {
          warn "run3(): redirecting child $what to oblivion\n"
              if debugging >= 2;
  
          $fh = $fh_cache{nul} ||= do {
              open $fh, ">", File::Spec->devnull;
             $fh;
          };
      } elsif ( $type eq "FH" ) {
          $fh = $dest;
          warn "run3(): redirecting $what to filehandle '$dest'\n"
              if debugging >= 3;
      } elsif ( !$type ) {
          warn "run3(): feeding child $what to file '$dest'\n"
              if debugging >= 2;
  
          open $fh, $options->{"append_$what"} ? ">>" : ">", $dest
             or croak "$!: $dest";
      } else {
          warn "run3(): capturing child $what\n"
              if debugging >= 2;
  
          $fh = $fh_cache{$what} ||= tempfile;
          seek $fh, 0, 0;
          truncate $fh, 0;
      }
  
      my $binmode_it = $options->{"binmode_$what"};
      _binmode($fh, $binmode_it, uc $what);
  
      return $fh;
  }
  
  sub _read_child_output_fh {
      my ( $what, $type, $dest, $fh, $options ) = @_;
  
      return if $type eq "SCALAR" && $dest == \undef;
  
      seek $fh, 0, 0 or croak "$! seeking on temp file for child $what";
  
      if ( $type eq "SCALAR" ) {
          warn "run3(): reading child $what to SCALAR\n"
              if debugging >= 3;
  
          # two read()s are used instead of 1 so that the first will be
          # logged even it reads 0 bytes; the second won't.
          my $count = read $fh, $$dest, 10_000,
             $options->{"append_$what"} ? length $$dest : 0;
          while (1) {
              croak "$! reading child $what from temp file"
                  unless defined $count;
  
              last unless $count;
  
              warn "run3(): read $count bytes from child $what",
                  debugging >= 3 ? ( ": '", substr( $$dest, -$count ), "'" ) : (),
                  "\n"
                  if debugging >= 2;
  
              $count = read $fh, $$dest, 10_000, length $$dest;
          }
      } elsif ( $type eq "ARRAY" ) {
         if ($options->{"append_$what"}) {
             push @$dest, <$fh>;
         } else {
             @$dest = <$fh>;
         }
          if ( debugging >= 2 ) {
              my $count = 0;
              $count += length for @$dest;
              warn
                  "run3(): read ",
                  scalar @$dest,
                  " records, $count bytes from child $what",
                  debugging >= 3 ? ( ": '", @$dest, "'" ) : (),
                  "\n";
          }
      } elsif ( $type eq "CODE" ) {
          warn "run3(): capturing child $what to CODE ref\n"
              if debugging >= 3;
  
          local $_;
          while ( <$fh> ) {
              warn
                  "run3(): read ",
                  length,
                  " bytes from child $what",
                  debugging >= 3 ? ( ": '", $_, "'" ) : (),
                  "\n"
                  if debugging >= 2;
  
              $dest->( $_ );
          }
      } else {
          croak "run3() can't redirect child $what to a $type";
      }
  
  }
  
  sub _type {
      my ( $redir ) = @_;
  
      return "FH" if eval {
          local $SIG{'__DIE__'};
          $redir->isa("IO::Handle")
      };
  
      my $type = ref $redir;
      return $type eq "GLOB" ? "FH" : $type;
  }
  
  sub _max_fd {
      my $fd = dup(0);
      POSIX::close $fd;
      return $fd;
  }
  
  my $run_call_time;
  my $sys_call_time;
  my $sys_exit_time;
  
  sub run3 {
      $run_call_time = gettimeofday() if profiling;
  
      my $options = @_ && ref $_[-1] eq "HASH" ? pop : {};
  
      my ( $cmd, $stdin, $stdout, $stderr ) = @_;
  
      print STDERR "run3(): running ",
         join( " ", map "'$_'", ref $cmd ? @$cmd : $cmd ),
         "\n"
         if debugging;
  
      if ( ref $cmd ) {
          croak "run3(): empty command"     unless @$cmd;
          croak "run3(): undefined command" unless defined $cmd->[0];
          croak "run3(): command name ('')" unless length  $cmd->[0];
      } else {
          croak "run3(): missing command" unless @_;
          croak "run3(): undefined command" unless defined $cmd;
          croak "run3(): command ('')" unless length  $cmd;
      }
  
      foreach (qw/binmode_stdin binmode_stdout binmode_stderr/) {
         if (my $mode = $options->{$_}) {
             croak qq[option $_ must be a number or a proper layer string: "$mode"]
                unless $mode =~ /^(:|\d+$)/;
         }
      }
  
      my $in_type  = _type $stdin;
      my $out_type = _type $stdout;
      my $err_type = _type $stderr;
  
      if ($fh_cache_pid != $$) {
         # fork detected, close all cached filehandles and clear the cache
         close $_ foreach values %fh_cache;
         %fh_cache = ();
         $fh_cache_pid = $$;
      }
  
      # This routine proceeds in stages so that a failure in an early
      # stage prevents later stages from running, and thus from needing
      # cleanup.
  
      my $in_fh  = _spool_data_to_child $in_type, $stdin,
          $options->{binmode_stdin} if defined $stdin;
  
      my $out_fh = _fh_for_child_output "stdout", $out_type, $stdout,
          $options if defined $stdout;
  
      my $tie_err_to_out =
          defined $stderr && defined $stdout && $stderr eq $stdout;
  
      my $err_fh = $tie_err_to_out
          ? $out_fh
          : _fh_for_child_output "stderr", $err_type, $stderr,
              $options if defined $stderr;
  
      # this should make perl close these on exceptions
  #    local *STDIN_SAVE;
      local *STDOUT_SAVE;
      local *STDERR_SAVE;
  
      my $saved_fd0 = dup( 0 ) if defined $in_fh;
  
  #    open STDIN_SAVE,  "<&STDIN"#  or croak "run3(): $! saving STDIN"
  #        if defined $in_fh;
      open STDOUT_SAVE, ">&STDOUT" or croak "run3(): $! saving STDOUT"
          if defined $out_fh;
      open STDERR_SAVE, ">&STDERR" or croak "run3(): $! saving STDERR"
          if defined $err_fh;
  
      my $errno;
      my $ok = eval {
          # The open() call here seems to not force fd 0 in some cases;
          # I ran in to trouble when using this in VCP, not sure why.
          # the dup2() seems to work.
          dup2( fileno $in_fh, 0 )
  #        open STDIN,  "<&=" . fileno $in_fh
              or croak "run3(): $! redirecting STDIN"
              if defined $in_fh;
  
  #        close $in_fh or croak "$! closing STDIN temp file"
  #            if ref $stdin;
  
          open STDOUT, ">&" . fileno $out_fh
              or croak "run3(): $! redirecting STDOUT"
              if defined $out_fh;
  
          open STDERR, ">&" . fileno $err_fh
              or croak "run3(): $! redirecting STDERR"
              if defined $err_fh;
  
          $sys_call_time = gettimeofday() if profiling;
  
          my $r = ref $cmd
                ? system { $cmd->[0] } is_win32 ? quote_native( @$cmd ) : @$cmd
                : system $cmd;
  
         $errno = $!;              # save $!, because later failures will overwrite it
          $sys_exit_time = gettimeofday() if profiling;
          if ( debugging ) {
              my $err_fh = defined $err_fh ? \*STDERR_SAVE : \*STDERR;
             if ( defined $r && $r != -1 ) {
                print $err_fh "run3(): \$? is $?\n";
             } else {
                print $err_fh "run3(): \$? is $?, \$! is $errno\n";
             }
          }
  
          if (
              defined $r
              && ( $r == -1 || ( is_win32 && $r == 0xFF00 ) )
              && !$options->{return_if_system_error}
          ) {
              croak( $errno );
          }
  
          1;
      };
      my $x = $@;
  
      my @errs;
  
      if ( defined $saved_fd0 ) {
          dup2( $saved_fd0, 0 );
          POSIX::close( $saved_fd0 );
      }
  
  #    open STDIN,  "<&STDIN_SAVE"#  or push @errs, "run3(): $! restoring STDIN"
  #        if defined $in_fh;
      open STDOUT, ">&STDOUT_SAVE" or push @errs, "run3(): $! restoring STDOUT"
          if defined $out_fh;
      open STDERR, ">&STDERR_SAVE" or push @errs, "run3(): $! restoring STDERR"
          if defined $err_fh;
  
      croak join ", ", @errs if @errs;
  
      die $x unless $ok;
  
      _read_child_output_fh "stdout", $out_type, $stdout, $out_fh, $options
          if defined $out_fh && $out_type && $out_type ne "FH";
      _read_child_output_fh "stderr", $err_type, $stderr, $err_fh, $options
          if defined $err_fh && $err_type && $err_type ne "FH" && !$tie_err_to_out;
      $profiler->run_exit(
         $cmd,
         $run_call_time,
         $sys_call_time,
         $sys_exit_time,
         scalar gettimeofday()
      ) if profiling;
  
      $! = $errno;              # restore $! from system()
  
      return 1;
  }
  
  1;
  
  __END__
  
  =head2 C<< run3($cmd, $stdin, $stdout, $stderr, \%options) >>
  
  All parameters after C<$cmd> are optional.
  
  The parameters C<$stdin>, C<$stdout> and C<$stderr> indicate how the child's
  corresponding filehandle (C<STDIN>, C<STDOUT> and C<STDERR>, resp.) will be
  redirected.  Because the redirects come last, this allows C<STDOUT> and
  C<STDERR> to default to the parent's by just not specifying them -- a common
  use case.
  
  C<run3> throws an exception if the wrapped C<system> call returned -1 or
  anything went wrong with C<run3>'s processing of filehandles.  Otherwise it
  returns true.  It leaves C<$?> intact for inspection of exit and wait status.
  
  Note that a true return value from C<run3> doesn't mean that the command had a
  successful exit code. Hence you should always check C<$?>.
  
  See L</%options> for an option to handle the case of C<system> returning -1
  yourself.
  
  =head3 C<$cmd>
  
  Usually C<$cmd> will be an ARRAY reference and the child is invoked via
  
    system @$cmd;
  
  But C<$cmd> may also be a string in which case the child is invoked via
  
    system $cmd;
  
  (cf. L<perlfunc/system> for the difference and the pitfalls of using
  the latter form).
  
  =head3 C<$stdin>, C<$stdout>, C<$stderr>
  
  The parameters C<$stdin>, C<$stdout> and C<$stderr> can take one of the
  following forms:
  
  =over 4
  
  =item C<undef> (or not specified at all)
  
  The child inherits the corresponding filehandle from the parent.
  
    run3 \@cmd, $stdin;                   # child writes to same STDOUT and STDERR as parent
    run3 \@cmd, undef, $stdout, $stderr;  # child reads from same STDIN as parent
  
  =item C<\undef>
  
  The child's filehandle is redirected from or to the local equivalent of
  C</dev/null> (as returned by C<< File::Spec->devnull() >>).
  
    run3 \@cmd, \undef, $stdout, $stderr; # child reads from /dev/null
  
  =item a simple scalar
  
  The parameter is taken to be the name of a file to read from
  or write to. In the latter case, the file will be opened via
  
    open FH, ">", ...
  
  i.e. it is created if it doesn't exist and truncated otherwise.
  Note that the file is opened by the parent which will L<croak|Carp/croak>
  in case of failure.
  
    run3 \@cmd, \undef, "out.txt";        # child writes to file "out.txt"
  
  =item a filehandle (either a reference to a GLOB or an C<IO::Handle>)
  
  The filehandle is inherited by the child.
  
    open my $fh, ">", "out.txt";
    print $fh "prologue\n";
    ...
    run3 \@cmd, \undef, $fh;              # child writes to $fh
    ...
    print $fh "epilogue\n";
    close $fh;
  
  =item a SCALAR reference
  
  The referenced scalar is treated as a string to be read from or
  written to. In the latter case, the previous content of the string
  is overwritten.
  
    my $out;
    run3 \@cmd, \undef, \$out;           # child writes into string
    run3 \@cmd, \<<EOF;                  # child reads from string (can use "here" notation)
    Input
    to
    child
    EOF
  
  =item an ARRAY reference
  
  For C<$stdin>, the elements of C<@$stdin> are simply spooled to the child.
  
  For C<$stdout> or C<$stderr>, the child's corresponding file descriptor
  is read line by line (as determined by the current setting of C<$/>)
  into C<@$stdout> or C<@$stderr>, resp. The previous content of the array
  is overwritten.
  
    my @lines;
    run3 \@cmd, \undef, \@lines;         # child writes into array
  
  =item a CODE reference
  
  For C<$stdin>, C<&$stdin> will be called repeatedly (with no arguments) and
  the return values are spooled to the child. C<&$stdin> must signal the end of
  input by returning C<undef>.
  
  For C<$stdout> or C<$stderr>, the child's corresponding file descriptor
  is read line by line (as determined by the current setting of C<$/>)
  and C<&$stdout> or C<&$stderr>, resp., is called with the contents of the line.
  Note that there's no end-of-file indication.
  
    my $i = 0;
    sub producer {
      return $i < 10 ? "line".$i++."\n" : undef;
    }
  
    run3 \@cmd, \&producer;              # child reads 10 lines
  
  Note that this form of redirecting the child's I/O doesn't imply
  any form of concurrency between parent and child - run3()'s method of
  operation is the same no matter which form of redirection you specify.
  
  =back
  
  If the same value is passed for C<$stdout> and C<$stderr>, then the child
  will write both C<STDOUT> and C<STDERR> to the same filehandle.
  In general, this means that
  
      run3 \@cmd, \undef, "foo.txt", "foo.txt";
      run3 \@cmd, \undef, \$both, \$both;
  
  will DWIM and pass a single file handle to the child for both C<STDOUT> and
  C<STDERR>, collecting all into file "foo.txt" or C<$both>.
  
  =head3 C<\%options>
  
  The last parameter, C<\%options>, must be a hash reference if present.
  
  Currently the following keys are supported:
  
  =over 4
  
  =item C<binmode_stdin>, C<binmode_stdout>, C<binmode_stderr>
  
  The value must a "layer" as described in L<perlfunc/binmode>.  If specified the
  corresponding parameter C<$stdin>, C<$stdout> or C<$stderr>, resp., operates
  with the given layer.
  
  For backward compatibility, a true value that doesn't start with ":"
  (e.g. a number) is interpreted as ":raw". If the value is false
  or not specified, the default is ":crlf" on Windows and ":raw" otherwise.
  
  Don't expect that values other than the built-in layers ":raw", ":crlf",
  and (on newer Perls) ":bytes", ":utf8", ":encoding(...)" will work.
  
  =item C<append_stdout>, C<append_stderr>
  
  If their value is true then the corresponding parameter C<$stdout> or
  C<$stderr>, resp., will append the child's output to the existing "contents" of
  the redirector. This only makes sense if the redirector is a simple scalar (the
  corresponding file is opened in append mode), a SCALAR reference (the output is
  appended to the previous contents of the string) or an ARRAY reference (the
  output is C<push>ed onto the previous contents of the array).
  
  =item C<return_if_system_error>
  
  If this is true C<run3> does B<not> throw an exception if C<system> returns -1
  (cf. L<perlfunc/system> for possible failure scenarios.), but returns true
  instead.  In this case C<$?> has the value -1 and C<$!> contains the errno of
  the failing C<system> call.
  
  =back
  
  =head1 HOW IT WORKS
  
  =over 4
  
  =item (1)
  
  For each redirector C<$stdin>, C<$stdout>, and C<$stderr>, C<run3()> furnishes
  a filehandle:
  
  =over 4
  
  =item *
  
  if the redirector already specifies a filehandle it just uses that
  
  =item *
  
  if the redirector specifies a filename, C<run3()> opens the file
  in the appropriate mode
  
  =item *
  
  in all other cases, C<run3()> opens a temporary file (using
  L<tempfile|Temp/tempfile>)
  
  =back
  
  =item (2)
  
  If C<run3()> opened a temporary file for C<$stdin> in step (1),
  it writes the data using the specified method (either
  from a string, an array or returned by a function) to the temporary file and rewinds it.
  
  =item (3)
  
  C<run3()> saves the parent's C<STDIN>, C<STDOUT> and C<STDERR> by duplicating
  them to new filehandles. It duplicates the filehandles from step (1)
  to C<STDIN>, C<STDOUT> and C<STDERR>, resp.
  
  =item (4)
  
  C<run3()> runs the child by invoking L<system|perlfunc/system> with C<$cmd> as
  specified above.
  
  =item (5)
  
  C<run3()> restores the parent's C<STDIN>, C<STDOUT> and C<STDERR> saved in step (3).
  
  =item (6)
  
  If C<run3()> opened a temporary file for C<$stdout> or C<$stderr> in step (1),
  it rewinds it and reads back its contents using the specified method (either to
  a string, an array or by calling a function).
  
  =item (7)
  
  C<run3()> closes all filehandles that it opened explicitly in step (1).
  
  =back
  
  Note that when using temporary files, C<run3()> tries to amortize the overhead
  by reusing them (i.e. it keeps them open and rewinds and truncates them
  before the next operation).
  
  =head1 LIMITATIONS
  
  Often uses intermediate files (determined by File::Temp, and thus by the
  File::Spec defaults and the TMPDIR env. variable) for speed, portability and
  simplicity.
  
  Use extreme caution when using C<run3> in a threaded environment if concurrent
  calls of C<run3> are possible. Most likely, I/O from different invocations will
  get mixed up. The reason is that in most thread implementations all threads in
  a process share the same STDIN/STDOUT/STDERR.  Known failures are Perl ithreads
  on Linux and Win32. Note that C<fork> on Win32 is emulated via Win32 threads
  and hence I/O mix up is possible between forked children here (C<run3> is "fork
  safe" on Unix, though).
  
  =head1 DEBUGGING
  
  To enable debugging use the IPCRUN3DEBUG environment variable to
  a non-zero integer value:
  
    $ IPCRUN3DEBUG=1 myapp
  
  =head1 PROFILING
  
  To enable profiling, set IPCRUN3PROFILE to a number to enable emitting profile
  information to STDERR (1 to get timestamps, 2 to get a summary report at the
  END of the program, 3 to get mini reports after each run) or to a filename to
  emit raw data to a file for later analysis.
  
  =head1 COMPARISON
  
  Here's how it stacks up to existing APIs:
  
  =head2 compared to C<system()>, C<qx''>, C<open "...|">, C<open "|...">
  
  =over
  
  =item *
  
  better: redirects more than one file descriptor
  
  =item *
  
  better: returns TRUE on success, FALSE on failure
  
  =item *
  
  better: throws an error if problems occur in the parent process (or the
  pre-exec child)
  
  =item *
  
  better: allows a very perlish interface to Perl data structures and subroutines
  
  =item *
  
  better: allows 1 word invocations to avoid the shell easily:
  
   run3 ["foo"];  # does not invoke shell
  
  =item *
  
  worse: does not return the exit code, leaves it in $?
  
  =back
  
  =head2 compared to C<open2()>, C<open3()>
  
  =over
  
  =item *
  
  better: no lengthy, error prone polling/select loop needed
  
  =item *
  
  better: hides OS dependencies
  
  =item *
  
  better: allows SCALAR, ARRAY, and CODE references to source and sink I/O
  
  =item *
  
  better: I/O parameter order is like C<open3()>  (not like C<open2()>).
  
  =item *
  
  worse: does not allow interaction with the subprocess
  
  =back
  
  =head2 compared to L<IPC::Run::run()|IPC::Run/run>
  
  =over
  
  =item *
  
  better: smaller, lower overhead, simpler, more portable
  
  =item *
  
  better: no select() loop portability issues
  
  =item *
  
  better: does not fall prey to Perl closure leaks
  
  =item *
  
  worse: does not allow interaction with the subprocess (which IPC::Run::run()
  allows by redirecting subroutines)
  
  =item *
  
  worse: lacks many features of C<IPC::Run::run()> (filters, pipes, redirects,
  pty support)
  
  =back
  
  =head1 COPYRIGHT
  
  Copyright 2003, R. Barrie Slaymaker, Jr., All Rights Reserved
  
  =head1 LICENSE
  
  You may use this module under the terms of the BSD, Artistic, or GPL licenses,
  any version.
  
  =head1 AUTHOR
  
  Barrie Slaymaker E<lt>C<barries@slaysys.com>E<gt>
  
  Ricardo SIGNES E<lt>C<rjbs@cpan.org>E<gt> performed routine maintenance since
  2010, thanks to help from the following ticket and/or patch submitters: Jody
  Belka, Roderich Schupp, David Morel, Jeff Lavallee, and anonymous others.
  
  =cut
IPC_RUN3

$fatpacked{"IPC/Run3/ProfArrayBuffer.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'IPC_RUN3_PROFARRAYBUFFER';
  package IPC::Run3::ProfArrayBuffer;
  
  $VERSION = 0.048;
  
  =head1 NAME
  
  IPC::Run3::ProfArrayBuffer - Store profile events in RAM in an array
  
  =head1 SYNOPSIS
  
  =head1 DESCRIPTION
  
  =cut
  
  use strict;
  
  =head1 METHODS
  
  =over
  
  =item C<< IPC::Run3::ProfArrayBuffer->new() >>
  
  =cut
  
  sub new {
      my $class = ref $_[0] ? ref shift : shift;
  
      my $self = bless { @_ }, $class;
  
      $self->{Events} = [];
  
      return $self;
  }
  
  =item C<< $buffer->app_call(@events) >>
  
  =item C<< $buffer->app_exit(@events) >>
  
  =item C<< $buffer->run_exit(@events) >>
  
  The three above methods push the given events onto the stack of recorded
  events.
  
  =cut
  
  for my $subname ( qw(app_call app_exit run_exit) ) {
    no strict 'refs';
    *{$subname} = sub {
        push @{shift->{Events}}, [ $subname => @_ ];
    };
  }
  
  =item get_events
  
  Returns a list of all the events.  Each event is an ARRAY reference
  like:
  
     [ "app_call", 1.1, ... ];
  
  =cut
  
  sub get_events {
      my $self = shift;
      @{$self->{Events}};
  }
  
  =back
  
  =head1 LIMITATIONS
  
  =head1 COPYRIGHT
  
  Copyright 2003, R. Barrie Slaymaker, Jr., All Rights Reserved
  
  =head1 LICENSE
  
  You may use this module under the terms of the BSD, Artistic, or GPL licenses,
  any version.
  
  =head1 AUTHOR
  
  Barrie Slaymaker E<lt>barries@slaysys.comE<gt>
  
  =cut
  
  1;
IPC_RUN3_PROFARRAYBUFFER

$fatpacked{"IPC/Run3/ProfLogReader.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'IPC_RUN3_PROFLOGREADER';
  package IPC::Run3::ProfLogReader;
  
  $VERSION = 0.048;
  
  =head1 NAME
  
  IPC::Run3::ProfLogReader -  read and process a ProfLogger file
  
  =head1 SYNOPSIS
  
   use IPC::Run3::ProfLogReader;
  
   my $reader = IPC::Run3::ProfLogReader->new; ## use "run3.out"
   my $reader = IPC::Run3::ProfLogReader->new( Source => $fn );
  
   my $profiler = IPC::Run3::ProfPP;   ## For example
   my $reader   = IPC::Run3::ProfLogReader->new( ..., Handler => $p );
  
   $reader->read;
   $eaderr->read_all;
  
  =head1 DESCRIPTION
  
  Reads a log file.  Use the filename "-" to read from STDIN.
  
  =cut
  
  use strict;
  
  =head1 METHODS
  
  =head2 C<< IPC::Run3::ProfLogReader->new( ... ) >>
  
  =cut
  
  sub new {
      my $class = ref $_[0] ? ref shift : shift;
      my $self = bless { @_ }, $class;
      
      $self->{Source} = "run3.out"
          unless defined $self->{Source} && length $self->{Source};
  
      my $source = $self->{Source};
  
      if ( ref $source eq "GLOB" || UNIVERSAL::isa( $source, "IO::Handle" ) ) {
          $self->{FH} = $source;
      }
      elsif ( $source eq "-" ) {
          $self->{FH} = \*STDIN;
      }
      else {
          open PROFILE, "<$self->{Source}" or die "$!: $self->{Source}\n";
          $self->{FH} = *PROFILE{IO};
      }
      return $self;
  }
  
  
  =head2 C<< $reader->set_handler( $handler ) >>
  
  =cut
  
  sub set_handler { $_[0]->{Handler} = $_[1] }
  
  =head2 C<< $reader->get_handler() >>
  
  =cut
  
  sub get_handler { $_[0]->{Handler} }
  
  =head2 C<< $reader->read() >>
  
  =cut
  
  sub read {
      my $self = shift;
  
      my $fh = $self->{FH};
      my @ln = split / /, <$fh>;
  
      return 0 unless @ln;
      return 1 unless $self->{Handler};
  
      chomp $ln[-1];
  
      ## Ignore blank and comment lines.
      return 1 if @ln == 1 && ! length $ln[0] || 0 == index $ln[0], "#";
  
      if ( $ln[0] eq "\\app_call" ) {
          shift @ln;
          my @times = split /,/, pop @ln;
          $self->{Handler}->app_call(
              [
                  map {
                      s/\\\\/\\/g;
                      s/\\_/ /g;
                      $_;
                  } @ln
              ],
              @times
          );
      }
      elsif ( $ln[0] eq "\\app_exit" ) {
          shift @ln;
          $self->{Handler}->app_exit( pop @ln, @ln );
      }
      else {
          my @times = split /,/, pop @ln;
          $self->{Handler}->run_exit(
              [
                  map {
                      s/\\\\/\\/g;
                      s/\\_/ /g;
                      $_;
                  } @ln
              ],
              @times
          );
      }
  
      return 1;
  }
  
  
  =head2 C<< $reader->read_all() >>
  
  This method reads until there is nothing left to read, and then returns true.
  
  =cut
  
  sub read_all {
      my $self = shift;
  
      1 while $self->read;
  
      return 1;
  }
  
  
  =head1 LIMITATIONS
  
  =head1 COPYRIGHT
  
      Copyright 2003, R. Barrie Slaymaker, Jr., All Rights Reserved
  
  =head1 LICENSE
  
  You may use this module under the terms of the BSD, Artistic, or GPL licenses,
  any version.
  
  =head1 AUTHOR
  
  Barrie Slaymaker E<lt>barries@slaysys.comE<gt>
  
  =cut
  
  1;
IPC_RUN3_PROFLOGREADER

$fatpacked{"IPC/Run3/ProfLogger.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'IPC_RUN3_PROFLOGGER';
  package IPC::Run3::ProfLogger;
  
  $VERSION = 0.048;
  
  =head1 NAME
  
  IPC::Run3::ProfLogger - write profiling data to a log file
  
  =head1 SYNOPSIS
  
   use IPC::Run3::ProfLogger;
  
   my $logger = IPC::Run3::ProfLogger->new;  ## write to "run3.out"
   my $logger = IPC::Run3::ProfLogger->new( Destination => $fn );
  
   $logger->app_call( \@cmd, $time );
  
   $logger->run_exit( \@cmd1, @times1 );
   $logger->run_exit( \@cmd1, @times1 );
  
   $logger->app_exit( $time );
  
  =head1 DESCRIPTION
  
  Used by IPC::Run3 to write a profiling log file.  Does not
  generate reports or maintain statistics; its meant to have minimal
  overhead.
  
  Its API is compatible with a tiny subset of the other IPC::Run profiling
  classes.
  
  =cut
  
  use strict;
  
  =head1 METHODS
  
  =head2 C<< IPC::Run3::ProfLogger->new( ... ) >>
  
  =cut
  
  sub new {
      my $class = ref $_[0] ? ref shift : shift;
      my $self = bless { @_ }, $class;
      
      $self->{Destination} = "run3.out"
          unless defined $self->{Destination} && length $self->{Destination};
  
      open PROFILE, ">$self->{Destination}"
          or die "$!: $self->{Destination}\n";
      binmode PROFILE;
      $self->{FH} = *PROFILE{IO};
  
      $self->{times} = [];
      return $self;
  }
  
  =head2 C<< $logger->run_exit( ... ) >>
  
  =cut
  
  sub run_exit {
      my $self = shift;
      my $fh = $self->{FH};
      print( $fh
          join(
              " ",
              (
                  map {
                      my $s = $_;
                      $s =~ s/\\/\\\\/g;
                      $s =~ s/ /_/g;
                      $s;
                  } @{shift()}
              ),
              join(
                  ",",
                  @{$self->{times}},
                  @_,
              ),
          ),
          "\n"
      );
  }
  
  =head2 C<< $logger->app_exit( $arg ) >>
  
  =cut
  
  sub app_exit {
      my $self = shift;
      my $fh = $self->{FH};
      print $fh "\\app_exit ", shift, "\n";
  }
  
  =head2 C<< $logger->app_call( $t, @args) >>
  
  =cut
  
  sub app_call {
      my $self = shift;
      my $fh = $self->{FH};
      my $t = shift;
      print( $fh
          join(
              " ",
              "\\app_call",
              (
                  map {
                      my $s = $_;
                      $s =~ s/\\\\/\\/g;
                      $s =~ s/ /\\_/g;
                      $s;
                  } @_
              ),
              $t,
          ),
          "\n"
      );
  }
  
  =head1 LIMITATIONS
  
  =head1 COPYRIGHT
  
  Copyright 2003, R. Barrie Slaymaker, Jr., All Rights Reserved
  
  =head1 LICENSE
  
  You may use this module under the terms of the BSD, Artistic, or GPL licenses,
  any version.
  
  =head1 AUTHOR
  
  Barrie Slaymaker E<lt>barries@slaysys.comE<gt>
  
  =cut
  
  1;
IPC_RUN3_PROFLOGGER

$fatpacked{"IPC/Run3/ProfPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'IPC_RUN3_PROFPP';
  package IPC::Run3::ProfPP;
  
  $VERSION = 0.048;
  
  =head1 NAME
  
  IPC::Run3::ProfPP - Generate reports from IPC::Run3 profiling data
  
  =head1 SYNOPSIS
  
  =head1 DESCRIPTION
  
  Used by IPC::Run3 and/or run3profpp to print out profiling reports for
  human readers.  Use other classes for extracting data in other ways.
  
  The output methods are plain text, override these (see the source for
  now) to provide other formats.
  
  This class generates reports on each run3_exit() and app_exit() call.
  
  =cut
  
  require IPC::Run3::ProfReporter;
  @ISA = qw( IPC::Run3::ProfReporter );
  
  use strict;
  use POSIX qw( floor );
  
  =head1 METHODS
  
  =head2 C<< IPC::Run3::ProfPP->new() >>
  
  Returns a new profile reporting object.
  
  =cut
  
  sub _emit { shift; warn @_ }
  
  sub _t {
      sprintf "%10.6f secs", @_;
  }
  
  sub _r {
      my ( $num, $denom ) = @_;
      return () unless $denom;
      sprintf "%10.6f", $num / $denom;
  }
  
  sub _pct {
      my ( $num, $denom ) = @_;
      return () unless $denom;
      sprintf  " (%3d%%)", floor( 100 * $num / $denom + 0.5 );
  }
  
  =head2 C<< $profpp->handle_app_call() >>
  
  =cut
  
  sub handle_app_call {
      my $self = shift;
      $self->_emit("IPC::Run3 parent: ",
          join( " ", @{$self->get_app_cmd} ),
          "\n",
      );
  
      $self->{NeedNL} = 1;
  }
  
  =head2 C<< $profpp->handle_app_exit() >>
  
  =cut
  
  sub handle_app_exit {
      my $self = shift;
  
      $self->_emit("\n") if $self->{NeedNL} && $self->{NeedNL} != 1;
  
      $self->_emit( "IPC::Run3 total elapsed:             ",
          _t( $self->get_app_cumulative_time ),
          "\n");
      $self->_emit( "IPC::Run3 calls to run3():    ",
          sprintf( "%10d", $self->get_run_count ),
          "\n");
      $self->_emit( "IPC::Run3 total spent in run3():     ",
          _t( $self->get_run_cumulative_time ),
          _pct( $self->get_run_cumulative_time, $self->get_app_cumulative_time ),
          ", ",
          _r( $self->get_run_cumulative_time, $self->get_run_count ),
          " per call",
          "\n");
      my $exclusive = 
          $self->get_app_cumulative_time - $self->get_run_cumulative_time;
      $self->_emit( "IPC::Run3 total spent not in run3(): ",
          _t( $exclusive ),
          _pct( $exclusive, $self->get_app_cumulative_time ),
          "\n");
      $self->_emit( "IPC::Run3 total spent in children:   ",
          _t( $self->get_sys_cumulative_time ),
          _pct( $self->get_sys_cumulative_time, $self->get_app_cumulative_time ),
          ", ",
          _r( $self->get_sys_cumulative_time, $self->get_run_count ),
          " per call",
          "\n");
      my $overhead =
          $self->get_run_cumulative_time - $self->get_sys_cumulative_time;
      $self->_emit( "IPC::Run3 total overhead:            ",
          _t( $overhead ),
          _pct(
              $overhead,
              $self->get_sys_cumulative_time
          ),
          ", ",
          _r( $overhead, $self->get_run_count ),
          " per call",
          "\n");
  }
  
  =head2 C<< $profpp->handle_run_exit() >>
  
  =cut
  
  sub handle_run_exit {
      my $self = shift;
      my $overhead = $self->get_run_time - $self->get_sys_time;
  
      $self->_emit("\n") if $self->{NeedNL} && $self->{NeedNL} != 2;
      $self->{NeedNL} = 3;
  
      $self->_emit( "IPC::Run3 child: ",
          join( " ", @{$self->get_run_cmd} ),
          "\n");
      $self->_emit( "IPC::Run3 run3()  : ", _t( $self->get_run_time ), "\n",
           "IPC::Run3 child   : ", _t( $self->get_sys_time ), "\n",
           "IPC::Run3 overhead: ", _t( $overhead ),
               _pct( $overhead, $self->get_sys_time ),
               "\n");
  }
  
  =head1 LIMITATIONS
  
  =head1 COPYRIGHT
  
      Copyright 2003, R. Barrie Slaymaker, Jr., All Rights Reserved
  
  =head1 LICENSE
  
  You may use this module under the terms of the BSD, Artistic, or GPL licenses,
  any version.
  
  =head1 AUTHOR
  
  Barrie Slaymaker E<lt>barries@slaysys.comE<gt>
  
  =cut
  
  1;
IPC_RUN3_PROFPP

$fatpacked{"IPC/Run3/ProfReporter.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'IPC_RUN3_PROFREPORTER';
  package IPC::Run3::ProfReporter;
  
  $VERSION = 0.048;
  
  =head1 NAME
  
  IPC::Run3::ProfReporter - base class for handling profiling data
  
  =head1 SYNOPSIS
  
  =head1 DESCRIPTION
  
  See L<IPC::Run3::ProfPP|IPC::Run3::ProfPP> and for an example subclass.
  
  This class just notes and accumulates times; subclasses use methods like
  "handle_app_call", "handle_run_exit" and "handle_app_exit" to emit reports on
  it.  The default methods for these handlers are noops.
  
  If run from the command line, a reporter will be created and run on
  each logfile given as a command line parameter or on run3.out if none
  are given.
  
  This allows reports to be run like:
  
      perl -MIPC::Run3::ProfPP -e1
      perl -MIPC::Run3::ProfPP -e1 foo.out bar.out
  
  Use "-" to read from STDIN (the log file format is meant to be moderately
  greppable):
  
      grep "^cvs " run3.out perl -MIPC::Run3::ProfPP -e1 -
  
  Use --app to show only application level statistics (ie don't emit
  a report section for each command run).
  
  =cut
  
  use strict;
  
  my $loaded_by;
  
  sub import {
      $loaded_by = shift;
  }
  
  END {
      my @caller;
      for ( my $i = 0;; ++$i ) {
          my @c = caller $i;
          last unless @c;
          @caller = @c;
      }
  
      if ( $caller[0] eq "main"
          && $caller[1] eq "-e"
      ) {
          require IPC::Run3::ProfLogReader;
          require Getopt::Long;
          my ( $app, $run );
  
          Getopt::Long::GetOptions(
              "app" => \$app,
              "run" => \$run,
          );
  
          $app = 1, $run = 1 unless $app || $run;
  
          for ( @ARGV ? @ARGV : "" ) {
              my $r = IPC::Run3::ProfLogReader->new(
                  Source  => $_,
                  Handler => $loaded_by->new(
                      Source => $_,
                      app_report => $app,
                      run_report => $run,
                  ),
              );
              $r->read_all;
          }
      }
  }
  
  =head1 METHODS
  
  =over
  
  =item C<< IPC::Run3::ProfReporter->new >>
  
  Returns a new profile reporting object.
  
  =cut
  
  sub new {
      my $class = ref $_[0] ? ref shift : shift;
      my $self = bless { @_ }, $class;
      $self->{app_report} = 1, $self->{run_report} = 1
          unless $self->{app_report} || $self->{run_report};
  
      return $self;
  }
  
  =item C<< $reporter->handle_app_call( ... ) >>
  
  =item C<< $reporter->handle_app_exit( ... ) >>
  
  =item C<< $reporter->handle_run_exit( ... ) >>
  
  These methods are called by the handled events (see below).
  
  =cut
  
  sub handle_app_call {}
  sub handle_app_exit {}
  
  sub handle_run_exit {}
  
  =item C<< $reporter->app_call(\@cmd, $time) >>
  
  =item C<< $reporter->app_exit($time) >>
  
  =item C<< $reporter->run_exit(@times) >>
  
     $self->app_call( $time );
     my $time = $self->get_app_call_time;
  
  Sets the time (in floating point seconds) when the application, run3(),
  or system() was called or exited.  If no time parameter is passed, uses
  IPC::Run3's time routine.
  
  Use get_...() to retrieve these values (and _accum values, too).  This
  is a separate method to speed the execution time of the setters just a
  bit.
  
  =cut
  
  sub app_call {
      my $self = shift;
      ( $self->{app_cmd}, $self->{app_call_time} ) = @_;
      $self->handle_app_call if $self->{app_report};
  }
  
  sub app_exit {
      my $self = shift;
      $self->{app_exit_time} = shift;
      $self->handle_app_exit if $self->{app_report};
  }
  
  sub run_exit {
      my $self = shift;
      @{$self}{qw(
          run_cmd run_call_time sys_call_time sys_exit_time run_exit_time
      )} = @_;
  
      ++$self->{run_count};
      $self->{run_cumulative_time} += $self->get_run_time;
      $self->{sys_cumulative_time} += $self->get_sys_time;
      $self->handle_run_exit if $self->{run_report};
  }
  
  =item C<< $reporter->get_run_count() >>
  
  =item C<< $reporter->get_app_call_time() >>
  
  =item C<< $reporter->get_app_exit_time() >>
  
  =item C<< $reporter->get_app_cmd() >>
  
  =item C<< $reporter->get_app_time() >>
  
  =cut
  
  sub get_run_count     { shift->{run_count} }
  sub get_app_call_time { shift->{app_call_time} }
  sub get_app_exit_time { shift->{app_exit_time} }
  sub get_app_cmd       { shift->{app_cmd}       }
  sub get_app_time {
      my $self = shift;
      $self->get_app_exit_time - $self->get_app_call_time;
  }
  
  =item C<< $reporter->get_app_cumulative_time() >>
  
  =cut
  
  sub get_app_cumulative_time {
      my $self = shift;
      $self->get_app_exit_time - $self->get_app_call_time;
  }
  
  =item C<< $reporter->get_run_call_time() >>
  
  =item C<< $reporter->get_run_exit_time() >>
  
  =item C<< $reporter->get_run_time() >>
  
  =cut
  
  sub get_run_call_time { shift->{run_call_time} }
  sub get_run_exit_time { shift->{run_exit_time} }
  sub get_run_time {
      my $self = shift;
      $self->get_run_exit_time - $self->get_run_call_time;
  }
  
  =item C<< $reporter->get_run_cumulative_time() >>
  
  =cut
  
  sub get_run_cumulative_time { shift->{run_cumulative_time} }
  
  =item C<< $reporter->get_sys_call_time() >>
  
  =item C<< $reporter->get_sys_exit_time() >>
  
  =item C<< $reporter->get_sys_time() >>
  
  =cut
  
  sub get_sys_call_time { shift->{sys_call_time} }
  sub get_sys_exit_time { shift->{sys_exit_time} }
  sub get_sys_time {
      my $self = shift;
      $self->get_sys_exit_time - $self->get_sys_call_time;
  }
  
  =item C<< $reporter->get_sys_cumulative_time() >>
  
  =cut
  
  sub get_sys_cumulative_time { shift->{sys_cumulative_time} }
  
  =item C<< $reporter->get_run_cmd() >>
  
  =cut
  
  sub get_run_cmd { shift->{run_cmd} }
  
  =back
  
  =head1 LIMITATIONS
  
  =head1 COPYRIGHT
  
      Copyright 2003, R. Barrie Slaymaker, Jr., All Rights Reserved
  
  =head1 LICENSE
  
  You may use this module under the terms of the BSD, Artistic, or GPL licenses,
  any version.
  
  =head1 AUTHOR
  
  Barrie Slaymaker <barries@slaysys.com>
  
  =cut
  
  1;
IPC_RUN3_PROFREPORTER

$fatpacked{"Net/OpenSSH.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'NET_OPENSSH';
  package Net::OpenSSH;
  
  our $VERSION = '0.83';
  
  use strict;
  use warnings;
  
  our $debug ||= 0;
  our $debug_fh ||= \*STDERR;
  
  our $FACTORY;
  
  use Carp qw(carp croak);
  use POSIX qw(:sys_wait_h);
  use Socket;
  use File::Spec;
  use Cwd ();
  use Scalar::Util ();
  use Errno ();
  use Net::OpenSSH::Constants qw(:error :_state);
  use Net::OpenSSH::ModuleLoader;
  use Net::OpenSSH::ShellQuoter;
  use Digest::MD5;
  
  my $thread_generation = 0;
  
  sub CLONE { $thread_generation++ };
  
  sub _debug {
      local ($!, $@);
      print {$debug_fh} '# ', (map { defined($_) ? $_ : '<undef>' } @_), "\n"
  }
  
  sub _debug_dump {
      local ($!, $@);
      require Data::Dumper;
      local $Data::Dumper::Terse = 1;
      local $Data::Dumper::Indent = 0;
      my $head = shift;
      _debug("$head: ", Data::Dumper::Dumper(@_));
  }
  
  sub _hexdump {
      no warnings qw(uninitialized);
      my $data = shift;
      while ($data =~ /(.{1,32})/smg) {
          my $line=$1;
          my @c= (( map { sprintf "%02x",$_ } unpack('C*', $line)),
                  (("  ") x 32))[0..31];
          $line=~s/(.)/ my $c=$1; unpack("c",$c)>=32 ? $c : '.' /egms;
          print {$debug_fh} "#> ", join(" ", @c, '|', $line), "\n";
      }
  }
  
  {
      my %good;
  
      sub _sub_options {
          my $sub = shift;
          $good{__PACKAGE__ . "::$sub"} = { map { $_ => 1 } @_ };
      }
  
      sub _croak_bad_options (\%) {
          my $opts = shift;
          if (%$opts) {
  	    my $sub = (caller 1)[3];
              my $good = $good{$sub};
              my @keys = grep defined($opts->{$_}), ( $good ? grep !$good->{$_}, keys %$opts : keys %$opts);
              if (@keys) {
                  croak "Invalid or bad combination of options ('" . CORE::join("', '", @keys) . "')";
              }
          }
      }
  }
  
  sub _croak_scalar_context {
      my ($sub, $wantarray) = (caller 1)[3, 5];
      unless ($wantarray) {
          $sub =~ s/^.*:://;
          croak "method '$sub' called in scalar context";
      }
  }
  
  sub _tcroak {
      if (${^TAINT} > 0) {
  	push @_, " while running with -T switch";
          goto &croak;
      }
      if (${^TAINT} < 0) {
  	push @_, " while running with -t switch";
          goto &carp;
      }
  }
  
  sub _catch_tainted_args {
      my $i;
      for (@_) {
          next unless $i++;
          if (Scalar::Util::tainted($_)) {
              my (undef, undef, undef, $subn) = caller 1;
              my $msg = ( $subn =~ /::([a-z]\w*)$/
                          ? "Insecure argument '$_' on '$1' method call"
                          : "Insecure argument '$_' on method call" );
              _tcroak($msg);
          }
          elsif (ref($_) eq 'HASH') {
              for (grep Scalar::Util::tainted($_), values %$_) {
  		my (undef, undef, undef, $subn) = caller 1;
  		my $msg = ( $subn =~ /::([a-z]\w*)$/
  			    ? "Insecure argument on '$1' method call"
  			    : "Insecure argument on method call" );
  		_tcroak($msg);
              }
          }
      }
  }
  
  sub _set_error {
      my $self = shift;
      my $code = shift || 0;
      my @extra = grep defined, @_;
      my $err = $self->{_error} = ( $code
                                    ? Scalar::Util::dualvar($code, join(': ', @{$self->{_error_prefix}},
                                                                        (@extra ? @extra : "Unknown error $code")))
                                    : 0 );
      $debug and $debug & 1 and _debug "set_error($code - $err)";
      return $err
  }
  
  my $check_eval_re = do {
      my $path = quotemeta $INC{"Net/OpenSSH.pm"};
      qr/at $path line \d+.$/
  };
  
  sub _check_eval_ok {
      my ($self, $code) = @_;
      if ($@) {
          my $err = $@;
          $err =~ s/$check_eval_re//;
          $self->_set_error($code, $err);
          return;
      }
      1
  }
  
  sub _or_set_error {
      my $self = shift;
      $self->{_error} or $self->_set_error(@_);
  }
  
  sub _first_defined { defined && return $_ for @_; return }
  
  my $obfuscate = sub {
      # just for the casual observer...
      my $txt = shift;
      $txt =~ s/(.)/chr(ord($1) ^ 47)/ges
          if defined $txt;
      $txt;
  };
  
  my $deobfuscate = $obfuscate;
  
  # regexp from Regexp::IPv6
  my $IPv6_re = qr((?-xism::(?::[0-9a-fA-F]{1,4}){0,5}(?:(?::[0-9a-fA-F]{1,4}){1,2}|:(?:(?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})))|[0-9a-fA-F]{1,4}:(?:[0-9a-fA-F]{1,4}:(?:[0-9a-fA-F]{1,4}:(?:[0-9a-fA-F]{1,4}:(?:[0-9a-fA-F]{1,4}:(?:[0-9a-fA-F]{1,4}:(?:[0-9a-fA-F]{1,4}:(?:[0-9a-fA-F]{1,4}|:)|(?::(?:[0-9a-fA-F]{1,4})?|(?:(?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2}))))|:(?:(?:(?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2}))|[0-9a-fA-F]{1,4}(?::[0-9a-fA-F]{1,4})?|))|(?::(?:(?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2}))|:[0-9a-fA-F]{1,4}(?::(?:(?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2}))|(?::[0-9a-fA-F]{1,4}){0,2})|:))|(?:(?::[0-9a-fA-F]{1,4}){0,2}(?::(?:(?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2}))|(?::[0-9a-fA-F]{1,4}){1,2})|:))|(?:(?::[0-9a-fA-F]{1,4}){0,3}(?::(?:(?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2}))|(?::[0-9a-fA-F]{1,4}){1,2})|:))|(?:(?::[0-9a-fA-F]{1,4}){0,4}(?::(?:(?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2}))|(?::[0-9a-fA-F]{1,4}){1,2})|:))));
  
  sub parse_connection_opts {
      my ($class, $opts) = @_;
      my ($user, $passwd, $ipv6, $host, $port, $host_squared);
  
      my $target = delete $opts->{host};
      defined $target or croak "mandatory host argument missing";
  
      ($user, $passwd, $ipv6, $host, $port) =
          $target =~ m{^
                         \s*               # space
                         (?:
                           ([^:]+)         # username
                           (?::(.*))?      # : password
                           \@              # @
                         )?
                         (?:               # host
                            (              #   IPv6...
                              \[$IPv6_re(?:\%[^\[\]]*)\] #     [IPv6]
                              |            #     or
                              $IPv6_re     #     IPv6
                            )
                            |              #   or
                            ([^\[\]\@:]+)  #   hostname / ipv4
                         )
                         (?::([^\@:]+))?   # port
                         \s*               # space
                       $}ix
                  or croak "bad host/target '$target' specification";
  
      if (defined $ipv6) {
          ($host) = $ipv6 =~ /^\[?(.*?)\]?$/;
          $host_squared = "[$host]";
      }
      else {
          $host_squared = $host;
      }
  
      $user = delete $opts->{user} unless defined $user;
      $port = delete $opts->{port} unless defined $port;
      $passwd = delete $opts->{passwd} unless defined $passwd;
      $passwd = delete $opts->{password} unless defined $passwd;
  
      wantarray and return ($host, $port, $user, $passwd, $host_squared);
  
      my %r = ( user => $user,
                password => $passwd,
                host => $host,
                host_squared => $host_squared,
                port => $port );
      $r{ipv6} = 1 if defined $ipv6;
      return \%r;
  }
  
  my $sizeof_sun_path = ($^O eq 'linux' ? 108 :
                         $^O =~ /bsd/i  ? 104 :
                         $^O eq 'hpux'  ? 92  : undef);
  
  sub new {
      ${^TAINT} and &_catch_tainted_args;
  
      my $class = shift;
      @_ & 1 and unshift @_, 'host';
  
      return $FACTORY->($class, @_) if defined $FACTORY;
  
      my %opts = @_;
  
      my $external_master = delete $opts{external_master};
      # reuse_master is an obsolete alias:
      $external_master = delete $opts{reuse_master} unless defined $external_master;
  
      if (not defined $opts{host} and defined $external_master) {
          $opts{host} = '0.0.0.0';
      }
  
      my ($host, $port, $user, $passwd, $host_squared) = $class->parse_connection_opts(\%opts);
  
      my ($passphrase, $key_path, $login_handler);
      unless (defined $passwd) {
          $key_path = delete $opts{key_path};
          $passwd = delete $opts{passphrase};
          if (defined $passwd) {
              $passphrase = 1;
          }
          else {
              $login_handler = delete $opts{login_handler};
          }
      }
  
      my $ssh_version = delete $opts{ssh_version};
      my $batch_mode = delete $opts{batch_mode};
      my $ctl_path = delete $opts{ctl_path};
      my $ctl_dir = delete $opts{ctl_dir};
      my $proxy_command = delete $opts{proxy_command};
      my $gateway = delete $opts{gateway} unless defined $proxy_command;
      my $ssh_cmd = _first_defined delete $opts{ssh_cmd}, 'ssh';
      my $rsync_cmd = _first_defined delete $opts{rsync_cmd}, 'rsync';
      my $scp_cmd = delete $opts{scp_cmd};
      my $sshfs_cmd = _first_defined delete $opts{sshfs_cmd}, 'sshfs';
      my $sftp_server_cmd = _first_defined delete $opts{sftp_server_cmd},
                                           '/usr/lib/openssh/sftp-server';
      my $timeout = delete $opts{timeout};
      my $kill_ssh_on_timeout = delete $opts{kill_ssh_on_timeout};
      my $strict_mode = _first_defined delete $opts{strict_mode}, 1;
      my $connect = _first_defined delete $opts{connect}, 1;
      my $async = delete $opts{async};
      my $remote_shell = _first_defined delete $opts{remote_shell}, 'POSIX';
      my $expand_vars = delete $opts{expand_vars};
      my $vars = _first_defined delete $opts{vars}, {};
      my $default_encoding = delete $opts{default_encoding};
      my $default_stream_encoding =
          _first_defined delete $opts{default_stream_encoding}, $default_encoding;
      my $default_argument_encoding =
          _first_defined delete $opts{default_argument_encoding}, $default_encoding;
      my $forward_agent = delete $opts{forward_agent};
      $forward_agent and $passphrase and
          croak "agent forwarding can not be used when a passphrase has also been given";
      my $forward_X11 = delete $opts{forward_X11};
      my $passwd_prompt = delete $opts{password_prompt};
      my $master_pty_force = delete $opts{master_pty_force};
      $passwd_prompt = delete $opts{passwd_prompt} unless defined $passwd_prompt;
  
      my ($master_opts, @master_opts,
          $master_stdout_fh, $master_stderr_fh,
  	$master_stdout_discard, $master_stderr_discard,
          $master_setpgrp);
      unless ($external_master) {
          ($master_stdout_fh = delete $opts{master_stdout_fh} or
           $master_stdout_discard = delete $opts{master_stdout_discard});
  
          ($master_stderr_fh = delete $opts{master_stderr_fh} or
           $master_stderr_discard = delete $opts{master_stderr_discard});
  
          $master_opts = delete $opts{master_opts};
          if (defined $master_opts) {
              if (ref $master_opts) {
                  @master_opts = @$master_opts;
              }
              else {
                  carp "'master_opts' argument looks like if it should be splited first"
                      if $master_opts =~ /^-\w\s+\S/;
                  @master_opts = $master_opts;
              }
          }
          $master_setpgrp = delete $opts{master_setpgrp};
  
          # when a password/passphrase is given, calling setpgrp is
          # useless because the process runs attached to a different tty
          undef $master_setpgrp if $login_handler or defined $passwd;
      }
  
      my $default_ssh_opts = delete $opts{default_ssh_opts};
      carp "'default_ssh_opts' argument looks like if it should be splited first"
          if defined $default_ssh_opts and not ref $default_ssh_opts and $default_ssh_opts =~ /^-\w\s+\S/;
  
      my ($default_stdout_fh, $default_stderr_fh, $default_stdin_fh,
  	$default_stdout_file, $default_stderr_file, $default_stdin_file,
  	$default_stdout_discard, $default_stderr_discard, $default_stdin_discard);
  
      $default_stdout_file = (delete $opts{default_stdout_discard}
  			    ? '/dev/null'
  			    : delete $opts{default_stdout_file});
      $default_stdout_fh = delete $opts{default_stdout_fh}
  	unless defined $default_stdout_file;
  
      $default_stderr_file = (delete $opts{default_stderr_discard}
  			    ? '/dev/null'
  			    : delete $opts{default_stderr_file});
      $default_stderr_fh = delete $opts{default_stderr_fh}
  	unless defined $default_stderr_file;
  
      $default_stdin_file = (delete $opts{default_stdin_discard}
  			    ? '/dev/null'
  			    : delete $opts{default_stdin_file});
      $default_stdin_fh = delete $opts{default_stdin_fh}
  	unless defined $default_stdin_file;
  
      _croak_bad_options %opts;
  
      my @ssh_opts;
      # TODO: are those options really requiered or just do they eat on
      # the command line limited length?
      push @ssh_opts, -l => $user if defined $user;
      push @ssh_opts, -p => $port if defined $port;
  
      my $home = do {
  	local ($@, $SIG{__DIE__});
  	eval { Cwd::realpath((getpwuid $>)[7]) }
      };
  
      if (${^TAINT}) {
  	($home) = $home =~ /^(.*)$/;
  	Scalar::Util::tainted($ENV{PATH}) and
  		_tcroak('Insecure $ENV{PATH}');
      }
  
      my $self = { _error => 0,
  		 _error_prefix => [],
  		 _perl_pid => $$,
                   _thread_generation => $thread_generation,
                   _ssh_version => $ssh_version,
                   _ssh_cmd => $ssh_cmd,
  		 _scp_cmd => $scp_cmd,
  		 _rsync_cmd => $rsync_cmd,
                   _sshfs_cmd => $sshfs_cmd,
                   _sftp_server_cmd => $sftp_server_cmd,
                   _pid => undef,
                   _host => $host,
  		 _host_squared => $host_squared,
                   _user => $user,
                   _port => $port,
                   _passwd => $obfuscate->($passwd),
                   _passwd_prompt => $passwd_prompt,
                   _passphrase => $passphrase,
                   _key_path => $key_path,
                   _login_handler => $login_handler,
                   _timeout => $timeout,
                   _proxy_command => $proxy_command,
                   _gateway_args => $gateway,
                   _kill_ssh_on_timeout => $kill_ssh_on_timeout,
                   _batch_mode => $batch_mode,
                   _home => $home,
                   _forward_agent => $forward_agent,
                   _forward_X11 => $forward_X11,
                   _external_master => $external_master,
                   _default_ssh_opts => $default_ssh_opts,
  		 _default_stdin_fh => $default_stdin_fh,
  		 _default_stdout_fh => $default_stdout_fh,
  		 _default_stderr_fh => $default_stderr_fh,
  		 _master_stdout_fh => $master_stdout_fh,
  		 _master_stderr_fh => $master_stderr_fh,
  		 _master_stdout_discard => $master_stdout_discard,
  		 _master_stderr_discard => $master_stderr_discard,
                   _master_setpgrp => $master_setpgrp,
                   _master_pty_force => $master_pty_force,
  		 _remote_shell => $remote_shell,
                   _default_stream_encoding => $default_stream_encoding,
                   _default_argument_encoding => $default_argument_encoding,
  		 _expand_vars => $expand_vars,
  		 _vars => $vars,
                   _master_state => _STATE_START,
                 };
      bless $self, $class;
  
      $self->_detect_ssh_version;
  
      # default file handles are opened so late in order to have the
      # $self object to report errors
      $self->{_default_stdout_fh} = $self->_open_file('>', $default_stdout_file)
  	if defined $default_stdout_file;
      $self->{_default_stderr_fh} = $self->_open_file('>', $default_stderr_file)
  	if defined $default_stderr_file;
      $self->{_default_stdin_fh} = $self->_open_file('<', $default_stdin_file)
  	if defined $default_stdin_file;
  
      if ($self->{_error} == OSSH_SLAVE_PIPE_FAILED) {
          $self->_master_fail($async, "Unable to create default slave stream", $self->{_error});
          return $self;
      }
  
      $self->{_ssh_opts} = [$self->_expand_vars(@ssh_opts)];
      $self->{_master_opts} = [$self->_expand_vars(@master_opts)];
  
      $ctl_path = $self->_expand_vars($ctl_path);
      $ctl_dir = $self->_expand_vars($ctl_dir);
  
      if  (defined $ctl_path) {
          if ($external_master) {
              unless (-S $ctl_path) {
                  $self->_master_fail($async, "ctl_path $ctl_path does not point to a socket");
                  return $self;
              }
          }
          else {
              if (-e $ctl_path) {
                  $self->_master_fail($async, "unable to use ctl_path $ctl_path, a file object already exists there");
                  return $self;
              }
          }
      }
      else {
          $external_master and croak "external_master is set but ctl_path is not defined";
  
          unless (defined $ctl_dir) {
              unless (defined $self->{_home}) {
                  $self->_master_fail($async, "unable to determine home directory for uid $>");
                  return $self;
              }
  
              $ctl_dir = File::Spec->catdir($self->{_home}, ".libnet-openssh-perl");
          }
  
          mkdir $ctl_dir, 0700;
          unless (-d $ctl_dir) {
              $self->_master_fail($async, "unable to create ctl_dir $ctl_dir");
              return $self;
          }
  
          my $target = join('-', grep defined, $user, $host, $port);
  
          for (1..10) {
              my $ctl_file = Digest::MD5::md5_hex(sprintf "%s-%d-%d-%d", $target, $$, time, rand 1e6);
              $ctl_path = File::Spec->join($ctl_dir, $ctl_file);
              last unless -e $ctl_path
          }
          if (-e $ctl_path) {
              $self->_master_fail($async, "unable to find unused name for ctl_path inside ctl_dir $ctl_dir");
              return $self;
          }
      }
  
      if (defined $sizeof_sun_path and length $ctl_path > $sizeof_sun_path) {
          $self->_master_fail($async, "ctl_path $ctl_path is too long (max permissible size for $^O is $sizeof_sun_path)");
          return $self;
      }
  
      $ctl_dir = File::Spec->catpath((File::Spec->splitpath($ctl_path))[0,1], "");
      $debug and $debug & 2 and _debug "ctl_path: $ctl_path, ctl_dir: $ctl_dir";
  
      if ($strict_mode and !$self->_is_secure_path($ctl_dir)) {
   	$self->_master_fail($async, "ctl_dir $ctl_dir is not secure");
   	return $self;
      }
  
      $self->{_ctl_path} = $ctl_path;
  
      $self->_master_wait($async) if $connect;
  
      $self;
  }
  
  sub get_user { shift->{_user} }
  sub get_host { shift->{_host} }
  sub get_port { shift->{_port} }
  sub get_master_pid { shift->{_pid} }
  sub get_ctl_path { shift->{_ctl_path} }
  sub get_expand_vars { shift->{_expand_vars} }
  
  sub get_master_pty_log { shift->{_master_pty_log} }
  
  sub set_expand_vars {
      my $self = shift;
      $self->{_expand_vars} = (shift(@_) ? 1 : 0);
  }
  
  sub set_var {
      ${^TAINT} and &_catch_tainted_args;
      my $self = shift;
      my $k = shift;
      $k =~ /^(?:USER|HOST|PORT)$/
  	and croak "internal variable %$k% can not be set";
      $self->{_vars}{$k} = shift;
  }
  
  sub get_var {
      my ($self, $k) = @_;
      my $v = ( $k =~ /^(?:USER|HOST|PORT)$/
  	      ? $self->{lc "_$k"}
  	      : $self->{_vars}{$k} );
      (defined $v ? $v : '');
  }
  
  sub _expand_vars {
      my ($self, @str) = @_;
      if (ref $self and $self->{_expand_vars}) {
  	for (@str) {
  	    s{%(\w*)%}{length ($1) ? $self->get_var($1) : '%'}ge
  		if defined $_;
  	}
      }
      wantarray ? @str : $str[0]
  }
  
  sub error { shift->{_error} }
  
  sub die_on_error {
      my $ssh = shift;
      $ssh->{_error} and croak(@_ ? "@_: $ssh->{_error}" : $ssh->{_error});
  }
  
  
  sub _is_secure_path {
      my ($self, $path) = @_;
      my @parts = File::Spec->splitdir(Cwd::realpath($path));
      my $home = $self->{_home};
      for my $last (reverse 0..$#parts) {
          my $dir = File::Spec->catdir(@parts[0..$last]);
          unless (-d $dir) {
              $debug and $debug & 2 and _debug "$dir is not a directory";
              return undef;
          }
          my ($mode, $uid) = (stat $dir)[2, 4];
          $debug and $debug & 2 and _debug "_is_secure_path(dir: $dir, file mode: $mode, file uid: $uid, euid: $>";
          return undef unless(($uid == $> or $uid == 0 ) and (($mode & 022) == 0 or ($mode & 01000)));
          return 1 if (defined $home and $home eq $dir);
      }
      return 1;
  }
  
  _sub_options _capture_local_ssh => qw(stderr_to_stdout stderr_discard stderr_fh stderr_file);
  
  sub _capture_local_ssh {
      my $self = shift;
      my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ());
      _croak_bad_options %opts;
      my (undef, $out, undef, $pid) = $self->open_ex({ %opts,
                                                       _cmd => 'raw',
                                                       _no_master_required => 1,
                                                       stdout_pipe => 1,
                                                       stdin_discard => 1 },
                                                     $self->{_ssh_cmd}, @_);
      my ($txt) = $self->_io3($out, undef, undef, undef, 10, 'bytes');
      local $self->{_kill_ssh_on_timeout} = 1;
      $self->_waitpid($pid, 10);
      return $txt
  }
  
  sub _detect_ssh_version {
      my $self = shift;
      if (defined $self->{_ssh_version}) {
          $debug and $debug & 4 and _debug "ssh version given as $self->{_ssh_version}";
      }
      else {
          my $txt = $self->_capture_local_ssh({stderr_to_stdout => 1}, '-V');
          if (my ($full, $num) = $txt =~ /^OpenSSH_((\d+\.\d+)\S*)/mi) {
              $debug and $debug & 4 and _debug "OpenSSH version is $full";
              $self->{_ssh_version} = $num;
          }
          else {
              $self->{_ssh_version} = 0;
              $debug and $debug & 4 and _debug "unable to determine version, '$self->{_ssh_cmd} -V', output:\n$txt"
          }
      }
  }
  
  sub default_ssh_configuration {
      my $self = shift;
      $self->_capture_local_ssh('-qG', $self->{_host})
  }
  
  sub _make_ssh_call {
      my $self = shift;
      my @before = @{shift || []};
      my @args = ($self->{_ssh_cmd}, @before,
  		-S => $self->{_ctl_path},
                  @{$self->{_ssh_opts}}, $self->{_host},
                  '--',
                  (@_ ? "@_" : ()));
      $debug and $debug & 8 and _debug_dump 'call args' => \@args;
      @args;
  }
  
  sub _scp_cmd {
      my $self = shift;
      $self->{_scp_cmd} ||= do {
  	my $scp = $self->{_ssh_cmd};
  	$scp =~ s/ssh$/scp/i or croak "scp command name not set";
  	$scp;
      }
  }
  
  sub _make_scp_call {
      my $self = shift;
      my @before = @{shift || []};
      my @args = ($self->_scp_cmd, @before,
  		-o => "ControlPath=$self->{_ctl_path}",
                  -S => $self->{_ssh_cmd},
                  (defined $self->{_port} ? (-P => $self->{_port}) : ()),
                  '--', @_);
  
      $debug and $debug & 8 and _debug_dump 'scp call args' => \@args;
      @args;
  }
  
  sub _rsync_quote {
      my ($self, @args) = @_;
      for (@args) {
  	if (/['"\s]/) {
  	    s/"/""/g;
  	    $_ = qq|"$_"|;
  	}
  	s/%/%%/;
      }
      wantarray ? @args : join(' ', @args);
  }
  
  sub _make_rsync_call {
      my $self = shift;
      my $before = shift;
      my @transport = ($self->{_ssh_cmd}, @$before,
                      -S => $self->{_ctl_path});
      my $transport = $self->_rsync_quote(@transport);
      my @args = ( $self->{_rsync_cmd},
  		 -e => $transport,
  		 @_);
  
      $debug and $debug & 8 and _debug_dump 'rsync call args' => \@args;
      @args;
  }
  
  sub _make_W_option {
      my $self = shift;
      if (@_ == 1) {
          my $path = shift;
          $path = "./$path" unless $path =~ m|/|;
          $path =~ s/([\\:])/\\$1/g;
          return "-W$path";
      }
      if (@_ == 2) {
          return "-W" . join(':', @_);
      }
      croak "bad number of arguments for creating a tunnel"
  }
  
  sub _make_tunnel_call {
      my $self = shift;
      my @before = @{shift||[]};
      push @before, $self->_make_W_option(@_);
      my @args = $self->_make_ssh_call(\@before);
      $debug and $debug & 8 and _debug_dump 'tunnel call args' => \@args;
      @args;
  }
  
  sub master_exited {
      my $self = shift;
      $self->_master_gone(1)
  }
  
  sub _master_gone {
      my $self = shift;
      my $async = shift;
      delete $self->{_pid};
      $self->_master_fail($async, (@_ ? @_ : "master process exited unexpectedly"));
  }
  
  my @kill_signal = qw(0 0 TERM TERM TERM KILL);
  
  sub __has_sigchld_handle {
      my $h = $SIG{CHLD};
      defined $h and $h ne 'IGNORE' and $h ne 'DEFAULT'
  }
  
  sub _master_kill {
      my ($self, $async) = @_;
  
      if (my $pid = $self->_my_master_pid) {
          $debug and $debug & 32 and _debug '_master_kill: ', $pid;
  
          my $now = time;
          my $start = $self->{_master_kill_start} ||= $now;
          $self->{_master_kill_last} ||= $now;
          $self->{_master_kill_count} ||= 0;
  
          local $SIG{CHLD} = sub {} unless $async or __has_sigchld_handle;
          while (1) {
              if ($self->{_master_kill_last} < $now) {
                  $self->{_master_kill_last} = $now;
                  my $sig = $kill_signal[$self->{_master_kill_count}++];
                  $sig = 'KILL' unless defined $sig;
                  $debug and $debug & 32 and _debug "killing master $$ with signal $sig";
                  kill $sig, $pid;
              }
              my $deceased = waitpid($pid, WNOHANG);
              $debug and $debug & 32 and _debug "waitpid(master: $pid) => pid: $deceased, rc: $!";
              last if $deceased == $pid or ($deceased < 0 and $! == Errno::ECHILD());
              if ($self->{_master_kill_count} > 20) {
                  # FIXME: remove the hard-coded 20 retries?
                  $debug and $debug & 32 and _debug "unable to kill SSH master process, giving up";
                  last;
              }
              return if $async;
              select(undef, undef, undef, 0.2);
              $now = time;
          }
      }
      else {
          $debug and $debug & 32 and _debug("not killing master SSH (", $self->{_pid}, ") started from " .
                                            "process ", $self->{_perl_pid}, "/", $self->{_thread_generation},
                                            ", current ", $$, "/", $thread_generation, ")");
      }
      $self->_master_gone($async);
  }
  
  sub disconnect {
      my ($self, $async) = @_;
      @_ <= 2 or croak 'Usage: $self->disconnect([$async])';
      $self->_disconnect($async, 1);
  }
  
  sub disown_master {
      my $self = shift;
      if (my $pid = $self->_my_master_pid) {
          if ($self->wait_for_master) {
              $self->{_external_master} = 1;
              return $pid;
          }
      }
      undef;
  }
  
  sub restart {
      my ($self, $async) = @_;
      $self->{_external_master} and croak "Can restart SSH connection when using external master";
  
      # user is responsible for calling us in STATE_GONE in async mode
      $self->_disconnect($async, 1) unless $async;
  
      if ($self->{_master_state} != _STATE_GONE) {
  	croak "restart method called in wrong state (terminate the connection first!)" if $async;
  	return $self->_master_fail($async, "Unable to restart SSH session from state $self->{_master_state}")
      }
  
      # These slots should be deleted when exiting the KILLING state but
      # I like keeping them around for throubleshoting purposes.
      delete $self->{_master_kill_start};
      delete $self->{_master_kill_last};
      delete $self->{_master_kill_count};
      $self->_master_jump_state(_STATE_START, $async);
  }
  
  sub _my_master_pid {
      my $self = shift;
      unless ($self->{_external_master}) {
          my $pid = $self->{_pid};
          return $pid if
              $pid and $self->{_perl_pid} == $$ and $self->{_thread_generation} == $thread_generation;
      }
      ()
  }
  
  sub _disconnect {
      my ($self, $async, $send_ctl) = @_;
      return if $self->{_master_state} == _STATE_GONE;
  
      if (!$async and
          $self->{_master_state} == _STATE_RUNNING and
          ($send_ctl or $self->_my_master_pid)) {
          # we have successfully created the master connection so we
          # can send control commands:
          $debug and $debug & 32 and _debug("sending exit control to master");
          $self->_master_ctl('exit');
      }
      $self->_master_fail($async, 'aborted')
  }
  
  sub _check_is_system_fh {
      my ($name, $fh) = @_;
      my $fn = fileno(defined $fh ? $fh : $name);
      defined $fn and $fn >= 0 and return;
      croak "child process $name is not a real system file handle";
  }
  
  sub _master_redirect {
      my $self = shift;
      my $uname = uc shift;
      my $name = lc $uname;
  
      no strict 'refs';
      if ($self->{"_master_${name}_discard"}) {
  	open *$uname, '>>', '/dev/null';
      }
      else {
  	my $fh = $self->{"_master_${name}_fh"};
  	$fh = $self->{"_default_${name}_fh"} unless defined $fh;
  	if (defined $fh) {
  	    _check_is_system_fh $uname => $fh;
  	    if (fileno $fh != fileno *$uname) {
  		open *$uname, '>>&', $fh or POSIX::_exit(255);
  	    }
  	}
      }
  }
  
  sub _waitpid {
      my ($self, $pid, $timeout) = @_;
      $? = 0;
      if ($pid) {
          $timeout = $self->{_timeout} unless defined $timeout;
  
          my $time_limit;
          if (defined $timeout and $self->{_kill_ssh_on_timeout}) {
              $timeout = 0 if $self->{_error} == OSSH_SLAVE_TIMEOUT;
              $time_limit = time + $timeout;
          }
          local $SIG{CHLD} = sub {} unless __has_sigchld_handle;
  	while (1) {
              my $deceased;
              if (defined $time_limit) {
                  while (1) {
                      # TODO: we assume that all OSs return 0 when the
                      # process is still running, that may be wrong!
                      $deceased = waitpid($pid, WNOHANG) and last;
                      my $remaining = $time_limit - time;
                      if ($remaining <= 0) {
                          $debug and $debug & 16 and _debug "killing SSH slave, pid: $pid";
                          kill TERM => $pid;
                          $self->_or_set_error(OSSH_SLAVE_TIMEOUT, "ssh slave failed", "timed out");
                      }
                      # There is a race condition here. We try to
                      # minimize it keeping the waitpid and the select
                      # together and limiting the sleep time to 1s:
                      my $sleep = ($remaining < 0.1 ? 0.1 : 1);
                      $debug and $debug & 16 and
                          _debug "waiting for slave, timeout: $timeout, remaining: $remaining, sleep: $sleep";
                      $deceased = waitpid($pid, WNOHANG) and last;
                      select(undef, undef, undef, $sleep);
                  }
              }
              else {
                  $deceased = waitpid($pid, 0);
              }
              $debug and $debug & 16 and _debug "_waitpid($pid) => pid: $deceased, rc: $?, err: $!";
  	    if ($deceased == $pid) {
  		if ($?) {
  		    my $signal = ($? & 255);
  		    my $errstr = "child exited with code " . ($? >> 8);
  		    $errstr .= ", signal $signal" if $signal;
  		    $self->_or_set_error(OSSH_SLAVE_CMD_FAILED, $errstr);
  		    return undef;
  		}
  		return 1;
  	    }
  	    elsif ($deceased < 0) {
  		# at this point $deceased < 0 and so, $! has a valid error value.
  		next if $! == Errno::EINTR();
  		if ($! == Errno::ECHILD()) {
  		    $self->_or_set_error(OSSH_SLAVE_FAILED, "child process $pid does not exist", $!);
  		    return undef
  		}
  		warn "Internal error: unexpected error (".($!+0).": $!) from waitpid($pid) = $deceased. Report it, please!";
  	    }
  	    elsif ($deceased > 0) {
  		warn "Internal error: spurious process $deceased exited"
  	    }
  
  	    # wait a bit before trying again
  	    select(undef, undef, undef, 0.1);
  	}
      }
      else {
  	$self->_or_set_error(OSSH_SLAVE_FAILED, "spawning of new process failed");
  	return undef;
      }
  }
  
  sub check_master {
      my $self = shift;
      @_ and croak 'Usage: $ssh->check_master()';
      $self->_master_check(0);
  }
  
  sub wait_for_master {
      my ($self, $async) = @_;
      @_ <= 2 or croak 'Usage: $ssh->wait_for_master([$async])';
      $self->{_error} = 0
          unless $self->{_error} == OSSH_MASTER_FAILED;
      $self->_master_wait($async);
  }
  
  sub _master_start {
      my ($self, $async) = @_;
      $self->_set_error;
  
      my $timeout = int((($self->{_timeout} || 90) + 2)/3);
      my $ssh_flags= '-2MN';
      $ssh_flags .= ($self->{_forward_agent} ? 'A' : 'a') if defined $self->{_forward_agent};
      $ssh_flags .= ($self->{_forward_X11} ? 'X' : 'x');
      my @master_opts = (@{$self->{_master_opts}},
                         -o => "ServerAliveInterval=$timeout",
                         ($self->{_ssh_version} >= 5.6 ? (-o => "ControlPersist=no") : ()),
                        $ssh_flags);
  
      my ($mpty, $use_pty, $pref_auths);
      $use_pty = 1 if ( $self->{_master_pty_force} or
                        defined $self->{_login_handler} );
      if (defined $self->{_passwd}) {
          $use_pty = 1;
          $pref_auths = ($self->{_passphrase}
                         ? 'publickey'
                         : 'keyboard-interactive,password');
          push @master_opts, -o => 'NumberOfPasswordPrompts=1';
      }
      elsif ($self->{_batch_mode}) {
          push @master_opts, -o => 'BatchMode=yes';
      }
  
      if (defined $self->{_key_path}) {
          $pref_auths = 'publickey';
          push @master_opts, -i => $self->{_key_path};
      }
  
      my $proxy_command = $self->{_proxy_command};
  
      my $gateway;
      if (my $gateway_args = $self->{_gateway_args}) {
          if (ref $gateway_args eq 'HASH') {
              _load_module('Net::OpenSSH::Gateway');
              my $errors;
              unless ($gateway = Net::OpenSSH::Gateway->find_gateway(errors => $errors,
                                                                     host => $self->{_host}, port => $self->{_port},
                                                                     %$gateway_args)) {
                  return $self->_master_fail($async, 'Unable to build gateway object', join(', ', @$errors));
              }
          }
          else {
              $gateway = $gateway_args
          }
          $self->{_gateway} = $gateway;
          $gateway->before_ssh_connect or
              return $self->_master_fail($async, 'Gateway setup failed', join(', ', $gateway->errors));
          $proxy_command = $gateway->proxy_command;
      }
  
      if (defined $proxy_command) {
          push @master_opts, -o => "ProxyCommand=$proxy_command";
      }
  
      if ($use_pty) {
          _load_module('IO::Pty');
          $self->{_mpty} = $mpty = IO::Pty->new;
      }
  
      push @master_opts, -o => "PreferredAuthentications=$pref_auths"
          if defined $pref_auths;
  
      my @call = $self->_make_ssh_call(\@master_opts);
  
      my $pid = fork;
      unless ($pid) {
          defined $pid
              or return $self->_master_fail($async, "unable to fork ssh master: $!");
  
          if ($debug and $debug & 512) {
              require Net::OpenSSH::OSTracer;
              Net::OpenSSH::OSTracer->trace;
          }
  
          $mpty->make_slave_controlling_terminal if $mpty;
  
  	$self->_master_redirect('STDOUT');
  	$self->_master_redirect('STDERR');
  
          delete $ENV{SSH_ASKPASS} if defined $self->{_passwd};
          delete $ENV{SSH_AUTH_SOCK} if defined $self->{_passphrase};
  
          setpgrp if $self->{_master_setpgrp};
  
  	local $SIG{__DIE__};
          eval { exec @call };
          POSIX::_exit(255);
      }
      $self->{_pid} = $pid;
      1;
  }
  
  sub _master_check {
      my ($self, $async) = @_;
      my $error;
      if ($async) {
          if (-S $self->{_ctl_path}) {
              delete $self->{_master_pty_log};
              return 1
          }
          $error = "master SSH connection broken";
      }
      else {
          my $out = $self->_master_ctl('check');
          $error = $self->{_error};
          unless ($error) {
              my $pid = $self->{_pid};
              if ($out =~ /pid=(\d+)/) {
                  if (!$pid or $1 == $pid) {
                      delete $self->{_master_pty_log};
                      return 1;
                  }
                  $error = "bad ssh master at $self->{_ctl_path} socket owned by pid $1 (pid $pid expected)";
              }
              else {
                  $error = ($out =~ /illegal option/i
                            ? 'OpenSSH 4.1 or later required'
                            : 'unknown error');
              }
          }
      }
      $self->_master_fail($async, $error);
  }
  
  sub _master_fail {
      my $self = shift;
      my $async = shift;
      if ($self->{_error} != OSSH_MASTER_FAILED) {
          $self->_set_error(OSSH_MASTER_FAILED, @_);
      }
      $self->_master_jump_state($self->{_pid} ? _STATE_KILLING : _STATE_GONE, $async);
  }
  
  sub _master_jump_state {
      my ($self, $state, $async) = @_;
      $debug and $debug & 4 and _debug "master state jumping from $self->{_master_state} to $state";
      if ($state == $self->{_master_state} and
          $state != _STATE_KILLING and
          $state != _STATE_GONE) {
          croak "internal error: state jump to itself ($state)!";
      }
      $self->{_master_state} = $state;
      return $self->_master_wait($async);
  }
  
  sub _master_wait {
      my ($self, $async) = @_;
  
      my $pid = $self->_my_master_pid;
      if ($pid) {
  	my $deceased = waitpid($pid, WNOHANG);
          if ($deceased == $pid or ($deceased < 0 and $! == Errno::ECHILD())) {
              $debug and $debug & 4 and _debug "master $pid exited, rc:", $?,", err: ",$!;
              return $self->_master_gone($async);
          }
      }
  
      if ($self->{_master_state} == _STATE_RUNNING) {
          return 1 if -S $self->{_ctl_path};
          return $self->_master_fail($async, "master SSH connection broken");
      }
  
      if ($self->{_master_state} == _STATE_KILLING) {
          $debug and $debug & 4 and _debug "killing master";
          return $self->_master_kill($async);
      }
  
      if ($self->{_master_state} == _STATE_START) {
          if ($self->{_external_master}) {
              return ($self->_master_jump_state(_STATE_RUNNING, $async) and
                      $self->_master_check($async))
          }
  
          $self->_master_start($async) or return;
          if ($self->{_mpty}) {
              $self->{_wfm_bout} = '';
              $self->{_master_pty_log} = '';
              if (defined $self->{_passwd} or $self->{_login_handler}) {
                  return $self->_master_jump_state(_STATE_LOGIN, $async);
              }
          }
          return $self->_master_jump_state(_STATE_AWAITING_MUX, $async);
      }
  
      if ($self->{_master_state} == _STATE_GONE) {
  	if (my $mpty = delete $self->{_mpty}) {
  	    close($mpty)
  	}
  	return 0;
      }
      if ($self->{_master_state} == _STATE_STOPPED) {
          return 0;
      }
  
      # At this point we are either in state AWAITIN_MUX or LOGIN
  
      local $self->{_error_prefix} = [@{$self->{_error_prefix}},
  				    "unable to establish master SSH connection"];
  
      $pid or return $self->_master_gone($async,
                                         "perl process was forked or threaded before SSH connection had been established");
  
      my $old_tcpgrp;
      if ($self->{_master_setpgrp} and not $async and
          not $self->{_batch_mode} and not $self->{_external_master}) {
          $old_tcpgrp = POSIX::tcgetpgrp(0);
          if ($old_tcpgrp > 0) {
              # let the master process ask for passwords at the TTY
              POSIX::tcsetpgrp(0, $pid);
          }
          else {
              undef $old_tcpgrp;
          }
      }
  
      my $mpty = $self->{_mpty};
      my $fnopty;
      my $rv = '';
      if ($mpty and 
          ( $self->{_master_state} == _STATE_LOGIN or
            $self->{_master_state} == _STATE_AWAITING_MUX )) {
          $fnopty = fileno $mpty;
          vec($rv, $fnopty, 1) = 1
      }
  
      my $timeout = $self->{_timeout};
      my $dt = ($async ? 0 : 0.02);
      my $start_time = time;
      my $error;
  
      # Loop until the mux socket appears or something goes wrong:
      while (1) {
          $dt *= 1.10 if $dt < 0.2; # adaptative delay
          if (-e $self->{_ctl_path}) {
              $debug and $debug & 4 and _debug "file object found at $self->{_ctl_path}";
              last;
          }
          $debug and $debug & 4 and _debug "file object not yet found at $self->{_ctl_path}, state:", $self->{_master_state};
  
          if (defined $timeout and (time - $start_time) > $timeout) {
              $error = "login timeout";
              last;
          }
  
  	my $deceased = waitpid($pid, WNOHANG);
          if ($deceased == $pid or ($deceased < 0 and $! == Errno::ECHILD())) {
              $error = "master process exited unexpectedly";
              $error = "bad pass" . ($self->{_passphrase} ? 'phrase' : 'word') . " or $error"
                  if defined $self->{_passwd};
              delete $self->{_pid};
              last;
          }
  
          if ($self->{_login_handler} and $self->{_master_state} == _STATE_LOGIN) {
              local ($@, $SIG{__DIE__});
              if (eval { $self->{_login_handler}->($self, $mpty, \$self->{_wfm_bout}) }) {
                  $self->{_master_state} = _STATE_AWAITING_MUX;
                  next;
              }
              if ($@) {
                  $error = "custom login handler failed: $@";
                  last;
              }
              # fallback
          }
          else {
              # we keep reading from mpty even after leaving state
              # STATE_LOGIN in order to search for additional password
              # prompts.
              my $rv1 = $rv;
              my $n = select($rv1, undef, undef, $dt);
              if ($n > 0) {
                  vec($rv1, $fnopty, 1) or die "internal error";
                  my $read = sysread($mpty, $self->{_wfm_bout}, 4096, length $self->{_wfm_bout});
                  if ($read) {
                      $self->{_master_pty_log} .= substr($self->{_wfm_bout}, -$read);
                      if ((my $remove = length($self->{_master_pty_log}) - 4096) > 0) {
                          substr($self->{_master_pty_log}, 0, $remove) = ''
                      }
  
                      if ($self->{_wfm_bout} =~ /The authenticity of host.*can't be established/si) {
                          $error = "the authenticity of the target host can't be established; the remote host " .
                              "public key is probably not present in the '~/.ssh/known_hosts' file";
                          last;
                      }
  
                      if ($self->{_wfm_bout} =~ /WARNING: REMOTE HOST IDENTIFICATION HAS CHANGED/si) {
                          $error = "the authenticity of the target host can't be established; the remote host " .
                              "public key doesn't match the one stored locally";
                          last;
                      }
  
                      my $passwd_prompt = _first_defined $self->{_passwd_prompt}, qr/[:?]/;
                      $passwd_prompt = quotemeta $passwd_prompt unless ref $passwd_prompt;
  
                      if ($self->{_master_state} == _STATE_LOGIN) {
                          if ($self->{_wfm_bout} =~ /^(.*$passwd_prompt)/s) {
                              $debug and $debug & 4 and _debug "passwd/passphrase requested ($1)";
                              print $mpty $deobfuscate->($self->{_passwd}) . "\n";
                              $self->{_wfm_bout} = ''; # reset
                              $self->{_master_state} = _STATE_AWAITING_MUX;
                          }
                      }
                      elsif (length($passwd_prompt) and $self->{_wfm_bout} =~ /^(.*$passwd_prompt)\s*$/s) {
                          $debug and $debug & 4 and _debug "passwd/passphrase requested again ($1)";
                          $error = "password authentication failed";
                          last;
                      }
                      next; # skip delay
                  }
              }
          }
          return if $async;
          select(undef, undef, undef, $dt);
      }
  
      if (defined $old_tcpgrp) {
          $debug and $debug & 4 and
              _debug("ssh pid: $pid, pgrp: ", getpgrp($pid),
                     ", \$\$: ", $$,
                     ", tcpgrp: ", POSIX::tcgetpgrp(0),
                     ", old_tcppgrp: ", $old_tcpgrp);
          local $SIG{TTOU} = 'IGNORE';
          POSIX::tcsetpgrp(0, $old_tcpgrp);
      }
  
      if ($error) {
          return $self->_master_fail($async, $error);
      }
  
      $self->_master_jump_state(_STATE_RUNNING, $async)
          and $self->_master_check($async);
  }
  
  sub _master_ctl {
      my $self = shift;
      my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ());
      my $cmd = shift;
  
      local $?;
      local $self->{_error_prefix} = [@{$self->{_error_prefix}},
                                      "control command failed"];
      $self->capture({ %opts,
                       encoding => 'bytes', # don't let the encoding
  					  # stuff get in the way
  		     stdin_discard => 1, tty => 0,
                       stderr_to_stdout => 1, ssh_opts => [-O => $cmd]});
  }
  
  sub stop {
      my ($self, $timeout) = @_;
      my $pid = $self->{_pid};
      local $self->{_kill_ssh_on_timeout} = 1;
      $self->_master_ctl({timeout => $timeout}, 'stop');
      unless ($self->{_error}) {
          $self->_set_error(OSSH_MASTER_FAILED, "master stopped");
          $self->_master_jump_state(_STATE_STOPPED, 1);
      }
  }
  
  sub _make_pipe {
      my $self = shift;
      my ($r, $w);
      if (pipe $r, $w) {
          my $old = select;
          select $r; $ |= 1;
          select $w; $ |= 1;
          select $old;
          return ($r, $w);
      }
      $self->_set_error(OSSH_SLAVE_PIPE_FAILED, "unable to create pipe: $!");
      return;
  }
  
  sub _remote_quoter {
      my ($self, $remote_shell) = @_;
      if (ref $self and (!defined $remote_shell or $remote_shell eq $self->{_remote_shell})) {
          return $self->{remote_quoter} ||= Net::OpenSSH::ShellQuoter->quoter($self->{_remote_shell});
      }
      Net::OpenSSH::ShellQuoter->quoter($remote_shell);
  }
  
  sub _quote_args {
      my $self = shift;
      my $opts = shift;
      ref $opts eq 'HASH' or die "internal error";
      my $quote = delete $opts->{quote_args};
      my $quote_extended = delete $opts->{quote_args_extended};
      my $glob_quoting = delete $opts->{glob_quoting};
      $quote = (@_ > 1) unless defined $quote;
  
      if ($quote) {
          my $remote_shell = delete $opts->{remote_shell};
          my $quoter = $self->_remote_quoter($remote_shell);
          my $quote_method = ($glob_quoting ? 'quote_glob' : 'quote');
  	# foo   => $quoter
  	# \foo  => $quoter_glob
  	# \\foo => no quoting at all and disable extended quoting as it is not safe
  	my @quoted;
  	for (@_) {
  	    if (ref $_) {
  		if (ref $_ eq 'SCALAR') {
  		    push @quoted, $quoter->quote_glob($self->_expand_vars($$_));
  		}
  		elsif (ref $_ eq 'REF' and ref $$_ eq 'SCALAR') {
  		    push @quoted, $self->_expand_vars($$$_);
  		    undef $quote_extended;
  		}
  		else {
  		    croak "invalid reference in remote command argument list"
  		}
  	    }
  	    else {
  		push @quoted, $quoter->$quote_method($self->_expand_vars($_));
  	    }
  	}
  
  	if ($quote_extended) {
              my @fragments;
              if ( $opts->{stdout_discard} and
                   ( $opts->{stderr_discard} or $opts->{stderr_to_stdout} ) ) {
                  @fragments = ('stdout_and_stderr_discard');
                  push @fragments, 'stdin_discard' if $opts->{stdin_discard};
              }
              else {
                  @fragments = grep $opts->{$_}, qw(stdin_discard stdout_discard
                                                    stderr_discard stderr_to_stdout);
              }
              push @quoted, $quoter->shell_fragments(@fragments);
  	}
  	wantarray ? @quoted : join(" ", @quoted);
      }
      else {
  	croak "reference found in argument list when argument quoting is disabled"
  	    if (grep ref, @_);
  
  	my @args = $self->_expand_vars(@_);
  	wantarray ? @args : join(" ", @args);
      }
  }
  
  sub shell_quote {
      shift->_quote_args({quote_args => 1}, @_);
  }
  
  sub shell_quote_glob {
      shift->_quote_args({quote_args => 1, glob_quoting => 1}, @_);
  }
  
  sub _array_or_scalar_to_list { map { defined($_) ? (ref $_ eq 'ARRAY' ? @$_ : $_ ) : () } @_ }
  
  sub make_remote_command {
      my $self = shift;
      $self->wait_for_master or return;
      my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ());
      my @ssh_opts = _array_or_scalar_to_list delete $opts{ssh_opts};
      my $tty = delete $opts{tty};
      my $ssh_flags = '';
      $ssh_flags .= ($tty ? 'qtt' : 'T') if defined $tty;
      if ($self->{_forward_agent}) {
  	my $forward_always = (($self->{_forward_agent} eq 'always') ? 1 : undef);
          my $forward_agent = _first_defined(delete($opts{forward_agent}), $forward_always);
          $ssh_flags .= ($forward_agent ? 'A' : 'a') if defined $forward_agent;
      }
      if ($self->{_forward_X11}) {
          my $forward_X11 = delete $opts{forward_X11};
          $ssh_flags .= ($forward_X11 ? 'X' : 'x');
      }
      my $tunnel = delete $opts{tunnel};
      my (@args);
      if ($tunnel) {
          push @ssh_opts, $self->_make_W_option(@_);
      }
      else {
          my $subsystem = delete $opts{subsystem};
          if ($subsystem) {
              push @ssh_opts, '-s';
              @_ == 1 or croak "wrong number of arguments for subsystem command";
          }
          @args = $self->_quote_args(\%opts, @_);
      }
      _croak_bad_options %opts;
  
      push @ssh_opts, "-$ssh_flags" if length $ssh_flags;
      my @call = $self->_make_ssh_call(\@ssh_opts, @args);
      if (wantarray) {
  	$debug and $debug & 16 and _debug_dump make_remote_command => \@call;
  	return @call;
      }
      else {
  	my $call = join ' ', $self->shell_quote(@call);
  	$debug and $debug & 16 and _debug_dump 'make_remote_command (quoted)' => $call;
  	return $call
      }
  }
  
  sub _open_file {
      my ($self, $default_mode, $name_or_args) = @_;
      my ($mode, @args) = (ref $name_or_args
  			 ? @$name_or_args
  			 : ($default_mode, $name_or_args));
      @args = $self->_expand_vars(@args);
      if (open my $fh, $mode, @args) {
  	return $fh;
      }
      else {
  	$self->_set_error(OSSH_SLAVE_PIPE_FAILED,
  			  "Unable to open file '$args[0]': $!");
  	return undef;
      }
  }
  
  sub _fileno_dup_over {
      my ($good_fn, $fh) = @_;
      if (defined $fh) {
          my $fn = fileno $fh;
          for (1..5) {
              $fn >= $good_fn and return $fn;
              $fn = POSIX::dup($fn);
          }
          POSIX::_exit(255);
      }
      undef;
  }
  
  sub _exec_dpipe {
      my ($self, $cmd, $io, $err) = @_;
      my $io_fd  = _fileno_dup_over(3 => $io);
      my $err_fd = _fileno_dup_over(3 => $err);
      POSIX::dup2($io_fd, 0);
      POSIX::dup2($io_fd, 1);
      POSIX::dup2($err_fd, 2) if defined $err_fd;
      if (ref $cmd) {
          exec @$cmd;
      }
      else {
          exec $cmd;
      }
  }
  
  sub _delete_stream_encoding {
      my ($self, $opts) = @_;
      _first_defined(delete $opts->{stream_encoding},
                     $opts->{encoding},
                     $self->{_default_stream_encoding});
  }
  
  sub _delete_argument_encoding {
      my ($self, $opts) = @_;
      _first_defined(delete $opts->{argument_encoding},
                     delete $opts->{encoding},
                     $self->{_default_argument_encoding});
  }
  
  sub open_ex {
      ${^TAINT} and &_catch_tainted_args;
      my $self = shift;
      my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ());
      unless (delete $opts{_no_master_required}) {
          $self->wait_for_master or return;
      }
  
      my $ssh_flags = '';
      my $tunnel = delete $opts{tunnel};
      my ($cmd, $close_slave_pty, @args);
      if ($tunnel) {
  	@args = @_;
      }
      else {
          my $argument_encoding = $self->_delete_argument_encoding(\%opts);
  	my $tty = delete $opts{tty};
  	$ssh_flags .= ($tty ? 'qtt' : 'T') if defined $tty;
  
  	$cmd = delete $opts{_cmd} || 'ssh';
  	$opts{quote_args_extended} = 1
  	    if (not defined $opts{quote_args_extended} and $cmd eq 'ssh');
          @args = $self->_quote_args(\%opts, @_);
          $self->_encode_args($argument_encoding, @args) or return;
      }
  
      my ($stdinout_socket, $stdinout_dpipe_make_parent);
      my $stdinout_dpipe = delete $opts{stdinout_dpipe};
      if ($stdinout_dpipe) {
          $stdinout_dpipe_make_parent = delete $opts{stdinout_dpipe_make_parent};
          $stdinout_socket = 1;
      }
      else {
          $stdinout_socket = delete $opts{stdinout_socket};
      }
  
      my ($stdin_discard, $stdin_pipe, $stdin_fh, $stdin_file, $stdin_pty,
          $stdout_discard, $stdout_pipe, $stdout_fh, $stdout_file, $stdout_pty,
          $stderr_discard, $stderr_pipe, $stderr_fh, $stderr_file, $stderr_to_stdout);
      unless ($stdinout_socket) {
          unless ($stdin_discard = delete $opts{stdin_discard} or
                  $stdin_pipe = delete $opts{stdin_pipe} or
                  $stdin_fh = delete $opts{stdin_fh} or
                  $stdin_file = delete $opts{stdin_file}) {
              unless ($tunnel) {
                  if ($stdin_pty = delete $opts{stdin_pty}) {
                      $close_slave_pty = _first_defined delete $opts{close_slave_pty}, 1;
                  }
              }
          }
  
          ( $stdout_discard = delete $opts{stdout_discard} or
            $stdout_pipe = delete $opts{stdout_pipe} or
            $stdout_fh = delete $opts{stdout_fh} or
            $stdout_file = delete $opts{stdout_file} or
            (not $tunnel and $stdout_pty = delete $opts{stdout_pty}) );
  
          $stdout_pty and !$stdin_pty
              and croak "option stdout_pty requires stdin_pty set";
      }
  
      ( $stderr_discard = delete $opts{stderr_discard} or
        $stderr_pipe = delete $opts{stderr_pipe} or
        $stderr_fh = delete $opts{stderr_fh} or
        $stderr_to_stdout = delete $opts{stderr_to_stdout} or
        $stderr_file = delete $opts{stderr_file} );
  
      my $ssh_opts = delete $opts{ssh_opts};
      $ssh_opts = $self->{_default_ssh_opts} unless defined $ssh_opts;
      my @ssh_opts = $self->_expand_vars(_array_or_scalar_to_list $ssh_opts);
      if ($self->{_forward_agent}) {
  	my $forward_always = (($self->{_forward_agent} eq 'always') ? 1 : undef);
          my $forward_agent = _first_defined(delete($opts{forward_agent}), $forward_always);
          $ssh_flags .= ($forward_agent ? 'A' : 'a') if defined $forward_agent;
      }
      if ($self->{_forward_X11}) {
          my $forward_X11 = delete $opts{forward_X11};
          $ssh_flags .= ($forward_X11 ? 'X' : 'x');
      }
      if (delete $opts{subsystem}) {
          $ssh_flags .= 's';
      }
  
      my $setpgrp = delete $opts{setpgrp};
      undef $setpgrp if defined $stdin_pty;
  
      _croak_bad_options %opts;
  
      if (defined $stdin_file) {
  	$stdin_fh = $self->_open_file('<', $stdin_file) or return
      }
      if (defined $stdout_file) {
  	$stdout_fh = $self->_open_file('>', $stdout_file) or return
      }
      if (defined $stderr_file) {
  	$stderr_fh = $self->_open_file('>', $stderr_file) or return
      }
  
      my ($rin, $win, $rout, $wout, $rerr, $werr);
  
      if ($stdinout_socket) {
          unless(socketpair $rin, $win, AF_UNIX, SOCK_STREAM, PF_UNSPEC) {
              $self->_set_error(OSSH_SLAVE_PIPE_FAILED, "socketpair failed: $!");
              return;
          }
          $wout = $rin;
      }
      else {
          if ($stdin_pipe) {
              ($rin, $win) = $self->_make_pipe or return;
          }
          elsif ($stdin_pty) {
              _load_module('IO::Pty');
              $win = IO::Pty->new;
              unless ($win) {
                  $self->_set_error(OSSH_SLAVE_PIPE_FAILED, "unable to allocate pseudo-tty: $!");
                  return;
              }
              $rin = $win->slave;
          }
          elsif (defined $stdin_fh) {
              $rin = $stdin_fh;
          }
          else {
              $rin = $self->{_default_stdin_fh}
          }
          _check_is_system_fh STDIN => $rin;
  
          if ($stdout_pipe) {
              ($rout, $wout) = $self->_make_pipe or return;
          }
          elsif ($stdout_pty) {
              $wout = $rin;
          }
          elsif (defined $stdout_fh) {
              $wout = $stdout_fh;
          }
          else {
              $wout = $self->{_default_stdout_fh};
          }
          _check_is_system_fh STDOUT => $wout;
      }
  
      unless ($stderr_to_stdout) {
  	if ($stderr_pipe) {
  	    ($rerr, $werr) = $self->_make_pipe or return;
  	}
  	elsif (defined $stderr_fh) {
  	    $werr = $stderr_fh;
  	}
  	else {
  	    $werr = $self->{_default_stderr_fh};
  	}
  	_check_is_system_fh STDERR => $werr;
      }
  
      push @ssh_opts, "-$ssh_flags" if length $ssh_flags;
  
      my @call = ( $tunnel         ? $self->_make_tunnel_call(\@ssh_opts, @args) :
                   $cmd eq 'ssh'   ? $self->_make_ssh_call(\@ssh_opts, @args)    :
  		 $cmd eq 'scp'   ? $self->_make_scp_call(\@ssh_opts, @args)    :
  		 $cmd eq 'rsync' ? $self->_make_rsync_call(\@ssh_opts, @args)  :
                   $cmd eq 'raw'   ? @args                                       :
  		 die "Internal error: bad _cmd protocol" );
  
      $debug and $debug & 16 and _debug_dump open_ex => \@call;
  
      my $pid = fork;
      unless ($pid) {
          unless (defined $pid) {
              $self->_set_error(OSSH_SLAVE_FAILED,
                                "unable to fork new ssh slave: $!");
              return;
          }
  
          setpgrp if $setpgrp;
  
          $stdin_discard  and (open $rin,  '<', '/dev/null' or POSIX::_exit(255));
          $stdout_discard and (open $wout, '>', '/dev/null' or POSIX::_exit(255));
          $stderr_discard and (open $werr, '>', '/dev/null' or POSIX::_exit(255));
  
          if ($stdinout_dpipe) {
              my $pid1 = fork;
              defined $pid1 or POSIX::_exit(255);
  
              unless ($pid1 xor $stdinout_dpipe_make_parent) {
                  eval { $self->_exec_dpipe($stdinout_dpipe, $win, $werr) };
                  POSIX::_exit(255);
              }
          }
  
          my $rin_fd  = _fileno_dup_over(0 => $rin);
          my $wout_fd = _fileno_dup_over(1 => $wout);
          my $werr_fd = _fileno_dup_over(2 => $werr);
  
          if (defined $rin_fd) {
              $win->make_slave_controlling_terminal if $stdin_pty;
  	    $rin_fd == 0 or POSIX::dup2($rin_fd, 0) or POSIX::_exit(255);
          }
  	if (defined $wout_fd) {
              $wout_fd == 1 or POSIX::dup2($wout_fd, 1) or POSIX::_exit(255);
          }
          if (defined $werr_fd) {
              $werr_fd == 2 or POSIX::dup2($werr_fd, 2) or POSIX::_exit(255);
          }
          elsif ($stderr_to_stdout) {
              POSIX::dup2(1, 2) or POSIX::_exit(255);
          }
          do { exec @call };
          POSIX::_exit(255);
      }
      $win->close_slave() if $close_slave_pty;
      undef $win if defined $stdinout_dpipe;
      wantarray ? ($win, $rout, $rerr, $pid) : $pid;
  }
  
  sub pipe_in {
      ${^TAINT} and &_catch_tainted_args;
      my $self = shift;
      $self->wait_for_master or return;
      my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ());
      my $argument_encoding = $self->_delete_argument_encoding(\%opts);
      my @args = $self->_quote_args(\%opts, @_);
      _croak_bad_options %opts;
  
      $self->_encode_args($argument_encoding, @args) or return;
      my @call = $self->_make_ssh_call([], @args);
      $debug and $debug & 16 and _debug_dump pipe_in => @call;
      my $pid = open my $rin, '|-', @call;
      unless ($pid) {
          $self->_set_error(OSSH_SLAVE_FAILED,
                            "unable to fork new ssh slave: $!");
          return;
      }
      wantarray ? ($rin, $pid) : $rin;
  }
  
  sub pipe_out {
      ${^TAINT} and &_catch_tainted_args;
      my $self = shift;
      $self->wait_for_master or return;
      my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ());
      my $argument_encoding = $self->_delete_argument_encoding(\%opts);
      my @args = $self->_quote_args(\%opts, @_);
      _croak_bad_options %opts;
  
      $self->_encode_args($argument_encoding, @args) or return;
      my @call = $self->_make_ssh_call([], @args);
      $debug and $debug & 16 and _debug_dump pipe_out => @call;
      my $pid = open my $rout, '-|', @call;
      unless ($pid) {
          $self->_set_error(OSSH_SLAVE_FAILED,
                            "unable to fork new ssh slave: $!");
          return;
      }
      wantarray ? ($rout, $pid) : $rout;
  }
  
  sub _find_encoding {
      my ($self, $encoding, $data) = @_;
      if (defined $encoding and $encoding ne 'bytes') {
  	_load_module('Encode');
          my $enc = Encode::find_encoding($encoding);
          unless (defined $enc) {
              $self->_set_error(OSSH_ENCODING_ERROR, "bad encoding '$encoding'");
              return
          }
          return $enc
      }
      return undef
  }
  
  sub _encode {
      my $self = shift;
      my $enc = shift;
      if (defined $enc and @_) {
          local ($@, $SIG{__DIE__});
          eval {
              for (@_) {
                  defined or next;
                  $_ = $enc->encode($_, Encode::FB_CROAK());
              }
          };
          $self->_check_eval_ok(OSSH_ENCODING_ERROR) or return undef;
      }
      1;
  }
  
  sub _encode_args {
      if (@_ > 2) {
          my $self = shift;
          my $encoding = shift;
  
          my $enc = $self->_find_encoding($encoding);
          if ($enc) {
              local $self->{_error_prefix} = [@{$self->{_error_prefix}}, "argument encoding failed"];
              $self->_encode($enc, @_);
          }
          return !$self->{_error};
      }
      1;
  }
  
  sub _decode {
      my $self = shift;
      my $enc = shift;
      local ($@, $SIG{__DIE__});
      eval {
          for (@_) {
              defined or next;
              $_ = $enc->decode($_, Encode::FB_CROAK());
          }
      };
      $self->_check_eval_ok(OSSH_ENCODING_ERROR);
  }
  
  my @retriable = (Errno::EINTR(), Errno::EAGAIN());
  push @retriable, Errno::EWOULDBLOCK() if Errno::EWOULDBLOCK() != Errno::EAGAIN();
  
  sub _io3 {
      my ($self, $out, $err, $in, $stdin_data, $timeout, $encoding, $keep_in_open) = @_;
      # $self->wait_for_master or return;
      my @data = _array_or_scalar_to_list $stdin_data;
      my ($cout, $cerr, $cin) = (defined($out), defined($err), defined($in));
      $timeout = $self->{_timeout} unless defined $timeout;
  
      my $has_input = grep { defined and length } @data;
      if ($cin and !$has_input) {
          close $in unless $keep_in_open;
          undef $cin;
      }
      elsif (!$cin and $has_input) {
          croak "remote input channel is not defined but data is available for sending"
      }
  
      my $enc = $self->_find_encoding($encoding);
      if ($enc and @data) {
          local $self->{_error_prefix} = [@{$self->{_error_prefix}}, "stdin data encoding failed"];
          $self->_encode($enc, @data) if $has_input;
          return if $self->{_error};
      }
  
      my $bout = '';
      my $berr = '';
      my ($fnoout, $fnoerr, $fnoin);
      local $SIG{PIPE} = 'IGNORE';
  
   MLOOP: while ($cout or $cerr or $cin) {
          $debug and $debug & 64 and _debug "io3 mloop, cin: " . ($cin || 0) .
              ", cout: " . ($cout || 0) . ", cerr: " . ($cerr || 0);
          my ($rv, $wv);
  
          if ($cout or $cerr) {
              $rv = '';
              if ($cout) {
                  $fnoout = fileno $out;
                  vec($rv, $fnoout, 1) = 1;
              }
              if ($cerr) {
                  $fnoerr = fileno $err;
                  vec($rv, $fnoerr, 1) = 1
              }
          }
  
          if ($cin) {
              $fnoin = fileno $in;
              $wv = '';
              vec($wv, $fnoin, 1) = 1;
          }
  
          my $recalc_vecs;
      FAST: until ($recalc_vecs) {
              $debug and $debug & 64 and
                  _debug "io3 fast, cin: " . ($cin || 0) .
                      ", cout: " . ($cout || 0) . ", cerr: " . ($cerr || 0);
              my ($rv1, $wv1) = ($rv, $wv);
              my $n = select ($rv1, $wv1, undef, $timeout);
              if ($n > 0) {
                  if ($cout and vec($rv1, $fnoout, 1)) {
                      my $offset = length $bout;
                      my $read = sysread($out, $bout, 20480, $offset);
                      if ($debug and $debug & 64) {
                          _debug "stdout, bytes read: ", $read, " at offset $offset";
                          $read and $debug & 128 and _hexdump substr $bout, $offset;
                      }
                      unless ($read or grep $! == $_, @retriable) {
                          close $out;
                          undef $cout;
                          $recalc_vecs = 1;
                      }
                  }
                  if ($cerr and vec($rv1, $fnoerr, 1)) {
                      my $read = sysread($err, $berr, 20480, length($berr));
                      $debug and $debug & 64 and _debug "stderr, bytes read: ", $read;
                      unless ($read or grep $! == $_, @retriable) {
                          close $err;
                          undef $cerr;
                          $recalc_vecs = 1;
                      }
                  }
                  if ($cin and vec($wv1, $fnoin, 1)) {
                      my $written = syswrite($in, $data[0], 20480);
                      if ($debug and $debug & 64) {
                          _debug "stdin, bytes written: ", $written;
                          $written and $debug & 128 and _hexdump substr $data[0], 0, $written;
                      }
                      if ($written) {
                          substr($data[0], 0, $written, '');
                          while (@data) {
                              next FAST
                                  if (defined $data[0] and length $data[0]);
                              shift @data;
                          }
                          # fallback when stdin queue is exhausted
                      }
                      elsif (grep $! == $_, @retriable) {
                          next FAST;
                      }
                      close $in unless $keep_in_open;
                      undef $cin;
                      $recalc_vecs = 1;
                  }
              }
              else {
                  next if $n < 0 and grep $! == $_, @retriable;
                  $self->_set_error(OSSH_SLAVE_TIMEOUT, 'ssh slave failed', 'timed out');
                  last MLOOP;
              }
          }
      }
      close $out if $cout;
      close $err if $cerr;
      close $in if $cin and not $keep_in_open;
  
      if ($enc) {
          local $self->{_error_prefix} = [@{$self->{_error_prefix}}, 'output decoding failed'];
          unless ($self->_decode($enc, $bout, $berr)) {
              undef $bout;
              undef $berr;
          }
      }
      $debug and $debug & 64 and _debug "leaving _io3()";
      return ($bout, $berr);
  }
  
  
  
  _sub_options spawn => qw(stderr_to_stdout stdin_discard stdin_fh stdin_file stdout_discard stdout_fh
                           stdout_file stderr_discard stderr_fh stderr_file stdinout_dpipe
                           stdinout_dpipe_make_parent quote_args quote_args_extended remote_shell
                           glob_quoting tty ssh_opts tunnel encoding argument_encoding forward_agent
                           forward_X11 setpgrp subsystem);
  sub spawn {
      ${^TAINT} and &_catch_tainted_args;
      my $self = shift;
      my %opts =  (ref $_[0] eq 'HASH' ? %{shift()} : ());
      _croak_bad_options %opts;
  
      return scalar $self->open_ex(\%opts, @_);
  }
  
  _sub_options open2 => qw(stderr_to_stdout stderr_discard stderr_fh stderr_file quote_args quote_args_extended
                           remote_shell glob_quoting tty ssh_opts tunnel encoding argument_encoding forward_agent
                           forward_X11 setpgrp subsystem);
  sub open2 {
      ${^TAINT} and &_catch_tainted_args;
      my $self = shift;
      my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ());
      _croak_bad_options %opts;
      _croak_scalar_context;
  
      my ($in, $out, undef, $pid) =
          $self->open_ex({ stdout_pipe => 1,
                           stdin_pipe => 1,
                           %opts }, @_) or return ();
      return ($in, $out, $pid);
  }
  
  _sub_options open2pty => qw(stderr_to_stdout stderr_discard stderr_fh stderr_file
                              quote_args quote_args_extended remote_shell glob_quoting tty
                              close_slave_pty ssh_opts encoding argument_encoding forward_agent
                              forward_X11 setpgrp subsystem);
  sub open2pty {
      ${^TAINT} and &_catch_tainted_args;
      my $self = shift;
      my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ());
      _croak_bad_options %opts;
  
      my ($pty, undef, undef, $pid) =
          $self->open_ex({ stdout_pty => 1,
                           stdin_pty => 1,
  			 tty => 1,
                         %opts }, @_) or return ();
      wantarray ? ($pty, $pid) : $pty;
  }
  
  _sub_options open2socket => qw(stderr_to_stdout stderr_discard stderr_fh stderr_file
                                 quote_args quote_args_extended remote_shell glob_quoting tty
                                 ssh_opts tunnel encoding argument_encoding forward_agent
                                 forward_X11 setpgrp subsystem);
  sub open2socket {
      ${^TAINT} and &_catch_tainted_args;
      my $self = shift;
      my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ());
      _croak_bad_options %opts;
  
      my ($socket, undef, undef, $pid) =
          $self->open_ex({ stdinout_socket => 1,
                           %opts }, @_) or return ();
      wantarray ? ($socket, $pid) : $socket;
  }
  
  _sub_options open3 => qw(quote_args quote_args_extended remote_shell glob_quoting tty ssh_opts
                           encoding argument_encoding forward_agent forward_X11 setpgrp subsystem);
  sub open3 {
      ${^TAINT} and &_catch_tainted_args;
      my $self = shift;
      my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ());
      _croak_bad_options %opts;
      _croak_scalar_context;
  
      my ($in, $out, $err, $pid) =
          $self->open_ex({ stdout_pipe => 1,
                           stdin_pipe => 1,
                           stderr_pipe => 1,
  			 %opts },
                         @_) or return ();
      return ($in, $out, $err, $pid);
  }
  
  _sub_options open3pty => qw(quote_args quote_args_extended remote_shell glob_quoting tty close_slave_pty ssh_opts
                              encoding argument_encoding forward_agent forward_X11 setpgrp subsystem);
  sub open3pty {
      ${^TAINT} and &_catch_tainted_args;
      my $self = shift;
      my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ());
      _croak_bad_options %opts;
      _croak_scalar_context;
  
      my ($pty, undef, $err, $pid) =
          $self->open_ex({ stdout_pty => 1,
                           stdin_pty => 1,
  			 tty => 1,
                           stderr_pipe => 1,
  			 %opts },
                         @_) or return ();
      return ($pty, $err, $pid);
  }
  
  _sub_options open3socket => qw(quote_args quote_args_extended remote_shell glob_quoting tty ssh_opts encoding
                                 argument_encoding forward_agent forward_X11 setpgrp subsystem);
  sub open3socket {
      ${^TAINT} and &_catch_tainted_args;
      my $self = shift;
      my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ());
      _croak_bad_options %opts;
      _croak_scalar_context;
  
      my ($socket, undef, $err, $pid) =
          $self->open_ex({ stdinout_socket => 1,
                           stderr_pipe => 1,
  			 %opts }, @_) or return ();
      return ($socket, $err, $pid);
  }
  
  _sub_options system => qw(stdout_discard stdout_fh stdin_discard stdout_file stdin_fh stdin_file
                            quote_args quote_args_extended remote_shell glob_quoting
                            stderr_to_stdout stderr_discard stderr_fh stderr_file
                            stdinout_dpipe stdinout_dpipe_make_parent tty ssh_opts tunnel encoding
                            argument_encoding forward_agent forward_X11 setpgrp subsystem);
  sub system {
      ${^TAINT} and &_catch_tainted_args;
      my $self = shift;
      my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ());
      my $stdin_data = delete $opts{stdin_data};
      my $timeout = delete $opts{timeout};
      my $async = delete $opts{async};
      my $stdin_keep_open = ($async ? undef : delete $opts{stdin_keep_open});
  
      _croak_bad_options %opts;
  
      $stdin_data = '' if $stdin_keep_open and not defined $stdin_data;
  
      my $stream_encoding;
      if (defined $stdin_data) {
          $opts{stdin_pipe} = 1;
          $stream_encoding = $self->_delete_stream_encoding(\%opts);
      }
  
      local $SIG{INT} = 'IGNORE';
      local $SIG{QUIT} = 'IGNORE';
      local $SIG{CHLD};
  
      my ($in, undef, undef, $pid) = $self->open_ex(\%opts, @_) or return undef;
  
      $self->_io3(undef, undef, $in, $stdin_data,
                  $timeout, $stream_encoding, $stdin_keep_open) if defined $stdin_data;
      return $pid if $async;
      $self->_waitpid($pid, $timeout);
  }
  
  _sub_options test => qw(stdout_discard stdout_fh stdin_discard stdout_file stdin_fh stdin_file
                          quote_args quote_args_extended remote_shell glob_quoting stderr_to_stdout
                          stderr_discard stderr_fh stderr_file stdinout_dpipe
                          stdinout_dpipe_make_parent tty ssh_opts timeout stdin_data stdin_keep_open
                          encoding stream_encoding argument_encoding forward_agent forward_X11
                          setpgrp subsystem);
  
  sub test {
      ${^TAINT} and &_catch_tainted_args;
      my $self = shift;
      my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ());
      $opts{stdout_discard} = 1 unless grep defined($opts{$_}), qw(stdout_discard stdout_fh
                                                                   stdout_file stdinout_dpipe);
      $opts{stderr_discard} = 1 unless grep defined($opts{$_}), qw(stderr_discard stderr_fh
                                                                   stderr_file stderr_to_stdout);
      _croak_bad_options %opts;
  
      $self->system(\%opts, @_);
      my $error = $self->{_error};
      unless ($error) {
          return 1;
      }
      if ($error == OSSH_SLAVE_CMD_FAILED) {
          $self->_set_error(0);
          return 0;
      }
      return undef;
  }
  
  _sub_options capture => qw(stderr_to_stdout stderr_discard stderr_fh stderr_file stdin_discard
                             stdin_fh stdin_file quote_args quote_args_extended remote_shell
                             glob_quoting tty ssh_opts tunnel encoding argument_encoding forward_agent
                             forward_X11 setpgrp subsystem);
  sub capture {
      ${^TAINT} and &_catch_tainted_args;
      my $self = shift;
      my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ());
      my $stdin_data = delete $opts{stdin_data};
      my $stdin_keep_open = delete $opts{stdin_keep_open};
      my $timeout = delete $opts{timeout};
      _croak_bad_options %opts;
  
      $stdin_data = '' if $stdin_keep_open and not defined $stdin_data;
  
      my $stream_encoding = $self->_delete_stream_encoding(\%opts);
      $opts{stdout_pipe} = 1;
      $opts{stdin_pipe} = 1 if defined $stdin_data;
  
      local $SIG{INT} = 'IGNORE';
      local $SIG{QUIT} = 'IGNORE';
      local $SIG{CHLD};
  
      my ($in, $out, undef, $pid) = $self->open_ex(\%opts, @_) or return ();
      my ($output) = $self->_io3($out, undef, $in, $stdin_data,
                                 $timeout, $stream_encoding, $stdin_keep_open);
      $self->_waitpid($pid, $timeout);
      if (wantarray) {
          my $pattern = quotemeta $/;
          return split /(?<=$pattern)/, $output;
      }
      $output
  }
  
  _sub_options capture2 => qw(stdin_discard stdin_fh stdin_file quote_args quote_args_extended
                              remote_shell glob_quoting tty ssh_opts encoding stream_encoding
                              argument_encoding forward_agent forward_X11 setpgrp subsystem);
  sub capture2 {
      ${^TAINT} and &_catch_tainted_args;
      my $self = shift;
      my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ());
      my $stdin_data = delete $opts{stdin_data};
      my $stdin_keep_open = delete $opts{stdin_keep_open};
      my $timeout = delete $opts{timeout};
      _croak_bad_options %opts;
  
      $stdin_data = '' if $stdin_keep_open and not defined $stdin_data;
  
      my $stream_encoding = $self->_delete_stream_encoding(\%opts);
      $opts{stdout_pipe} = 1;
      $opts{stderr_pipe} = 1;
      $opts{stdin_pipe} = 1 if defined $stdin_data;
  
      local $SIG{INT} = 'IGNORE';
      local $SIG{QUIT} = 'IGNORE';
      local $SIG{CHLD};
  
      my ($in, $out, $err, $pid) = $self->open_ex( \%opts, @_) or return ();
      my @capture = $self->_io3($out, $err, $in, $stdin_data,
                                $timeout, $stream_encoding, $stdin_keep_open);
      $self->_waitpid($pid, $timeout);
      wantarray ? @capture : $capture[0];
  }
  
  _sub_options open_tunnel => qw(ssh_opts stderr_discard stderr_fh stderr_file
                                 encoding argument_encoding forward_agent setpgrp);
  sub open_tunnel {
      ${^TAINT} and &_catch_tainted_args;
      my $self = shift;
      my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ());
      $opts{stderr_discard} = 1 unless grep defined $opts{$_}, qw(stderr_discard stderr_fh stderr_file);
      _croak_bad_options %opts;
      @_ == 2 or croak 'Usage: $ssh->open_tunnel(\%opts, $host, $port)';
      $opts{tunnel} = 1;
      $self->open2socket(\%opts, @_);
  }
  
  _sub_options capture_tunnel => qw(ssh_opts stderr_discard stderr_fh stderr_file stdin_discard
  				  stdin_fh stdin_file stdin_data timeout encoding stream_encoding
  				  argument_encoding forward_agent setpgrp);
  sub capture_tunnel {
      ${^TAINT} and &_catch_tainted_args;
      my $self = shift;
      my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ());
      $opts{stderr_discard} = 1 unless grep defined $opts{$_}, qw(stderr_discard stderr_fh stderr_file);
      _croak_bad_options %opts;
      @_ == 2 or croak 'Usage: $ssh->capture_tunnel(\%opts, $host, $port)';
      $opts{tunnel} = 1;
      $self->capture(\%opts, @_);
  }
  
  sub _calling_method {
      my $method = (caller 2)[3];
      $method =~ s/.*:://;
      $method;
  }
  
  sub _scp_get_args {
      my $self = shift;
      my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ());
  
      @_ > 0 or croak
  	'Usage: $ssh->' . _calling_method . '(\%opts, $remote_fn1, $remote_fn2, ..., $local_fn_or_dir)';
  
      my $glob = delete $opts{glob};
  
      my $target = (@_ > 1 ? pop @_ : '.');
      $target =~ m|^[^/]*:| and $target = "./$target";
  
      my $prefix = $self->{_host_squared};
      $prefix = "$self->{_user}\@$prefix" if defined $self->{_user};
  
      my $src = "$prefix:". join(" ", $self->_quote_args({quote_args => 1,
                                                          glob_quoting => $glob},
                                                         @_));
      ($self, \%opts, $target, $src);
  }
  
  sub scp_get {
      ${^TAINT} and &_catch_tainted_args;
      my ($self, $opts, $target, @src) = _scp_get_args @_;
      $self->_scp($opts, @src, $target);
  }
  
  sub rsync_get {
      ${^TAINT} and &_catch_tainted_args;
      my ($self, $opts, $target, @src) = _scp_get_args @_;
      $self->_rsync($opts, @src, $target);
  }
  
  sub _scp_put_args {
      my $self = shift;
      my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ());
  
      @_ > 0 or croak
  	'Usage: $ssh->' . _calling_method . '(\%opts, $local_fn1, $local_fn2, ..., $remote_dir_or_fn)';
  
      my $glob = delete $opts{glob};
      my $glob_flags = ($glob ? delete $opts{glob_flags} || 0 : undef);
  
      my $prefix = $self->{_host_squared};
      $prefix = "$self->{_user}\@$prefix" if defined $self->{_user};
  
      my $remote_shell = delete $opts{remote_shell};
      my $target = $prefix . ':' . ( @_ > 1
                                     ? $self->_quote_args({quote_args => 1, remote_shell => $remote_shell}, pop(@_))
                                     : '');
  
      my @src = @_;
      if ($glob) {
  	require File::Glob;
  	@src = map File::Glob::bsd_glob($_, $glob_flags), @src;
  	unless (@src) {
  	    $self->_set_error(OSSH_SLAVE_FAILED,
  			      "given file name patterns did not match any file");
  	    return undef;
  	}
      }
      $_ = "./$_" for grep m|^[^/]*:|, @src;
  
      ($self, \%opts, $target, @src);
  }
  
  sub scp_put {
      ${^TAINT} and &_catch_tainted_args;
      my ($self, $opts, $target, @src) = _scp_put_args @_;
      return unless $self;
      $self->_scp($opts, @src, $target);
  }
  
  sub rsync_put {
      ${^TAINT} and &_catch_tainted_args;
      my ($self, $opts, $target, @src) = _scp_put_args @_;
      return unless $self;
      $self->_rsync($opts, @src, $target);
  }
  
  _sub_options _scp => qw(stderr_to_stdout stderr_discard stderr_fh
  			stderr_file stdout_discard stdout_fh
  			stdout_file encoding argument_encoding
                          forward_agent setpgrp);
  sub _scp {
      my $self = shift;
      my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ());
      my $quiet = delete $opts{quiet};
      $quiet = 1 unless defined $quiet;
      my $recursive = delete $opts{recursive};
      my $copy_attrs = delete $opts{copy_attrs};
      my $bwlimit = delete $opts{bwlimit};
      my $async = delete $opts{async};
      my $ssh_opts = delete $opts{ssh_opts};
      my $timeout = delete $opts{timeout};
      my $verbose = delete $opts{verbose};
      _croak_bad_options %opts;
  
      my @opts;
      @opts = @$ssh_opts if $ssh_opts;
      push @opts, '-q' if $quiet;
      push @opts, '-v' if $verbose;
      push @opts, '-r' if $recursive;
      push @opts, '-p' if $copy_attrs;
      push @opts, '-l', $bwlimit if $bwlimit;
  
      local $self->{_error_prefix} = [@{$self->{_error_prefix}}, 'scp failed'];
  
      my $pid = $self->open_ex({ %opts,
                                 _cmd => 'scp',
  			       ssh_opts => \@opts,
  			       quote_args => 0 },
  			     @_);
  
      return $pid if $async;
      $self->_waitpid($pid, $timeout);
  }
  
  my %rsync_opt_with_arg = map { $_ => 1 } qw(chmod suffix backup-dir rsync-path max-delete max-size min-size partial-dir
                                              timeout modify-window temp-dir compare-dest copy-dest link-dest compress-level
                                              skip-compress filter exclude exclude-from include include-from
                                              out-format log-file log-file-format bwlimit protocol iconv checksum-seed files-from);
  
  my %rsync_opt_forbidden = map { $_ => 1 } qw(rsh address port sockopts password-file write-batch
                                              only-write-batch read-batch ipv4 ipv6 version help daemon config detach
                                              protect-args list-only);
  
  $rsync_opt_forbidden{"no-$_"} = 1 for (keys %rsync_opt_with_arg, keys %rsync_opt_forbidden);
  
  my %rsync_error = (1, 'syntax or usage error',
  		   2, 'protocol incompatibility',
  		   3, 'errors selecting input/output files, dirs',
  		   4, 'requested action not supported: an attempt was made to manipulate 64-bit files on a platform '.
                        'that  cannot  support them; or an option was specified that is supported by the client and not '.
                        'by the server.',
  		   5, 'error starting client-server protocol',
  		   6, 'daemon unable to append to log-file',
  		   10, 'error in socket I/O',
  		   11, 'error in file I/O',
  		   12, 'error in rsync protocol data stream',
  		   13, 'errors with program diagnostics',
  		   14, 'error in IPC code',
  		   20, 'received SIGUSR1 or SIGINT',
  		   21, 'some error returned by waitpid()',
  		   22, 'error allocating core memory buffers',
  		   23, 'partial transfer due to error',
  		   24, 'partial transfer due to vanished source files',
  		   25, 'the --max-delete limit stopped deletions',
  		   30, 'timeout in data send/receive',
  		   35, 'timeout waiting for daemon connection');
  
  my %rsync_opt_open_ex = map { $_ => 1 } qw(stderr_to_stdout
  					   stderr_discard stderr_fh
  					   stderr_file stdout_discard
  					   stdout_fh stdout_file encoding
                                             argument_encoding);
  sub _rsync {
      my $self = shift;
      my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ());
      my $async = delete $opts{async};
      my $verbose = delete $opts{verbose};
      my $quiet = delete $opts{quiet};
      my $copy_attrs = delete $opts{copy_attrs};
      my $timeout = delete $opts{timeout};
      $quiet = 1 unless (defined $quiet or $verbose);
  
      my @opts;
      push @opts, '-q' if $quiet;
      push @opts, '-pt' if $copy_attrs;
      push @opts, '-' . ($verbose =~ /^\d+$/ ? 'v' x $verbose : 'v') if $verbose;
  
      my %opts_open_ex = ( _cmd => 'rsync',
  			 quote_args => 0 );
  
      for my $opt (keys %opts) {
  	my $value = $opts{$opt};
  	if (defined $value) {
  	    if ($rsync_opt_open_ex{$opt}) {
  		$opts_open_ex{$opt} = $value;
  	    }
  	    else {
  		my $opt1 = $opt;
  		$opt1 =~ tr/_/-/;
  		$rsync_opt_forbidden{$opt1} and croak "forbidden rsync option '$opt' used";
  		if ($rsync_opt_with_arg{$opt1}) {
  		    push @opts, "--$opt1=$_" for _array_or_scalar_to_list($value)
  		}
  		else {
  		    $value = !$value if $opt1 =~ s/^no-//;
  		    push @opts, ($value ? "--$opt1" : "--no-$opt1");
  		}
  	    }
  	}
      }
  
      local $self->{_error_prefix} = [@{$self->{_error_prefix}}, 'rsync failed'];
  
      my $pid = $self->open_ex(\%opts_open_ex, @opts, '--', @_);
      return $pid if $async;
      $self->_waitpid($pid, $timeout) and return 1;
  
      if ($self->{_error} == OSSH_SLAVE_CMD_FAILED and $?) {
  	my $err = ($? >> 8);
  	my $errstr = $rsync_error{$err};
  	$errstr = 'Unknown rsync error' unless defined $errstr;
  	my $signal = $? & 255;
  	my $signalstr = ($signal ? " (signal $signal)" : '');
  	$self->_set_error(OSSH_SLAVE_CMD_FAILED,
  			  "command exited with code $err$signalstr: $errstr");
      }
      return undef
  }
  
  _sub_options sftp => qw(autoflush timeout argument_encoding encoding block_size queue_size autodie
  			late_set_perm forward_agent setpgrp min_block_size read_ahead write_delay
  			dirty_cleanup remote_has_volumes autodisconnect more);
  
  sub sftp {
      ${^TAINT} and &_catch_tainted_args;
      @_ & 1 or croak 'Usage: $ssh->sftp(%sftp_opts)';
      _load_module('Net::SFTP::Foreign', '1.47');
      my ($self, %opts) = @_;
      my $stderr_fh = delete $opts{stderr_fh};
      my $stderr_discard = delete $opts{stderr_discard};
      my $fs_encoding = _first_defined(delete $opts{fs_encoding},
                                       $opts{argument_encoding},
                                       $opts{encoding},
                                       $self->{_default_argument_encoding});
      undef $fs_encoding if (defined $fs_encoding and $fs_encoding eq 'bytes');
      _croak_bad_options %opts;
      $opts{timeout} = $self->{_timeout} unless defined $opts{timeout};
      $self->wait_for_master or return undef;
      my ($in, $out, $pid) = $self->open2( { subsystem => 1,
  					   stderr_fh => $stderr_fh,
  					   stderr_discard => $stderr_discard },
  					 'sftp' )
  	or return undef;
  
      my $sftp = Net::SFTP::Foreign->new(transport => [$out, $in, $pid],
  				       dirty_cleanup => 0,
                                         fs_encoding => $fs_encoding,
  				       %opts);
      if ($sftp->error) {
  	$self->_or_set_error(OSSH_SLAVE_SFTP_FAILED, "unable to create SFTP client", $sftp->error);
  	return undef;
      }
      $sftp
  }
  
  _sub_options sshfs_import => qw(stderr_discard stderr_fh stderr_file
                                  ssh_opts argument_encoding sshfs_opts setpgrp);
  sub sshfs_import {
      ${^TAINT} and &_catch_tainted_args;
      my $self = shift;
      my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ());
      @_ == 2 or croak 'Usage: $ssh->sshfs_import(\%opts, $remote, $local)';
      my ($from, $to) = @_;
      my @sshfs_opts = ( -o => 'slave',
                         _array_or_scalar_to_list delete $opts{sshfs_opts} );
      _croak_bad_options %opts;
  
      $opts{ssh_opts} = ['-s', _array_or_scalar_to_list delete $opts{ssh_opts}];
      $opts{stdinout_dpipe} = [$self->{_sshfs_cmd}, "$self->{_host_squared}:$from", $to, @sshfs_opts];
      $opts{stdinout_dpipe_make_parent} = 1;
      $self->spawn(\%opts, 'sftp');
  }
  
  _sub_options sshfs_export => qw(stderr_discard stderr_fh stderr_file
                                  ssh_opts argument_encoding sshfs_opts setpgrp);
  sub sshfs_export {
      ${^TAINT} and &_catch_tainted_args;
      my $self = shift;
      my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ());
      @_ == 2 or croak 'Usage: $ssh->sshfs_export(\%opts, $local, $remote)';
      my ($from, $to) = @_;
      my @sshfs_opts = ( -o => 'slave',
                         _array_or_scalar_to_list delete $opts{sshfs_opts} );
      _croak_bad_options %opts;
      $opts{stdinout_dpipe} = $self->{_sftp_server_cmd};
  
      my $hostname = do {
          local ($@, $SIG{__DIE__});
          eval {
              require Sys::Hostname;
              Sys::Hostname::hostname();
          };
      };
      $hostname = 'remote' if (not defined $hostname   or
                               not length $hostname    or
                               $hostname=~/^localhost\b/);
      $self->spawn(\%opts, $self->{_sshfs_cmd}, "$hostname:$from", $to, @sshfs_opts);
  }
  
  sub object_remote {
      my $self = shift;
      _load_module('Object::Remote') or return;
      _load_module('Net::OpenSSH::ObjectRemote') or return;
      my $connector = Net::OpenSSH::ObjectRemote->new(net_openssh => $self);
      $connector->connect(@_);
  }
  
  sub any {
      my $self = shift;
      _load_module('Net::SSH::Any');
      Net::SSH::Any->new($self->{_host}, user => $self->{_user}, port => $self->{_port},
                         backend => 'Net_OpenSSH',
                         backend_opts => { Net_OpenSSH => { instance => $self } });
  }
  
  sub DESTROY {
      my $self = shift;
      $debug and $debug & 2 and _debug("DESTROY($self, pid: ", $self->{_pid}, ")");
      local ($SIG{__DIE__}, $@, $?, $!);
      $self->_disconnect;
  }
  
  1;
  __END__
  
  =head1 NAME
  
  Net::OpenSSH - Perl SSH client package implemented on top of OpenSSH
  
  =head1 SYNOPSIS
  
    use Net::OpenSSH;
  
    my $ssh = Net::OpenSSH->new($host);
    $ssh->error and
      die "Couldn't establish SSH connection: ". $ssh->error;
  
    $ssh->system("ls /tmp") or
      die "remote command failed: " . $ssh->error;
  
    my @ls = $ssh->capture("ls");
    $ssh->error and
      die "remote ls command failed: " . $ssh->error;
  
    my ($out, $err) = $ssh->capture2("find /root");
    $ssh->error and
      die "remote find command failed: " . $ssh->error;
  
    my ($rin, $pid) = $ssh->pipe_in("cat >/tmp/foo") or
      die "pipe_in method failed: " . $ssh->error;
  
    print $rin "hello\n";
    close $rin;
  
    my ($rout, $pid) = $ssh->pipe_out("cat /tmp/foo") or
      die "pipe_out method failed: " . $ssh->error;
  
    while (<$rout>) { print }
    close $rout;
  
    my ($in, $out ,$pid) = $ssh->open2("foo");
    my ($pty, $pid) = $ssh->open2pty("foo");
    my ($in, $out, $err, $pid) = $ssh->open3("foo");
    my ($pty, $err, $pid) = $ssh->open3pty("login");
  
    my $sftp = $ssh->sftp();
    $sftp->error and die "SFTP failed: " . $sftp->error;
  
  
  =head1 DESCRIPTION
  
  Net::OpenSSH is a secure shell client package implemented on top of
  OpenSSH binary client (C<ssh>).
  
  =head2 Under the hood
  
  This package is implemented around the multiplexing feature found in
  later versions of OpenSSH. That feature allows one to run several
  sessions over a single SSH connection (OpenSSH 4.1 was the first
  one to provide all the required functionality).
  
  When a new Net::OpenSSH object is created, the OpenSSH C<ssh> client
  is run in master mode, establishing a persistent (for the lifetime of
  the object) connection to the server.
  
  Then, every time a new operation is requested a new C<ssh> process is
  started in slave mode, effectively reusing the master SSH connection
  to send the request to the remote side.
  
  =head2 Net::OpenSSH Vs. Net::SSH::.* modules
  
  Why should you use Net::OpenSSH instead of any of the other Perl SSH
  clients available?
  
  Well, this is my (biased) opinion:
  
  L<Net::SSH::Perl|Net::SSH::Perl> is not well maintained nowadays
  (update: a new maintainer has stepped in so this situation could
  change!!!), requires a bunch of modules (some of them very difficult
  to install) to be acceptably efficient and has an API that is limited
  in some ways.
  
  L<Net::SSH2|Net::SSH2> is much better than Net::SSH::Perl, but not
  completely stable yet. It can be very difficult to install on some
  specific operating systems and its API is also limited, in the same
  way as L<Net::SSH::Perl|Net::SSH::Perl>.
  
  Using L<Net::SSH::Expect|Net::SSH::Expect>, in general, is a bad
  idea. Handling interaction with a shell via Expect in a generic way
  just can not be reliably done.
  
  Net::SSH is just a wrapper around any SSH binary commands available on
  the machine. It can be very slow as they establish a new SSH
  connection for every operation performed.
  
  In comparison, Net::OpenSSH is a pure perl module that does not have
  any mandatory dependencies (obviously, besides requiring OpenSSH
  binaries).
  
  Net::OpenSSH has a very perlish interface. Most operations are
  performed in a fashion very similar to that of the Perl builtins and
  common modules (e.g. L<IPC::Open2|IPC::Open2>).
  
  It is also very fast. The overhead introduced by launching a new ssh
  process for every operation is not appreciable (at least on my Linux
  box). The bottleneck is the latency intrinsic to the protocol, so
  Net::OpenSSH is probably as fast as an SSH client can be.
  
  Being based on OpenSSH is also an advantage: a proved, stable, secure
  (to paranoid levels), inseparably and well maintained implementation
  of the SSH protocol is used.
  
  On the other hand, Net::OpenSSH does not work on Windows, not even
  under Cygwin.
  
  Net::OpenSSH specifically requires the OpenSSH SSH client (AFAIK, the
  multiplexing feature is not available from any other SSH
  client). However, note that it will interact with any server software,
  not just servers running OpenSSH C<sshd>.
  
  For password authentication, L<IO::Pty|IO::Pty> has to be
  installed. Other modules and binaries are also required to implement
  specific functionality (for instance
  L<Net::SFTP::Foreign|Net::SFTP::Foreign>, L<Expect|Expect> or
  L<rsync(1)|rsync(1)>).
  
  Net::OpenSSH and Net::SSH2 do not support version 1 of the SSH
  protocol.
  
  =head1 API
  
  =head2 Optional arguments
  
  Almost all methods in this package accept as first argument an
  optional reference to a hash containing parameters (C<\%opts>). For
  instance, these two method calls are equivalent:
  
    my $out1 = $ssh->capture(@cmd);
    my $out2 = $ssh->capture({}, @cmd);
  
  =head2 Error handling
  
  Most methods return undef (or an empty list) to indicate failure.
  
  The L</error> method can always be used to explicitly check for
  errors. For instance:
  
    my ($output, $errput) = $ssh->capture2({timeout => 1}, "find /");
    $ssh->error and die "ssh failed: " . $ssh->error;
  
  =head2 Net::OpenSSH methods
  
  These are the methods provided by the package:
  
  =over 4
  
  =item Net::OpenSSH->new($host, %opts)
  
  Creates a new SSH master connection
  
  C<$host> can be a hostname or an IP address. It may also
  contain the name of the user, her password and the TCP port
  number where the server is listening:
  
     my $ssh1 = Net::OpenSSH->new('jack@foo.bar.com');
     my $ssh2 = Net::OpenSSH->new('jack:secret@foo.bar.com:10022');
     my $ssh3 = Net::OpenSSH->new('jsmith@2001:db8::1428:57ab'); # IPv6
  
  IPv6 addresses may optionally be enclosed in brackets:
  
     my $ssh4 = Net::OpenSSH->new('jsmith@[::1]:1022');
  
  This method always succeeds in returning a new object. Error checking
  has to be performed explicitly afterwards:
  
    my $ssh = Net::OpenSSH->new($host, %opts);
    $ssh->error and die "Can't ssh to $host: " . $ssh->error;
  
  If you have problems getting Net::OpenSSH to connect to the remote
  host read the troubleshooting chapter near the end of this document.
  
  Accepted options:
  
  =over 4
  
  =item user => $user_name
  
  Login name
  
  =item port => $port
  
  TCP port number where the server is running
  
  =item password => $password
  
  User given password for authentication.
  
  Note that using password authentication in automated scripts is a very
  bad idea. When possible, you should use public key authentication
  instead.
  
  =item passphrase => $passphrase
  
  X<passphrase>Uses given passphrase to open private key.
  
  =item key_path => $private_key_path
  
  Uses the key stored on the given file path for authentication.
  
  =item gateway => $gateway
  
  If the given argument is a gateway object as returned by
  L<Net::OpenSSH::Gateway/find_gateway> method, use it to connect to
  the remote host.
  
  If it is a hash reference, call the C<find_gateway> method first.
  
  For instance, the following code fragments are equivalent:
  
    my $gateway = Net::OpenSSH::Gateway->find_gateway(
            proxy => 'http://proxy.corporate.com');
    $ssh = Net::OpenSSH->new($host, gateway => $gateway);
  
  and
  
    $ssh = Net::OpenSSH->new($host,
            gateway => { proxy => 'http://proxy.corporate.com'});
  
  =item proxy_command => $proxy_command
  
  Use the given command to establish the connection to the remote host
  (see C<ProxyCommand> on L<ssh_config(5)>).
  
  =item batch_mode => 1
  
  Disables querying the user for password and passphrases.
  
  =item ctl_dir => $path
  
  Directory where the SSH master control socket will be created.
  
  This directory and its parents must be writable only by the current
  effective user or root, otherwise the connection will be aborted to
  avoid insecure operation.
  
  By default C<~/.libnet-openssh-perl> is used.
  
  =item ctl_path => $path
  
  Path to the SSH master control socket.
  
  Usually this option should be avoided as the module is able to pick an unused
  socket path by itself. An exception to that rule is when the C<external_master>
  feature is enabled.
  
  Note that the length of the path is usually limited to between 92 and 108 bytes,
  depending of the underlying operating system.
  
  =item ssh_cmd => $cmd
  
  Name or full path to OpenSSH C<ssh> binary. For instance:
  
    my $ssh = Net::OpenSSH->new($host, ssh_cmd => '/opt/OpenSSH/bin/ssh');
  
  =item scp_cmd => $cmd
  
  Name or full path to OpenSSH C<scp> binary.
  
  By default it is inferred from the C<ssh> one.
  
  =item rsync_cmd => $cmd
  
  Name or full path to C<rsync> binary. Defaults to C<rsync>.
  
  =item remote_shell => $name
  
  Name of the remote shell. Used to select the argument quoter backend.
  
  =item timeout => $timeout
  
  Maximum acceptable time that can elapse without network traffic or any
  other event happening on methods that are not immediate (for instance,
  when establishing the master SSH connection or inside methods
  C<capture>, C<system>, C<scp_get>, etc.).
  
  See also L</Timeouts>.
  
  =item kill_ssh_on_timeout => 1
  
  This option tells Net::OpenSSH to kill the local slave SSH process
  when some operation times out.
  
  See also L</Timeouts>.
  
  =item strict_mode => 0
  
  By default, the connection will be aborted if the path to the socket
  used for multiplexing is found to be non-secure (for instance, when
  any of the parent directories is writable by other users).
  
  This option can be used to disable that feature. Use with care!!!
  
  =item async => 1
  
  By default, the constructor waits until the multiplexing socket is
  available. That option can be used to defer the waiting until the
  socket is actually used.
  
  For instance, the following code connects to several remote machines
  in parallel:
  
    my (%ssh, %ls);
    # multiple connections are established in parallel:
    for my $host (@hosts) {
        $ssh{$host} = Net::OpenSSH->new($host, async => 1);
    }
    # then to run some command in all the hosts (sequentially):
    for my $host (@hosts) {
        $ssh{$host}->system('ls /');
    }
  
  =item connect => 0
  
  Do not launch the master SSH process yet.
  
  =item master_opts => [...]
  
  Additional options to pass to the C<ssh> command when establishing the
  master connection. For instance:
  
    my $ssh = Net::OpenSSH->new($host,
        master_opts => [-o => "ProxyCommand corkscrew httpproxy 8080 $host"]);
  
  =item default_ssh_opts => [...]
  
  Default slave SSH command line options for L</open_ex> and derived
  methods.
  
  For instance:
  
    my $ssh = Net::OpenSSH->new($host,
        default_ssh_opts => [-o => "ConnectionAttempts=0"]);
  
  =item forward_agent => 1
  
  =item forward_agent => 'always'
  
  Enables forwarding of the authentication agent.
  
  When C<always> is passed as the argument, agent forwarding will be
  enabled by default in all the channels created from the
  object. Otherwise, it will have to be explicitly requested when
  calling the channel creating methods (i.e. C<open_ex> and its
  derivations).
  
  This option can not be used when passing a passphrase (via
  L</passphrase>) to unlock the login private key.
  
  Note that Net::OpenSSH will not run C<ssh-agent> for you. This has to
  be done ahead of time and the environment variable C<SSH_AUTH_SOCK>
  set pointing to the proper place.
  
  =item forward_X11 => 1
  
  Enables forwarding of the X11 protocol
  
  =item default_stdin_fh => $fh
  
  =item default_stdout_fh => $fh
  
  =item default_stderr_fh => $fh
  
  Default I/O streams for L</open_ex> and derived methods (currently, that
  means any method but L</pipe_in> and L</pipe_out> and I plan to remove
  those exceptions soon!).
  
  For instance:
  
    open my $stderr_fh, '>>', '/tmp/$host.err' or die ...;
    open my $stdout_fh, '>>', '/tmp/$host.log' or die ...;
  
    my $ssh = Net::OpenSSH->new($host, default_stderr_fh => $stderr_fh,
                                       default_stdout_fh => $stdout_fh);
    $ssh->error and die "SSH connection failed: " . $ssh->error;
  
    $ssh->scp_put("/foo/bar*", "/tmp")
      or die "scp failed: " . $ssh->error;
  
  =item default_stdin_file = $fn
  
  =item default_stdout_file = $fn
  
  =item default_stderr_file = $fn
  
  Opens the given file names and use them as the defaults.
  
  =item master_stdout_fh => $fh
  
  =item master_stderr_fh => $fh
  
  Redirect corresponding stdio streams of the master SSH process to
  given filehandles.
  
  =item master_stdout_discard => $bool
  
  =item master_stderr_discard => $bool
  
  Discard corresponding stdio streams.
  
  =item expand_vars => $bool
  
  Activates variable expansion inside command arguments and file paths.
  
  See L</"Variable expansion"> below.
  
  =item vars => \%vars
  
  Initial set of variables.
  
  =item external_master => 1
  
  Instead of launching a new OpenSSH client in master mode, the module
  tries to reuse an already existent one. C<ctl_path> must also be
  passed when this option is set. See also L</get_ctl_path>.
  
  Example:
  
    $ssh = Net::OpenSSH->new('foo', external_master => 1, ctl_path = $path);
  
  When C<external_master> is set, the hostname argument becomes optional
  (C<0.0.0.0> is passed to OpenSSH which does not use it at all).
  
  =item default_encoding => $encoding
  
  =item default_stream_encoding => $encoding
  
  =item default_argument_encoding => $encoding
  
  Set default encodings. See L</Data encoding>.
  
  =item password_prompt => $string
  
  =item password_prompt => $re
  
  By default, when using password authentication, the module expects the
  remote side to send a password prompt matching C</[?:]/>.
  
  This option can be used to override that default for the rare cases
  when a different prompt is used.
  
  Examples:
  
     password_prompt => ']'; # no need to escape ']'
     password_prompt => qr/[:?>]/;
  
  =item login_handler => \&custom_login_handler
  
  Some remote SSH server may require a custom login/authentication
  interaction not natively supported by Net::OpenSSH. In that cases, you
  can use this option to replace the default login logic.
  
  The callback will be invoked repeatedly as C<custom_login_handler($ssh,
  $pty, $data)> where C<$ssh> is the current Net::OpenSSH object, C<pty>
  a L<IO::Pty> object attached to the slave C<ssh> process tty and
  C<$data> a reference to an scalar you can use at will.
  
  The login handler must return 1 after the login process has completed
  successfully or 0 in case it still needs to do something else. If some
  error happens, it must die.
  
  Note, that blocking operations should not be performed inside the
  login handler (at least if you want the C<async> and C<timeout>
  features to work).
  
  See also the sample script C<login_handler.pl> in the C<examples>
  directory.
  
  Usage of this option is incompatible with the C<password> and
  C<passphrase> options, you will have to handle password or passphrases
  from the custom handler yourself.
  
  =item master_setpgrp => 1
  
  When this option is set, the master process is run as a different
  process group. As a consequence it will not die when the user presses
  Ctrl-C at the terminal.
  
  In order to allow the master SSH process to request any information
  from the user, the module may set it as the terminal controlling
  process while the connection is established (using
  L<POSIX/tcsetpgrp>). Afterwards, the terminal controlling process is
  reset.
  
  This feature is highly experimental. Report any problems you may find,
  please.
  
  =item master_pty_force => 1
  
  By default, Net::OpenSSH attaches the master SSH process to a pty only
  when some kind of interactive authentication is requested. If this
  flag is set a pty will be attached always.
  
  That allows to get better diagnostics for some kind of errors (as for
  instance, bad host keys) and also allows to retrieve the pty log using
  L<get_master_pty_log>.
  
  =back
  
  =item $ssh->error
  
  Returns the error condition for the last performed operation.
  
  The returned value is a dualvar as $! (see L<perlvar/"$!">) that
  renders an informative message when used in string context or an error
  number in numeric context (error codes appear in
  L<Net::OpenSSH::Constants|Net::OpenSSH::Constants>).
  
  =item $ssh->get_master_pty_log
  
  In order to handle password authentication or entering the passphrase
  for a private key, Net::OpenSSH may run the master SSH process attached
  to a pty.
  
  In that case and after a constructor call returns a connection failure
  error, this method can be called to retrieve the output captured at
  the pty (the log is discarded when the connection is established
  successfully).
  
  Any data consumed from the pty by custom login handlers will be
  missing from the the returned log.
  
  =item $ssh->get_user
  
  =item $ssh->get_host
  
  =item $ssh->get_port
  
  Return the corresponding SSH login parameters.
  
  =item $ssh->get_ctl_path
  
  X<get_ctl_path>Returns the path to the socket where the OpenSSH master
  process listens for new multiplexed connections.
  
  =item ($in, $out, $err, $pid) = $ssh->open_ex(\%opts, @cmd)
  
  X<open_ex>I<Note: this is a low level method which, probably, you do
  not need to use!>
  
  That method starts the command C<@cmd> on the remote machine creating
  new pipes for the IO channels as specified on the C<%opts> hash.
  
  If C<@cmd> is omitted, the remote user shell is run.
  
  Returns four values, the first three (C<$in>, C<$out> and C<$err>)
  correspond to the local side of the pipes created (they can be undef)
  and the fourth (C<$pid>) to the PID of the new SSH slave process. An
  empty list is returned on failure.
  
  Note that C<waitpid> has to be used afterwards to reap the
  slave SSH process.
  
  Accepted options:
  
  =over 4
  
  =item stdin_pipe => 1
  
  Creates a new pipe and connects the reading side to the stdin stream
  of the remote process. The writing side is returned as the first
  value (C<$in>).
  
  =item stdin_pty => 1
  
  Similar to C<stdin_pipe>, but instead of a regular pipe it uses a
  pseudo-tty (pty).
  
  Note that on some operating systems (e.g. HP-UX, AIX), ttys are not
  reliable. They can overflow when large chunks are written or when data
  is written faster than it is read.
  
  =item stdin_fh => $fh
  
  Duplicates C<$fh> and uses it as the stdin stream of the remote process.
  
  =item stdin_file => $filename
  
  =item stdin_file => \@open_args
  
  Opens the file of the given name for reading and uses it as the remote
  process stdin stream.
  
  If an array reference is passed its contents are used as the arguments
  for the underlying open call. For instance:
  
    $ssh->system({stdin_file => ['-|', 'gzip -c -d file.gz']}, $rcmd);
  
  =item stdin_discard => 1
  
  Uses /dev/null as the remote process stdin stream.
  
  =item stdout_pipe => 1
  
  Creates a new pipe and connects the writing side to the stdout stream
  of the remote process. The reading side is returned as the second
  value (C<$out>).
  
  =item stdout_pty => 1
  
  Connects the stdout stream of the remote process to the
  pseudo-pty. This option requires C<stdin_pty> to be also set.
  
  =item stdout_fh => $fh
  
  Duplicates C<$fh> and uses it as the stdout stream of the remote
  process.
  
  =item stdout_file => $filename
  
  =item stdout_file => \@open_args
  
  Opens the file of the given filename and redirect stdout there.
  
  =item stdout_discard => 1
  
  Uses /dev/null as the remote process stdout stream.
  
  =item stdinout_socket => 1
  
  Creates a new socketpair, attaches the stdin an stdout streams of the
  slave SSH process to one end and returns the other as the first value
  (C<$in>) and undef for the second (C<$out>).
  
  Example:
  
    my ($socket, undef, undef, $pid) = $ssh->open_ex({stdinout_socket => 1},
                                                     '/bin/netcat $dest');
  
  See also L</open2socket>.
  
  =item stdinout_dpipe => $cmd
  
  =item stdinout_dpipe => \@cmd
  
  Runs the given command locally attaching its stdio streams to those of
  the remote SSH command. Conceptually it is equivalent to the
  L<dpipe(1)> shell command.
  
  =item stderr_pipe => 1
  
  Creates a new pipe and connects the writing side to the stderr stream
  of the remote process. The reading side is returned as the third
  value (C<$err>).
  
  Example:
  
    my $pid = $ssh->open_ex({stdinout_dpipe => 'vncviewer -stdio'},
                            x11vnc => '-inetd');
  
  =item stderr_fh => $fh
  
  Duplicates C<$fh> and uses it as the stderr stream of the remote process.
  
  =item stderr_file => $filename
  
  Opens the file of the given name and redirects stderr there.
  
  =item stderr_to_stdout => 1
  
  Makes stderr point to stdout.
  
  =item tty => $bool
  
  Tells C<ssh> to allocate a pseudo-tty for the remote process. By
  default, a tty is allocated if remote command stdin stream is attached
  to a tty.
  
  When this flag is set and stdin is not attached to a tty, the ssh
  master and slave processes may generate spurious warnings about failed
  tty operations. This is caused by a bug present in older versions of
  OpenSSH.
  
  =item close_slave_pty => 0
  
  When a pseudo pty is used for the stdin stream, the slave side is
  automatically closed on the parent process after forking the ssh
  command.
  
  This option disables that feature, so that the slave pty can be
  accessed on the parent process as C<$pty-E<gt>slave>. It will have to
  be explicitly closed (see L<IO::Pty|IO::Pty>)
  
  =item quote_args => $bool
  
  See L</"Shell quoting"> below.
  
  =item remote_shell => $shell
  
  Sets the remote shell. Allows one to change the argument quoting
  mechanism in a per-command fashion.
  
  This may be useful when interacting with a Windows machine where
  argument parsing may be done at the command level in custom ways.
  
  Example:
  
    $ssh->system({remote_shell => 'MSWin'}, echo => $line);
    $ssh->system({remote_shell => 'MSCmd,MSWin'}, type => $file);
  
  =item forward_agent => $bool
  
  Enables/disables forwarding of the authentication agent.
  
  This option can only be used when agent forwarding has been previously
  requested on the constructor.
  
  =item forward_X11 => $bool
  
  Enables/disables forwarding of the X11 protocol.
  
  This option can only be used when X11 forwarding has been previously
  requested on the constructor.
  
  =item ssh_opts => \@opts
  
  List of extra options for the C<ssh> command.
  
  This feature should be used with care, as the given options are not
  checked in any way by the module, and they could interfere with it.
  
  =item tunnel => $bool
  
  Instead of executing a command in the remote host, this option
  instruct Net::OpenSSH to create a TCP tunnel. The arguments become the
  target IP and port or the remote path for an Unix socket.
  
  Example:
  
    my ($in, $out, undef, $pid) = $ssh->open_ex({tunnel => 1}, $IP, $port);
    my ($in, $out, undef, $pid) = $ssh->open_ex({tunnel => 1}, $socket_path);
  
  See also L</Tunnels>.
  
  =item subsystem => $bool
  
  Request a connection to a SSH subsystem. The name of the subsystem
  must be passed as an argument, as in the following example:
  
    my $s = $ssh->open2socket({subsystem => 1}, 'netconf');
  
  =item encoding => $encoding
  
  =item argument_encoding => $encoding
  
  Set encodings. See L</Data encoding>.
  
  =back
  
  Usage example:
  
    # similar to IPC::Open2 open2 function:
    my ($in_pipe, $out_pipe, undef, $pid) =
        $ssh->open_ex( { stdin_pipe => 1,
                         stdout_pipe => 1 },
                       @cmd )
        or die "open_ex failed: " . $ssh->error;
    # do some IO through $in/$out
    # ...
    waitpid($pid);
  
  =item setpgrp => 1
  
  Calls C<setpgrp> after forking the child process. As a result it will
  not die when the user presses Ctrl+C at the console. See also
  L<perlfunc/setpgrp>.
  
  Using this option without also setting C<master_setpgrp> on the
  constructor call is mostly useless as the signal will be delivered to
  the master process and all the remote commands aborted.
  
  This feature is experimental.
  
  =item $ssh->system(\%opts, @cmd)
  
  Runs the command C<@cmd> on the remote machine.
  
  Returns true on success, undef otherwise.
  
  The error status is set to C<OSSH_SLAVE_CMD_FAILED> when the remote
  command exits with a non zero code (the code is available from C<$?>,
  see L<perlvar/"$?">).
  
  Example:
  
    $ssh->system('ls -R /')
      or die "ls failed: " . $ssh->error";
  
  As for C<system> builtin, C<SIGINT> and C<SIGQUIT> signals are
  blocked.  (see L<perlfunc/system>). Also, setting C<$SIG{CHLD}> to
  C<IGNORE> or to a custom signal handler will interfere with this
  method.
  
  Accepted options:
  
  =over 4
  
  =item stdin_data => $input
  
  =item stdin_data => \@input
  
  Sends the given data through the stdin stream to the remote
  process.
  
  For example, the following code creates a file on the remote side:
  
    $ssh->system({stdin_data => \@data}, "cat >/tmp/foo")
      or die "unable to write file: " . $ssh->error;
  
  =item timeout => $timeout
  
  The operation is aborted after C<$timeout> seconds elapsed without
  network activity.
  
  See also L</Timeouts>.
  
  =item async => 1
  
  Does not wait for the child process to exit. The PID of the new
  process is returned.
  
  Note that when this option is combined with C<stdin_data>, the given
  data will be transferred to the remote side before returning control
  to the caller.
  
  See also the L</spawn> method documentation below.
  
  =item stdin_fh => $fh
  
  =item stdin_discard => $bool
  
  =item stdout_fh => $fh
  
  =item stdout_discard => $bool
  
  =item stderr_fh => $fh
  
  =item stderr_discard => $bool
  
  =item stderr_to_stdout => $bool
  
  =item stdinout_dpipe => $cmd
  
  =item tty => $bool
  
  See the L</open_ex> method documentation for an explanation of these
  options.
  
  =item stdin_keep_open => $bool
  
  When C<stdin_data> is given, the module closes the stdin stream once
  all the data has been sent. Unfortunately, some SSH buggy servers fail
  to handle this event correctly and close the channel prematurely.
  
  As a workaround, when this flag is set the stdin is left open until
  the remote process terminates.
  
  =back
  
  =item $ok = $ssh->test(\%opts, @cmd);
  
  Runs the given command and returns its success/failure exit status as
  1 or 0 respectively. Returns undef when something goes wrong in the
  SSH layer.
  
  Error status is not set to OSSH_SLAVE_CMD_FAILED when the remote
  command exits with a non-zero code.
  
  By default this method discards the remote command C<stdout> and
  C<sterr> streams.
  
  Usage example:
  
    if ($ssh->test(ps => -C => $executable)) {
      say "$executable is running on remote machine"
    }
    else {
      die "something got wrong: ". $ssh->error if $ssh->error;
  
      say "$executable is not running on remote machine"
    }
  
  This method support the same set of options as C<system>, except
  C<async> and C<tunnel>.
  
  =item $output = $ssh->capture(\%opts, @cmd);
  
  =item @output = $ssh->capture(\%opts, @cmd);
  
  This method is conceptually equivalent to the perl backquote operator
  (e.g. C<`ls`>): it runs the command on the remote machine and captures
  its output.
  
  In scalar context returns the output as a scalar. In list context
  returns the output broken into lines (it honors C<$/>, see
  L<perlvar/"$/">).
  
  The exit status of the remote command is returned in C<$?>.
  
  When an error happens while capturing (for instance, the operation
  times out), the partial captured output will be returned. Error
  conditions have to be explicitly checked using the L</error>
  method. For instance:
  
    my $output = $ssh->capture({ timeout => 10 },
                               "echo hello; sleep 20; echo bye");
    $ssh->error and
        warn "operation didn't complete successfully: ". $ssh->error;
    print $output;
  
  Setting C<$SIG{CHLD}> to a custom signal handler or to C<IGNORE> will
  interfere with this method.
  
  Accepted options:
  
  =over 4
  
  =item stdin_data => $input
  
  =item stdin_data => \@input
  
  =item stdin_keep_open => $bool
  
  See the L</system> method documentation for an explanation of these
  options.
  
  =item timeout => $timeout
  
  See L</Timeouts>.
  
  =item stdin_fh => $fh
  
  =item stdin_discard => $bool
  
  =item stderr_fh => $fh
  
  =item stderr_discard => $bool
  
  =item stderr_to_stdout => $bool
  
  =item tty => $bool
  
  See the L</open_ex> method documentation for an explanation of these
  options.
  
  =back
  
  =item ($output, $errput) = $ssh->capture2(\%opts, @cmd)
  
  captures the output sent to both stdout and stderr by C<@cmd> on the
  remote machine.
  
  Setting C<$SIG{CHLD}> to a custom signal handler or to C<IGNORE> will
  also interfere with this method.
  
  The accepted options are:
  
  =over 4
  
  =item stdin_data => $input
  
  =item stdin_data => \@input
  
  =item stdin_keep_open => $bool
  
  See the L</system> method documentation for an explanation of these
  options.
  
  =item timeout => $timeout
  
  See L</Timeouts>.
  
  =item stdin_fh => $fh
  
  =item stdin_discard => $bool
  
  =item tty => $bool
  
  See the L</open_ex> method documentation for an explanation of these
  options.
  
  =back
  
  =item ($in, $pid) = $ssh->pipe_in(\%opts, @cmd)
  
  X<pipe_in>This method is similar to the following Perl C<open> call
  
    $pid = open $in, '|-', @cmd
  
  but running @cmd on the remote machine (see L<perlfunc/open>).
  
  No options are currently accepted.
  
  There is no need to perform a waitpid on the returned PID as it will
  be done automatically by perl when C<$in> is closed.
  
  Example:
  
    my ($in, $pid) = $ssh->pipe_in('cat >/tmp/fpp')
        or die "pipe_in failed: " . $ssh->error;
    print $in $_ for @data;
    close $in or die "close failed";
  
  =item ($out, $pid) = $ssh->pipe_out(\%opts, @cmd)
  
  X<pipe_out>Reciprocal to previous method, it is equivalent to
  
    $pid = open $out, '-|', @cmd
  
  running @cmd on the remote machine.
  
  No options are currently accepted.
  
  =item ($in, $out, $pid) = $ssh->open2(\%opts, @cmd)
  
  =item ($pty, $pid) = $ssh->open2pty(\%opts, @cmd)
  
  =item ($socket, $pid) = $ssh->open2socket(\%opts, @cmd)
  
  =item ($in, $out, $err, $pid) = $ssh->open3(\%opts, @cmd)
  
  =item ($pty, $err, $pid) = $ssh->open3pty(\%opts, @cmd)
  
  Shortcuts around L</open_ex> method.
  
  =item $pid = $ssh->spawn(\%opts, @_)
  
  X<spawn>Another L</open_ex> shortcut, it launches a new remote process
  in the background and returns the PID of the local slave SSH process.
  
  At some later point in your script, C<waitpid> should be called on the
  returned PID in order to reap the slave SSH process.
  
  For instance, you can run some command on several hosts in parallel
  with the following code:
  
    my %conn = map { $_ => Net::OpenSSH->new($_, async => 1) } @hosts;
    my @pid;
    for my $host (@hosts) {
        open my($fh), '>', "/tmp/out-$host.txt"
          or die "unable to create file: $!";
        push @pid, $conn{$host}->spawn({stdout_fh => $fh}, $cmd);
    }
  
    waitpid($_, 0) for @pid;
  
  Note that C<spawn> should not be used to start detached remote
  processes that may survive the local program (see also the L</FAQ>
  about running remote processes detached).
  
  =item ($socket, $pid) = $ssh->open_tunnel(\%opts, $dest_host, $port)
  
  =item ($socket, $pid) = $ssh->open_tunnel(\%opts, $socket_path)
  
  X<open_tunnel>Similar to L</open2socket>, but instead of running a
  command, it opens a TCP tunnel to the given address. See also
  L</Tunnels>.
  
  =item $out = $ssh->capture_tunnel(\%opts, $dest_host, $port)
  
  =item @out = $ssh->capture_tunnel(\%opts, $dest_host, $port)
  
  X<capture_tunnel>Similar to L</capture>, but instead of running a command, it opens a
  TCP tunnel.
  
  Example:
  
    $out = $ssh->capture_tunnel({stdin_data => join("\r\n",
                                                    "GET / HTTP/1.0",
                                                    "Host: www.perl.org",
                                                    "", "") },
                                'www.perl.org', 80)
  
  See also L</Tunnels>.
  
  =item $ssh->scp_get(\%opts, $remote1, $remote2,..., $local_dir_or_file)
  
  =item $ssh->scp_put(\%opts, $local, $local2,..., $remote_dir_or_file)
  
  These two methods are wrappers around the C<scp> command that allow
  transfers of files to/from the remote host using the existing SSH
  master connection.
  
  When transferring several files, the target argument must point to an
  existing directory. If only one file is to be transferred, the target
  argument can be a directory or a file name or can be omitted. For
  instance:
  
    $ssh->scp_get({glob => 1}, '/var/tmp/foo*', '/var/tmp/bar*', '/tmp');
    $ssh->scp_put('/etc/passwd');
  
  Both L</scp_get> and L</scp_put> methods return a true value when all
  the files are transferred correctly, otherwise they return undef.
  
  Accepted options:
  
  =over 4
  
  =item quiet => 0
  
  By default, C<scp> is called with the quiet flag C<-q> enabled in
  order to suppress progress information. This option allows one to
  re-enable the progress indication bar.
  
  =item verbose => 1
  
  Calls C<scp> with the C<-v> flag.
  
  =item recursive => 1
  
  Copies files and directories recursively.
  
  =item glob => 1
  
  Enables expansion of shell metacharacters in the sources list so that
  wildcards can be used to select files.
  
  =item glob_flags => $flags
  
  Second argument passed to L<File::Glob::bsd_glob|File::Glob/bsd_glob>
  function. Only available for L</scp_put> method.
  
  =item copy_attrs => 1
  
  Copies modification and access times and modes from the original
  files.
  
  =item bwlimit => $Kbits
  
  Limits the used bandwidth, specified in Kbit/s.
  
  =item timeout => $secs
  
  The transfer is aborted if the connection does not finish before the
  given timeout elapses. See also L</Timeouts>.
  
  =item async => 1
  
  Does not wait for the C<scp> command to finish. When this option is
  used, the method returns the PID of the child C<scp> process.
  
  For instance, it is possible to transfer files to several hosts in
  parallel as follows:
  
    use Errno;
    my (%pid, %ssh);
    for my $host (@hosts) {
      $ssh{$host} = Net::OpenSSH->new($host, async => 1);
    }
    for my $host (@hosts) {
      $pid{$host} = $ssh{$host}->scp_put({async => 1}, $local_fn, $remote_fn)
        or warn "scp_put to $host failed: " . $ssh{$host}->error . "\n";
    }
    for my $host (@hosts) {
      if (my $pid = $pid{$host}) {
        if (waitpid($pid, 0) > 0) {
          my $exit = ($? >> 8);
          $exit and warn "transfer of file to $host failed ($exit)\n";
        }
        else {
          redo if ($! == EINTR);
          warn "waitpid($pid) failed: $!\n";
        }
      }
    }
  
  =item stdout_fh => $fh
  
  =item stderr_fh => $fh
  
  =item stderr_to_stdout => 1
  
  These options are passed unchanged to method L</open_ex>, allowing
  capture of the output of the C<scp> program.
  
  Note that C<scp> will not generate progress reports unless its stdout
  stream is attached to a tty.
  
  =item ssh_opts => \@opts
  
  List of extra options for the C<ssh> command.
  
  This feature should be used with care, as the given options are not
  checked in any way by the module, and they could interfere with it.
  
  =back
  
  =item $ssh->rsync_get(\%opts, $remote1, $remote2,..., $local_dir_or_file)
  
  =item $ssh->rsync_put(\%opts, $local1, $local2,..., $remote_dir_or_file)
  
  These methods use C<rsync> over SSH to transfer files from/to the remote
  machine.
  
  They accept the same set of options as the C<scp> ones.
  
  Any unrecognized option will be passed as an argument to the C<rsync>
  command (see L<rsync(1)>). Underscores can be used instead of dashes
  in C<rsync> option names.
  
  For instance:
  
    $ssh->rsync_get({exclude => '*~',
                     verbose => 1,
                     safe_links => 1},
                    '/remote/dir', '/local/dir');
  
  =item $sftp = $ssh->sftp(%sftp_opts)
  
  X<Net_SFTP_Foreign>Creates a new L<Net::SFTP::Foreign|Net::SFTP::Foreign> object
  for SFTP interaction that runs through the ssh master connection.
  
  =item @call = $ssh->make_remote_command(\%opts, @cmd)
  
  =item $call = $ssh->make_remote_command(\%opts, @cmd)
  
  This method returns the arguments required to execute a command on the
  remote machine via SSH. For instance:
  
    my @call = $ssh->make_remote_command(ls => "/var/log");
    system @call;
  
  In scalar context, returns the arguments quoted and joined into one
  string:
  
    my $remote = $ssh->make_remote_comand("cd /tmp/ && tar xf -");
    system "tar cf - . | $remote";
  
  The options accepted are as follows:
  
  =over 4
  
  =item tty => $bool
  
  Enables/disables allocation of a tty on the remote side.
  
  =item forward_agent => $bool
  
  Enables/disables forwarding of authentication agent.
  
  This option can only be used when agent forwarding has been previously
  requested on the constructor.
  
  =item tunnel => 1
  
  Return a command to create a connection to some TCP server reachable
  from the remote host. In that case the arguments are the destination
  address and port. For instance:
  
    $cmd = $ssh->make_remote_command({tunnel => 1}, $host, $port);
  
  =item subsystem => 1
  
  Return a command for invoking a SSH subsystem (i.e. SFTP or
  netconf). In that case the only argument is the subsystem name.
  
  =back
  
  =item $ssh->wait_for_master($async)
  
  When the connection has been established by calling the constructor
  with the C<async> option, this call allows one to advance the process.
  
  If C<$async> is true, it will perform any work that can be done
  immediately without waiting (for instance, entering the password or
  checking for the existence of the multiplexing socket) and then
  return. If a false value is given, it will finalize the connection
  process and wait until the multiplexing socket is available.
  
  It returns a true value after the connection has been successfully
  established. False is returned if the connection process fails or if
  it has not yet completed (then, the L</error> method can be used to
  distinguish between both cases).
  
  From version 0.64 upwards, undef is returned when the master is still
  in an unstable state (login, killing, etc.) and 0 when it is in a
  stable state (running, stopped or gone).
  
  =item $ssh->check_master
  
  This method runs several checks to ensure that the master connection
  is still alive.
  
  =item $ssh->shell_quote(@args)
  
  Returns the list of arguments quoted so that they will be restored to
  their original form when parsed by the remote shell.
  
  In scalar context returns the list of arguments quoted and joined.
  
  Usually this task is done automatically by the module. See L</"Shell
  quoting"> below.
  
  This method can also be used as a class method.
  
  Example:
  
    my $quoted_args = Net::OpenSSH->shell_quote(@args);
    system('ssh', '--', $host, $quoted_args);
  
  =item $ssh->shell_quote_glob(@args)
  
  This method is like the previous C<shell_quote> but leaves wildcard
  characters unquoted.
  
  It can be used as a class method also.
  
  =item $ssh->set_expand_vars($bool)
  
  Enables/disables variable expansion feature (see L</"Variable
  expansion">).
  
  =item $ssh->get_expand_vars
  
  Returns current state of variable expansion feature.
  
  =item $ssh->set_var($name, $value)
  
  =item $ssh->get_var($name, $value)
  
  These methods allow one to change and to retrieve the value of the
  given name.
  
  =item $ssh->get_master_pid
  
  Returns the PID of the master SSH process
  
  =item $ssh->master_exited
  
  This methods allows one to tell the module that the master process has
  exited when we get its PID from some external wait or waitpid
  call. For instance:
  
    my $ssh = Net::OpenSSH->new('foo', async => 1);
  
    # create new processes
    # ...
  
    # rip them...
    my $master_pid = $ssh->master_pid;
    while ((my $pid = wait) > 0) {
      if ($pid == $master_pid) {
        $ssh->master_exited;
      }
    }
  
  If your program rips the master process and this method is not called,
  the OS could reassign the PID to a new unrelated process and the
  module would try to kill it at object destruction time.
  
  =item $ssh->disconnect($async)
  
  Shuts down the SSH connection.
  
  Usually, you don't need to call this method explicitly, but just let
  the Net::OpenSSH object go out of scope.
  
  If C<async> is true, it doesn't wait for the SSH connection to
  terminate. In that case, L</wait_for_master> must be called repeatedly
  until the shutdown sequence terminates (See the L</AnyEvent>
  integration section below).
  
  =item $ssh->restart($async)
  
  Restarts the SSH session closing any open connection and creating a
  new one. Any open channel would also be killed.
  
  Note that calling this method may request again the password or
  passphrase from the user.
  
  In asynchronous mode, this method requires the connection to be
  terminated before it gets called. Afterwards, C<wait_for_master>
  should be called repeatedly until the new connection is established.
  For instance:
  
    my $async = 1;
    $ssh->disconnect($async);
    while (1) {
      defined $ssh->wait_for_master($async) # returns 0 when the
                                            # disconnect process
                                            # finishes
        and last;
      do_something_else();
    }
    $ssh->restart($async);
    while (1) {
      defined $ssh->wait_for_master($async)
        and last;
      do_something_else();
    }
  
  
  =item $pid = $ssh->sshfs_import(\%opts, $remote_fs, $local_mnt_point)
  
  =item $pid = $ssh->sshfs_export(\%opts, $local_fs, $remote_mnt_point)
  
  These methods use L<sshfs(1)> to import or export a file system
  through the SSH connection.
  
  They return the C<$pid> of the C<sshfs> process or of the slave C<ssh>
  process used to proxy it. Killing that process unmounts the file
  system, though, it may be probably better to use L<fusermount(1)>.
  
  The options accepted are as follows:
  
  =over
  
  =item ssh_opts => \@ssh_opts
  
  Options passed to the slave C<ssh> process.
  
  =item sshfs_opts => \@sshfs_opts
  
  Options passed to the C<sshfs> command. For instance, to mount the file
  system in read-only mode:
  
    my $pid = $ssh->sshfs_export({sshfs_opts => [-o => 'ro']},
                                 "/", "/mnt/foo");
  
  =back
  
  Note that this command requires a recent version of C<sshfs> to work (at
  the time of writing, it requires the yet unreleased version available
  from the FUSE git repository!).
  
  See also the L<sshfs(1)> man page and the C<sshfs> and FUSE web sites
  at L<https://github.com/libfuse/sshfs> and
  L<https://github.com/libfuse/libfuse> respectively.
  
  =item $or = $ssh->object_remote(@args)
  
  X<Object_Remote>Returns an L<Object::Remote::Connection> instance
  running on top of the Net::OpenSSH connection.
  
  Example:
  
     my $or = $ssh->object_remote;
     my $hostname = Sys::Hostname->can::on($or, 'hostname');
     say $hostname->();
  
  See also L<Object::Remote>.
  
  =item $any = $ssh->any(%opts)
  
  X<Net_SSH_Any>Wraps the current object inside a Net::SSH::Any one.
  
  Example:
  
    my $any = $ssh->any;
    my $content = $any->scp_get_content("my-file.txt");
  
  =item $pid = $ssh->disown_master
  
  Under normal operation Net::OpenSSH controls the life-time of the
  master C<ssh> process and when the object is destroyed the master
  process and any connection running over it are terminated.
  
  In some (rare) cases, it is desirable to let the master process and
  all the running connections survive. Calling this method does just
  that, it tells Net::OpenSSH object that the master process is not its
  own anymore.
  
  The return value is the PID of the master process.
  
  Note also that disowning the master process does not affect the
  operation of the module in any other regard.
  
  For instance:
  
    # See examples/sshfs_mount.pl for a working program
    my $ssh = Net::OpenSSH->new($host);
    my $sshfs_pid = $ssh->sshfs_import("/home/foo", "my-remote-home");
    $ssh->disown_master;
    $ssh->stop; # tells the master to stop accepting requests
    exit(0);
  
  
  =item $ssh->default_ssh_configuration
  
  Allows one to retrieve the default SSH configuration for the target
  host from system files (i.e. C</etc/ssh/ssh_config>) and user files
  (C<~/.ssh/config>).
  
  Under the hood, this method just calls C<ssh -G $host> and returns the
  output unprocessed.
  
  Example:
  
    my $ssh = Net::OpenSSH->new($host, connect => 0);
    my $txt = $ssh->default_ssh_configuration;
    my @lines = split /^/m, $txt;
    chomp @lines;
    my %def_cfg = map split(/\s+/, $_, 2), @lines;
  
  =back
  
  =head2 Shell quoting
  
  By default, when invoking remote commands, this module tries to mimic
  perl C<system> builtin in regard to argument processing. Quoting
  L<perlfunc/system>:
  
    Argument processing varies depending on the number of arguments.  If
    there is more than one argument in LIST, or if LIST is an array with
    more than one value, starts the program given by the first element
    of the list with arguments given by the rest of the list.  If there
    is only one scalar argument, the argument is checked for shell
    metacharacters, and if there are any, the entire argument is passed
    to the system's command shell for parsing (this is "/bin/sh -c" on
    Unix platforms, but varies on other platforms).
  
  Take for example Net::OpenSSH L</system> method:
  
    $ssh->system("ls -l *");
    $ssh->system('ls', '-l', '/');
  
  The first call passes the argument unchanged to ssh and it is executed
  in the remote side through the shell which interprets metacharacters.
  
  The second call escapes any shell metacharacters so that, effectively,
  it is equivalent to calling the command directly and not through the
  shell.
  
  Under the hood, as the Secure Shell protocol does not provide for this
  mode of operation and always spawns a new shell where it runs the
  given command, Net::OpenSSH quotes any shell metacharacters in the
  command list.
  
  All the methods that invoke a remote command (system, open_ex, etc.)
  accept the option C<quote_args> that allows one to force/disable shell
  quoting.
  
  For instance:
  
    $ssh->system({quote_args => 1}, "/path with spaces/bin/foo");
  
  will correctly handle the spaces in the program path.
  
  The shell quoting mechanism implements some extensions (for instance,
  performing redirections to /dev/null on the remote side) that can be
  disabled with the option C<quote_args_extended>:
  
    $ssh->system({ stderr_discard => 1,
                   quote_args => 1, quote_args_extended => 0 },
                 @cmd);
  
  The option C<quote_args> can also be used to disable quoting when more
  than one argument is passed. For instance, to get some pattern
  expanded by the remote shell:
  
    $ssh->system({quote_args => 0}, 'ls', '-l', "/tmp/files_*.dat");
  
  The method C<shell_quote> can be used to selectively quote some
  arguments and leave others untouched:
  
    $ssh->system({quote_args => 0},
                 $ssh->shell_quote('ls', '-l'),
                 "/tmp/files_*.dat");
  
  When the glob option is set in C<scp> and C<rsync> file transfer
  methods, an alternative quoting method which knows about file
  wildcards and passes them unquoted is used. The set of wildcards
  recognized currently is the one supported by L<bash(1)>.
  
  Another way to selectively use quote globing or fully disable quoting
  for some specific arguments is to pass them as scalar references or
  double scalar references respectively. In practice, that means
  prepending them with one or two backslashes. For instance:
  
    # quote the last argument for globing:
    $ssh->system('ls', '-l', \'/tmp/my files/filed_*dat');
  
    # append a redirection to the remote command
    $ssh->system('ls', '-lR', \\'>/tmp/ls-lR.txt');
  
    # expand remote shell variables and glob in the same command:
    $ssh->system('tar', 'czf', \\'$HOME/out.tgz', \'/var/log/server.*.log');
  
  As shell quoting is a tricky matter, I expect bugs to appear in this
  area. You can see how C<ssh> is called, and the quoting used setting
  the following debug flag:
  
    $Net::OpenSSH::debug |= 16;
  
  By default, the module assumes the remote shell is some variant of a
  POSIX or Bourne shell (C<bash>, C<dash>, C<ksh>, etc.). If this is not
  the case, the construction option C<remote_shell> can be used to
  select an alternative quoting mechanism.
  
  For instance:
  
    $ssh = Net::OpenSSH->new($host, remote_shell => 'csh');
    $ssh->system(echo => "hard\n to\n  quote\n   argument!");
  
  Currently there are quoters available for POSIX (Bourne) compatible
  shells, C<csh> and the two Windows variants C<MSWin> (for servers
  using L<Win32::CreateProcess>, see
  L<Net::OpenSSH::ShellQuoter::MSWin>) and C<MSCmd> (for servers using
  C<cmd.exe>, see L<Net::OpenSSH::ShellQuoter::MSCmd>).
  
  In any case, you can always do the quoting yourself and pass the
  quoted remote command as a single string:
  
    # for VMS
    $ssh->system('DIR/SIZE NFOO::USERS:[JSMITH.DOCS]*.TXT;0');
  
  Note that the current quoting mechanism does not handle possible
  aliases defined by the remote shell. In that case, to force execution
  of the command instead of the alias, the full path to the command must
  be used.
  
  =head2 Timeouts
  
  In order to stop remote processes when they timeout, the ideal approach
  would be to send them signals through the SSH connection as specified
  by the protocol standard.
  
  Unfortunately OpenSSH does not implement that feature so Net::OpenSSH
  has to use other imperfect approaches:
  
  =over 4
  
  =item * close slave I/O streams
  
  Closing the STDIN and STDOUT streams of the unresponsive remote
  process will effectively deliver a SIGPIPE when it tries to access any
  of them.
  
  Remote processes may not access STDIN or STDOUT and even then,
  Net::OpenSSH can only close these channels when it is capturing them,
  so this approach does not always work.
  
  =item * killing the local SSH slave process
  
  This action may leave the remote process running, creating a remote
  orphan so Net::OpenSSH does not use it unless the construction option
  C<kill_ssh_on_timeout> is set.
  
  =back
  
  Luckily, future versions of OpenSSH will support signaling remote
  processes via the mux channel.
  
  =head2 Variable expansion
  
  The variable expansion feature allows one to define variables that are
  expanded automatically inside command arguments and file paths.
  
  This feature is disabled by default. It is intended to be used with
  L<Net::OpenSSH::Parallel|Net::OpenSSH::Parallel> and other similar
  modules.
  
  Variables are delimited by a pair of percent signs (C<%>), for
  instance C<%HOST%>. Also, two consecutive percent signs are replaced
  by a single one.
  
  The special variables C<HOST>, C<USER> and C<PORT> are maintained
  internally by the module and take the obvious values.
  
  Variable expansion is performed before shell quoting (see L</"Shell
  quoting">).
  
  Some usage example:
  
    my $ssh = Net::OpenSSH->new('server.foo.com', expand_vars => 1);
    $ssh->set_var(ID => 42);
    $ssh->system("ls >/tmp/ls.out-%HOST%-%ID%");
  
  will redirect the output of the C<ls> command to
  C</tmp/ls.out-server.foo.com-42> on the remote host.
  
  =head2 Tunnels
  
  Besides running commands on the remote host, Net::OpenSSH also allows
  one to tunnel TCP connections to remote machines reachable from the
  SSH server.
  
  That feature is made available through the C<tunnel> option of the
  L</open_ex> method, and also through wrapper methods L</open_tunnel>
  and L</capture_tunnel> and most others where it makes sense.
  
  Example:
  
    $ssh->system({tunnel => 1,
                  stdin_data => "GET / HTTP/1.0\r\n\r\n",
                  stdout_file => "/tmp/$server.res"},
                 $server, 80)
        or die "unable to retrieve page: " . $ssh->error;
  
  or capturing the output of several requests in parallel:
  
    my @pids;
    for (@servers) {
      my $pid = $ssh->spawn({tunnel => 1,
                             stdin_file => "/tmp/request.req",
                             stdout_file => "/tmp/$_.res"},
                            $_, 80);
      if ($pid) {
        push @pids, $pid;
      }
      else {
        warn "unable to spawn tunnel process to $_: " . $ssh->error;
      }
    }
    waitpid ($_, 0) for (@pids);
  
  Under the hood, in order to create a tunnel, a new C<ssh> process is
  spawned with the option C<-W${address}:${port}> (available from
  OpenSSH 5.4 and upwards) making it redirect its stdio streams to the
  remote given address. Unlike when C<ssh> C<-L> options is used to
  create tunnels, no TCP port is opened on the local machine at any time
  so this is a perfectly secure operation.
  
  The PID of the new process is returned by the named methods. It must
  be reaped once the pipe or socket handlers for the local side of the
  tunnel have been closed.
  
  OpenSSH 5.4 or later is required for the tunnels functionality to
  work. Also, note that tunnel forwarding may be administratively
  forbidden at the server side (see L<sshd(8)> and L<sshd_config(5)> or
  the documentation provided by your SSH server vendor).
  
  =head3 Tunnels targeting UNIX sockets
  
  When connecting to hosts running a recent version of OpenSSH sshd, it
  is also possible to open connections targeting Unix sockets.
  
  For instance:
  
    my $response = $ssh->capture({tunnel => 1, stdin_data => $request },
                                 "/tmp/socket-foo");
  
  Currently, this feature requires a patched OpenSSH ssh client. The
  patch is available as
  C<patches/openssh-fwd-stdio-to-streamlocal-1.patch>.
  
  =head3 Port forwarding
  
  L<Net::OpenSSH> does not offer direct support for handling port
  forwardings between server and client. But that can be done easily
  anyway passing custom SSH options to its methods.
  
  For instance, tunnel creation options can be passed to the constructor:
  
    my $ssh = Net::OpenSSH->new(...
                      master_opts => -Llocalhost:1234:localhost:3306');
  
  The port forwardings can also be changed for a running SSH connection
  using a Control command:
  
      # setting up a tunnel:
      $ssh->system({ssh_opts => ['-O','forward',
                                 '-L127.0.0.1:12345:127.0.0.1:3306']});
  
      # canceling it:
      $ssh->system({ssh_opts => ['-O', 'cancel',
                                 '-L127.0.0.1:12345:127.0.0.1:3306']});
  
  =head2 Data encoding
  
  Net::OpenSSH has some support for transparently converting the data send
  or received from the remote server to Perl internal unicode
  representation.
  
  The methods supporting that feature are those that move data from/to
  Perl data structures (e.g. C<capture>, C<capture2>, C<capture_tunnel>
  and methods supporting the C<stdin_data> option). Data accessed through
  pipes, sockets or redirections is not affected by the encoding options.
  
  It is also possible to set the encoding of the command and arguments
  passed to the remote server on the command line.
  
  By default, if no encoding option is given on the constructor or on the
  method calls, Net::OpenSSH will not perform any encoding transformation,
  effectively processing the data as C<latin1>.
  
  When data can not be converted between the Perl internal
  representation and the selected encoding inside some Net::OpenSSH
  method, it will fail with an C<OSSH_ENCODING_ERROR> error.
  
  The supported encoding options are as follows:
  
  =over 4
  
  =item stream_encoding => $encoding
  
  sets the encoding of the data send and received on capture methods.
  
  =item argument_encoding => $encoding
  
  sets the encoding of the command line arguments
  
  =item encoding => $encoding
  
  sets both C<argument_encoding> and C<stream_encoding>.
  
  =back
  
  The constructor also accepts C<default_encoding>,
  C<default_stream_encoding> and C<default_argument_encoding> that set the
  defaults.
  
  =head2 Diverting C<new>
  
  When a code ref is installed at C<$Net::OpenSSH::FACTORY>, calls to new
  will be diverted through it.
  
  That feature can be used to transparently implement connection
  caching, for instance:
  
    my $old_factory = $Net::OpenSSH::FACTORY;
    my %cache;
  
    sub factory {
      my ($class, %opts) = @_;
      my $signature = join("\0", $class, map { $_ => $opts{$_} }, sort keys %opts);
      my $old = $cache{signature};
      return $old if ($old and $old->error != OSSH_MASTER_FAILED);
      local $Net::OpenSSH::FACTORY = $old_factory;
      $cache{$signature} = $class->new(%opts);
    }
  
    $Net::OpenSSH::FACTORY = \&factory;
  
  ... and I am sure it can be abused in several other ways!
  
  
  =head1 3rd PARTY MODULE INTEGRATION
  
  =head2 Expect
  
  Sometimes you would like to use L<Expect> to control some program
  running in the remote host. You can do it as follows:
  
    my ($pty, $pid) = $ssh->open2pty(@cmd)
        or die "unable to run remote command @cmd";
    my $expect = Expect->init($pty);
  
  Then, you will be able to use the new Expect object in C<$expect> as
  usual.
  
  =head2 Net::Telnet
  
  This example is adapted from L<Net::Telnet> documentation:
  
    my ($pty, $pid) = $ssh->open2pty({stderr_to_stdout => 1})
      or die "unable to start remote shell: " . $ssh->error;
    my $telnet = Net::Telnet->new(-fhopen => $pty,
                                  -prompt => '/.*\$ $/',
                                  -telnetmode => 0,
                                  -cmd_remove_mode => 1,
                                  -output_record_separator => "\r");
  
    $telnet->waitfor(-match => $telnet->prompt,
                     -errmode => "return")
      or die "login failed: " . $telnet->lastline;
  
    my @lines = $telnet->cmd("who");
  
    ...
  
    $telnet->close;
    waitpid($pid, 0);
  
  =head2 mod_perl and mod_perl2
  
  L<mod_perl> and L<mod_perl2> tie STDIN and STDOUT to objects that are
  not backed up by real file descriptors at the operating system
  level. Net::OpenSSH will fail if any of these handles is used
  explicitly or implicitly when calling some remote command.
  
  The work-around is to redirect them to C</dev/null> or to some file:
  
    open my $def_in, '<', '/dev/null' or die "unable to open /dev/null";
    my $ssh = Net::OpenSSH->new($host,
                                default_stdin_fh => $def_in);
  
    my $out = $ssh->capture($cmd1);
    $ssh->system({stdout_discard => 1}, $cmd2);
    $ssh->system({stdout_to_file => '/tmp/output'}, $cmd3);
  
  Also, note that from a security stand point, running C<ssh> from
  inside the web server process is not a great idea. An attacker
  exploiting some Apache bug would be able to access the SSH keys and
  passwords and gain unlimited access to the remote systems.
  
  If you can, use a queue (as L<TheSchwartz|TheSchwartz>) or any other
  mechanism to execute the ssh commands from another process running
  under a different user account.
  
  At a minimum, ensure that C<~www-data/.ssh> (or similar) is not
  accessible through the web server!
  
  =head2 Net::SFTP::Foreign
  
  See L<method C<sftp>|/Net_SFTP_Foreign>.
  
  =head2 Net::SSH::Any
  
  See L<method C<any>|/Net_SSH_Any>.
  
  =head2 Object::Remote
  
  See L<method C<object_remote>|/Object_Remote>.
  
  =head2 AnyEvent (and similar frameworks)
  
  X<AnyEvent>Net::OpenSSH provides all the functionality required to be
  integrated inside event oriented programming framework such as
  L<AnyEvent> or L<IO::Async> in the following way:
  
  =over 4
  
  =item 1. Create a disconnected Net::OpenSSH object:
  
      my $ssh = Net::OpenSSH->new($host, async => 1, ...);
  
  =item 2. Let the object connect to the remote host:
  
  Use a timer to call the C<wait_for_master> method in async mode
  repeatedly until it returns a true value indicating success.
  
  Also, the object error state needs to be checked after every call in
  order to detect failed connections. For instance:
  
    my $ssh = Net::OpenSSH->new(..., async => 1);
    my $w;
    $w = AE::timer 0.1, 0.1, sub {
      if ($ssh->wait_for_master(1)) {
        # the connection has been established!
        # remote commands can be run now
        undef $w;
        on_ssh_success(...);
      }
      elsif ($ssh->error) {
        # connection can not be established
        undef $w;
        on_ssh_failure(...);
      }
    }
  
  =item 3. Use the event framework to launch the remote processes:
  
  Call Net::OpenSSH C<make_remote_command> to construct commands which
  can be run using the framework regular facilities for launching external
  commands.
  
  Error checking should also be performed at this point because the SSH
  connection could be broken.
  
  For instance:
  
    if (defined(my $cmd = $ssh->make_remote_command(echo => 'hello!')) {
      AnyEvent::Util::run_cmd($cmd, %run_cmd_opts);
    }
    else {
      # something went wrong!
    }
  
  Alternatively, any of the C<open*> methods provided by Net::OpenSSH
  could also be used to launch remote commands.
  
  =item 4. When finished, disconnect asynchronously
  
  After initiating an asynchronous disconnect with C<disconnect(1)>,
  repeatedly call C<wait_for_master> until you get a defined but false
  value:
  
    $ssh->disconnect(1);
  
    my $w; $w = AE::timer 0.1, 0.1, sub {
      my $res = $ssh->wait_for_master(1);
  
      if (defined $res && !$res) {
        undef $w;
        undef $ssh;
      }
    };
  
  Be careful not to let the C<$ssh> object go out of scope until the
  disconnection has finished, otherwise its destructor will wait and
  block your program until the disconnection has completed.
  
  =back
  
  =head2 Other modules
  
  CPAN contains several modules that rely on SSH to perform their duties
  as for example L<IPC::PerlSSH|IPC::PerlSSH> or
  L<GRID::Machine|GRID::Machine>.
  
  Often, it is possible to instruct them to go through a Net::OpenSSH
  multiplexed connection employing some available constructor
  option. For instance:
  
    use Net::OpenSSH;
    use IPC::PerlIPC;
    my $ssh = Net::OpenSSH->new(...);
    $ssh->error and die "unable to connect to remote host: " . $ssh->error;
    my @cmd = $ssh->make_remote_command('/usr/bin/perl');
    my $ipc = IPC::PerlSSH->new(Command => \@cmd);
    my @r = $ipc->eval('...');
  
  or...
  
    use GRID::Machine;
    ...
    my @cmd = $ssh->make_remote_command('/usr/bin/perl');
    my $grid = GRID::Machine->new(command => \@cmd);
    my $r = $grid->eval('print "hello world!\n"');
  
  In other cases, some kind of plugin mechanism is provided by the 3rd
  party modules to allow for different transports. The method C<open2>
  may be used to create a pair of pipes for transport in these cases.
  
  =head1 TROUBLESHOOTING
  
  Usually, Net::OpenSSH works out of the box, but when it fails, some
  users have a hard time finding the cause of the problem. This mini
  troubleshooting guide should help you to find and solve it.
  
  =over 4
  
  =item 1 - check the error message
  
  Add in your script, after the Net::OpenSSH constructor call, an error
  check:
  
    $ssh = Net::OpenSSH->new(...);
    $ssh->error and die "SSH connection failed: " . $ssh->error;
  
  The error message will tell what has gone wrong.
  
  =item 2 - Check the connection parameters
  
  Believe it or not, passing bad parameters to Net::OpenSSH turns to be
  one of the top causes of failures so check that you are using the
  right parameters.
  
  Specifically, if you are obtaining them from the outside, ensure that
  they don't have extra spaces or new lines attached (do you need to
  C<chomp>?).
  
  Passwords and URIs may contain C<$> or C<@> characters. If you have
  then hardcoded in your script, check that those are quoted properly
  (and BTW, use C<strict>).
  
  =item 3 - OpenSSH version
  
  Ensure that you have a version of C<ssh> recent enough:
  
    $ ssh -V
    OpenSSH_5.1p1 Debian-5, OpenSSL 0.9.8g 19 Oct 2007
  
  OpenSSH version 4.1 was the first to support the multiplexing feature
  and is the minimal required by the module to work. I advise you to use
  the latest OpenSSH (currently 7.5).
  
  The C<ssh_cmd> constructor option lets you select the C<ssh> binary to
  use. For instance:
  
    $ssh = Net::OpenSSH->new($host,
                             ssh_cmd => "/opt/OpenSSH/5.8/bin/ssh")
  
  Some hardware vendors (e.g. Sun, err... Oracle) include custom
  versions of OpenSSH bundled with the operating system. In principle,
  Net::OpenSSH should work with these SSH clients as long as they are
  derived from some version of OpenSSH recent enough. Anyway, my advise
  is to use the real OpenSSH software if you can!
  
  =item 4 - run ssh from the command line
  
  Check you can connect to the remote host using the same parameters you
  are passing to Net::OpenSSH. In particular, ensure that you are
  running C<ssh> as the same local user.
  
  If you are running your script from a web server, the user
  would probably be C<www>, C<apache> or something alike.
  
  Common problems are:
  
  =over 4
  
  =item *
  
  Remote host public key not present in known_hosts file.
  
  The SSH protocol uses public keys to identify the remote hosts so that
  they can not be supplanted by some malicious third parties.
  
  For OpenSSH, usually the server public key is stored in
  C</etc/ssh/ssh_host_dsa_key.pub> or in
  C</etc/ssh/ssh_host_rsa_key.pub> and that key should be copied into the
  C<~/.ssh/known_hosts> file in the local machine (other SSH
  implementations may use other file locations).
  
  Maintaining the server keys when several hosts and clients are
  involved may be somewhat inconvenient, so most SSH clients, by
  default, when a new connection is established to a host whose key is
  not in the C<known_hosts> file, show the key and ask the user if he
  wants the key copied there.
  
  =item *
  
  Wrong remote host public key in known_hosts file.
  
  This is another common problem that happens when some server is
  replaced or reinstalled from scratch and its public key changes
  becoming different to that installed on the C<known_hosts> file.
  
  The easiest way to solve that problem is to remove the old key from
  the C<known_hosts> file by hand using any editor and then to connect
  to the server replying C<yes> when asked to save the new key.
  
  =item *
  
  Wrong permissions for the C<~/.ssh> directory or its contents.
  
  OpenSSH client performs several checks on the access permissions of
  the C<~/.ssh> directory and its contents and refuses to use them when
  misconfigured. See the FILES section from the L<ssh(1)> man page.
  
  =item *
  
  Incorrect settings for password or public key authentication.
  
  Check that you are using the right password or that the user public
  key is correctly installed on the server.
  
  =back
  
  =item 5 - security checks on the multiplexing socket
  
  Net::OpenSSH performs some security checks on the directory where the
  multiplexing socket is going to be placed to ensure that it can not be
  accessed by other users.
  
  The default location for the multiplexing socket is under
  C<~/.libnet-openssh-perl>. It can be changed using the C<ctl_dir> and
  C<ctl_path> constructor arguments.
  
  The requirements for that directory and all its parents are:
  
  =over 4
  
  =item *
  
  They have to be owned by the user executing the script or by root
  
  =item *
  
  Their permission masks must be 0755 or more restrictive, so nobody
  else has permissions to perform write operations on them.
  
  =back
  
  The constructor option C<strict_mode> disables these security checks,
  but you should not use it unless you understand its implications.
  
  =item 6 - file system must support sockets
  
  Some file systems (as for instance FAT or AFS) do not support placing
  sockets inside them.
  
  Ensure that the C<ctl_dir> path does not lay into one of those file
  systems.
  
  =back
  
  =head1 DEBUGGING
  
  Debugging of Net::OpenSSH internals is controlled through the variable
  C<$Net::OpenSSH::debug>. Every bit of this variable activates
  debugging of some subsystem as follows:
  
  =over 4
  
  =item bit 1 - errors
  
  Dumps changes on the internal object attribute where errors are stored.
  
  =item bit 2 - ctl_path
  
  Dumps information about ctl_path calculation and the tests performed
  on that directory in order to decide if it is secure to place the
  multiplexing socket inside.
  
  =item bit 4 - connecting
  
  Dumps information about the establishment of new master connections.
  
  =item bit 8 - commands and arguments
  
  Dumps the command and arguments for every system/exec call.
  
  =item bit 16 - command execution
  
  Dumps information about the progress of command execution.
  
  =item bit 32 - destruction
  
  Dumps information about the destruction of Net::OpenSSH objects and
  the termination of the SSH master processes.
  
  =item bit 64 - IO loop
  
  Dumps information about the progress of the IO loop on capture
  operations.
  
  =item bit 128 - IO hexdumps
  
  Generates hexdumps of the information that travels through the SSH
  streams inside capture operations.
  
  =item bit 512 - OS tracing of the master process
  
  Use the module L<Net::OpenSSH::OSTracer> to trace the SSH master
  process at the OS level.
  
  =back
  
  For instance, in order to activate all the debugging flags, you can
  use:
  
    $Net::OpenSSH::debug = ~0;
  
  Note that the meaning of the flags and the information generated is
  only intended for debugging of the module and may change without
  notice between releases.
  
  If you are using password authentication, enabling debugging for
  L<IO::Tty> may also show interesting information:
  
      $IO::Tty::DEBUG = 1;
  
  Finally, by default debugging output is sent to C<STDERR>. You can
  override it pointing C<$Net::OpenSSH::debug_fh> to a different file
  handle. For instance:
  
    BEGIN {
      open my $out, '>', '/tmp/debug.txt' or warn $!;
      $Net::OpenSSH::debug_fh = $out;
      $Net::OpenSSH::debug = -1;
    }
  
  =head1 SECURITY
  
  B<Q>: Is this module secure?
  
  B<A>: Well, it tries to be!
  
  From a security standpoint the aim of this module is to be as secure
  as OpenSSH, your operating system, your shell and in general your
  environment allow it to be.
  
  It does not take any shortcut just to make your life easier if that
  means lowering the security level (for instance, disabling
  C<StrictHostKeyChecking> by default).
  
  In code supporting features that are not just proxied to OpenSSH,
  the module tries to keep the same standards of security as OpenSSH
  (for instance, checking directory and file permissions when placing
  the multiplexing socket).
  
  On the other hand, and keeping with OpenSSH philosophy, the module
  lets you disable most (all?) of those security measures. But just
  because it lets you do it it doesn't mean it is a good idea to do
  so!!!
  
  If you are a novice programmer or SSH user, and googling you have just
  found some flag that you don't understand but that seems to magically
  solve your connection problems... well, believe me, it is probably a
  bad idea to use it. Ask somebody how really knows first!
  
  Just to make thinks clear, if your code contains any of the keywords
  from the (non-exclusive) list below and you don't know why, you are
  probably wrecking the security of the SSH protocol:
  
    strict_mode
    StrictHostKeyChecking
    UserKnownHostsFile
  
  Other considerations related to security you may like to know are as
  follows:
  
  =over 4
  
  =item Taint mode
  
  The module supports working in taint mode.
  
  If you are in an exposed environment, you should probably enable it
  for your script in order to catch any unchecked command for being
  executed in the remote side.
  
  =item Web environments
  
  It is a bad idea to establish SSH connections from your webserver
  because if it becomes compromised in any way, the attacker would be
  able to use the credentials from your script to connect to the remote
  host and do anything he wishes there.
  
  =item Command quoting
  
  The module can quote commands and arguments for you in a flexible
  and powerful way.
  
  This is a feature you should use as it reduces the possibility of some
  attacker being able to inject and run arbitrary commands on the remote
  machine (and even for scripts that are not exposed it is always
  advisable to enable argument quoting).
  
  Having said that, take into consideration that argument-quoting is
  just a hack to emulate the invoke-without-a-shell feature of Perl
  builtins such as C<system> and alike. There may be bugs(*) on the
  quoting code, your particular shell may have different quoting rules
  with unhandled corner cases or whatever. If your script is exposed to
  the outside, you should check your inputs and restrict what you accept
  as valid.
  
  [* even if this is one of the parts of the module more intensively
  tested!]
  
  =item Shellshock
  
  (see L<Shellshock|http://en.wikipedia.org/wiki/Shellshock_%28software_bug%29>)
  
  When executing local commands, the module always avoids calling the
  shell so in this way it is not affected by Shellshock.
  
  Unfortunately, some commands (C<scp>, C<rsync> and C<ssh> when the
  C<ProxyCommand> option is used) invoke other commands under the hood
  using the user shell. That opens the door to local Shellshock
  exploitation.
  
  On the remote side invocation of the shell is unavoidable due to the
  protocol design.
  
  By default, SSH does not forward environment variables but some Linux
  distributions explicitly change the default OpenSSH configuration to
  enable forwarding and acceptance of some specific ones (for instance
  C<LANG> and C<LC_*> on Debian and derivatives, Fedora does alike) and
  this also opens the door to Shellshock exploitation.
  
  Note that the shell used to invoke commands is not C</bin/sh> but the
  user shell as configured in C</etc/passwd>, PAM or whatever
  authentication subsystem is used by the local or remote operating
  system. Debian users, don't think you are not affected because
  your C</bin/sh> points to C<dash>!
  
  =back
  
  =head1 FAQ
  
  Frequent questions about the module:
  
  =over
  
  =item Connecting to switches, routers, etc.
  
  B<Q>: I can not get the method C<system>, C<capture>, etc., to work
  when connecting to some router, switch, etc. What I am doing wrong?
  
  B<A>: Roughly, the SSH protocol allows for two modes of operation:
  command mode and interactive mode.
  
  Command mode is designed to run single commands on the remote host. It
  opens a SSH channel between both hosts, asks the remote computer to
  run some given command and when it finishes, the channel is closed. It
  is what you get, for instance, when you run something as...
  
    $ ssh my.unix.box cat foo.txt
  
  ... and it is also the way Net::OpenSSH runs commands on the remote
  host.
  
  Interactive mode launches a shell on the remote hosts with its stdio
  streams redirected to the local ones so that the user can
  transparently interact with it.
  
  Some devices (as probably the one you are using) do not run an
  standard, general purpose shell (e.g. C<bash>, C<csh> or C<ksh>) but
  some custom program specially targeted and limited to the task of
  configuring the device.
  
  Usually, the SSH server running on these devices does not support
  command mode. It unconditionally attaches the restricted shell to any
  incoming SSH connection and waits for the user to enter commands
  through the redirected stdin stream.
  
  The only way to work-around this limitation is to make your script
  talk to the restricted shell (1-open a new SSH session, 2-wait for the
  shell prompt, 3-send a command, 4-read the output until you get to the
  shell prompt again, repeat from 3). The best tool for this task is
  probably L<Expect>, used alone or combined with Net::OpenSSH (see
  L</Expect>).
  
  There are some devices that support command mode but that only accept
  one command per connection. In that cases, using L<Expect> is also
  probably the best option.
  
  Nowadays, there is a new player, L<Net::CLI::Interact> that may be
  more suitable than Expect, and L<Net::Appliance::Session> for working
  specifically with network devices.
  
  =item Connection fails
  
  B<Q>: I am unable to make the module connect to the remote host...
  
  B<A>: Have you read the troubleshooting section? (see
  L</TROUBLESHOOTING>).
  
  =item Disable StrictHostKeyChecking
  
  B<Q>: Why is C<ssh> not run with C<StrictHostKeyChecking=no>?
  
  B<A>: Using C<StrictHostKeyChecking=no> relaxes the default security
  level of SSH and it will be relatively easy to end with a
  misconfigured SSH (for instance, when C<known_hosts> is unwritable)
  that could be forged to connect to a bad host in order to perform
  man-in-the-middle attacks, etc.
  
  I advice you to do not use that option unless you fully understand its
  implications from a security point of view.
  
  If you want to use it anyway, past it to the constructor:
  
    $ssh = Net::OpenSSH->new($host,
             master_opts => [-o => "StrictHostKeyChecking=no"],
             ...);
  
  =item child process STDIN/STDOUT/STDERR is not a real system file
  handle
  
  B<Q>: Calls to C<system>, C<capture>, etc. fail with the previous
  error, what's happening?
  
  B<A>: The reported stdio stream is closed or is not attached to a real
  file handle (e.g. it is a tied handle). Redirect it to C</dev/null> or
  to a real file:
  
    my $out = $ssh->capture({stdin_discard => 1, stderr_to_stdout => 1},
                            $cmd);
  
  See also the L<mod_perl> entry above.
  
  =item Solaris (and AIX and probably others)
  
  B<Q>: I was trying Net::OpenSSH on Solaris and seem to be running into
  an issue...
  
  B<A>: The SSH client bundled with Solaris is an early fork of OpenSSH
  that does not provide the multiplexing functionality required by
  Net::OpenSSH. You will have to install the OpenSSH client.
  
  Precompiled packages are available from Sun Freeware
  (L<http://www.sunfreeware.com>). There, select your OS version an CPU
  architecture, download the OpenSSH package and its dependencies and
  install them. Note that you do B<not> need to configure Solaris to use
  the OpenSSH server C<sshd>.
  
  Ensure that OpenSSH client is in your path before the system C<ssh> or
  alternatively, you can hardcode the full path into your scripts
  as follows:
  
    $ssh = Net::OpenSSH->new($host,
                             ssh_cmd => '/usr/local/bin/ssh');
  
  AIX and probably some other unixen, also bundle SSH clients lacking
  the multiplexing functionality and require installation of the real
  OpenSSH.
  
  =item Can not change working directory
  
  B<Q>: I want to run some command inside a given remote directory but I
  am unable to change the working directory. For instance:
  
    $ssh->system('cd /home/foo/bin');
    $ssh->systen('ls');
  
  does not list the contents of C</home/foo/bin>.
  
  What am I doing wrong?
  
  B<A>: Net::OpenSSH (and, for that matter, all the SSH modules
  available from CPAN but L<Net::SSH::Expect>) run every command in a
  new session so most shell builtins that are run for its side effects
  become useless (e.g. C<cd>, C<export>, C<ulimit>, C<umask>, etc.,
  usually, you can list them running C<help> from the shell).
  
  A work around is to combine several commands in one, for instance:
  
    $ssh->system('cd /home/foo/bin && ls');
  
  Note the use of the shell C<&&> operator instead of C<;> in order to
  abort the command as soon as any of the subcommands fail.
  
  Also, several commands can be combined into one while still using the
  multi-argument quoting feature as follows:
  
    $ssh->system(@cmd1, \\'&&', @cmd2, \\'&&', @cmd3, ...);
  
  =item Running detached remote processes
  
  B<Q>: I need to be able to ssh into several machines from my script,
  launch a process to run in the background there, and then return
  immediately while the remote programs keep running...
  
  B<A>: If the remote systems run some Unix/Linux variant, the right
  approach is to use L<nohup(1)> that will disconnect the remote process
  from the stdio streams and to ask the shell to run the command on the
  background. For instance:
  
    $ssh->system("nohup $long_running_command &");
  
  Also, it may be possible to demonize the remote program. If it is
  written in Perl you can use L<App::Daemon> for that (actually, there
  are several CPAN modules that provided that kind of functionality).
  
  In any case, note that you should not use L</spawn> for that.
  
  =item MaxSessions server limit reached
  
  B<Q>: I created an C<$ssh> object and then fork a lot children
  processes which use this object. When the children number is bigger
  than C<MaxSessions> as defined in sshd configuration (defaults to 10),
  trying to fork new remote commands will prompt the user for the
  password.
  
  B<A>: When the slave SSH client gets a response from the remote
  servers saying that the maximum number of sessions for the current
  connection has been reached, it fall backs to open a new direct
  connection without going through the multiplexing socket.
  
  To stop that for happening, the following hack can be used:
  
    $ssh = Net::OpenSSH->new(host,
        default_ssh_opts => ['-oConnectionAttempts=0'],
        ...);
  
  =item Running remote commands with sudo
  
  B<Q>: How can I run remote commands using C<sudo> to become root first?
  
  B<A>: The simplest way is to tell C<sudo> to read the password from
  stdin with the C<-S> flag and to do not use cached credentials
  with the C<-k> flag. You may also like to use the C<-p> flag to tell
  C<sudo> to print an empty prompt. For instance:
  
    my @out = $ssh->capture({ stdin_data => "$sudo_passwd\n" },
                            'sudo', '-Sk',
                            '-p', '',
                            '--',
                            @cmd);
  
  If the version of sudo installed on the remote host does not support
  the C<-S> flag (it tells sudo to read the password from its STDIN
  stream), you can do it as follows:
  
    my @out = $ssh->capture({ tty => 1,
                              stdin_data => "$sudo_passwd\n" },
                            'sudo', '-k',
                            '-p', '',
                            '--',
                            @cmd);
  
  This may generate an spurious and harmless warning from the SSH master
  connection (because we are requesting allocation of a tty on the
  remote side and locally we are attaching it to a regular pair of
  pipes).
  
  If for whatever reason the methods described above fail, you can
  always revert to using Expect to talk to the remote C<sudo>. See the
  C<examples/expect.pl> script from this module distribution.
  
  =item Interactive sessions
  
  B<Q>: How can I start an interactive remote session?
  
  B<A>: Just call the C<system> method with an empty argument list:
  
     my $ssh = Net::OpenSSH->new(...);
     $ssh->system;
  
  =back
  
  =head1 SEE ALSO
  
  OpenSSH client documentation L<ssh(1)>, L<ssh_config(5)>, the project
  web L<http://www.openssh.org> and its FAQ
  L<http://www.openbsd.org/openssh/faq.html>. L<scp(1)> and
  L<rsync(1)>. The OpenSSH Wikibook
  L<http://en.wikibooks.org/wiki/OpenSSH>.
  
  L<Net::OpenSSH::Gateway> for detailed instruction about how to get
  this module to connect to hosts through proxies and other SSH gateway
  servers.
  
  Core perl documentation L<perlipc>, L<perlfunc/open>,
  L<perlfunc/waitpid>.
  
  L<IO::Pty|IO::Pty> to known how to use the pseudo tty objects returned
  by several methods on this package.
  
  L<Net::SFTP::Foreign|Net::SFTP::Foreign> provides a compatible SFTP
  implementation.
  
  L<Expect|Expect> can be used to interact with commands run through
  this module on the remote machine (see also the C<expect.pl> and
  <autosudo.pl> scripts in the examples directory).
  
  L<SSH::OpenSSH::Parallel> is an advanced scheduler that allows one to run
  commands in remote hosts in parallel. It is obviously based on
  Net::OpenSSH.
  
  L<SSH::Batch|SSH::Batch> allows one to run remote commands in parallel in
  a cluster. It is build on top on C<Net::OpenSSH> also.
  
  Other Perl SSH clients: L<Net::SSH::Perl|Net::SSH::Perl>,
  L<Net::SSH2|Net::SSH2>, L<Net::SSH|Net::SSH>,
  L<Net::SSH::Expect|Net::SSH::Expect>, L<Net::SCP|Net::SCP>,
  L<Net::SSH::Mechanize|Net::SSH::Mechanize>.
  
  L<Net::OpenSSH::Compat> is a package offering a set of compatibility
  layers for other SSH modules on top of Net::OpenSSH.
  
  L<IPC::PerlSSH|IPC::PerlSSH>, L<GRID::Machine|GRID::Machine> allow
  execution of Perl code in remote machines through SSH.
  
  L<SSH::RPC|SSH::RPC> implements an RPC mechanism on top of SSH using
  Net::OpenSSH to handle the connections.
  
  L<Net::CLI::Interact> allows one to interact with remote shells
  and other services. It is specially suited for interaction with
  network equipment. The phrasebook approach it uses is very clever. You
  may also like to check the L<other
  modules|https://metacpan.org/author/OLIVER> from its author, Oliver
  Gorwits.
  
  =head1 BUGS AND SUPPORT
  
  =head2 Experimental features
  
  Support for the C<restart> feature is experimental.
  
  L<Object::Remote> integration is highly experimental.
  
  Support for tunnels targeting Unix sockets is highly experimental.
  
  Support for the C<setpgrp> feature is highly experimental.
  
  Support for the gateway feature is highly experimental and mostly
  stalled.
  
  Support for taint mode is experimental.
  
  =head2 Known issues
  
  Net::OpenSSH does not work on Windows. OpenSSH multiplexing feature
  requires passing file handles through sockets, something that is not
  supported by any version of Windows.
  
  It does not work on VMS either... well, probably, it does not work on
  anything not resembling a modern Linux/Unix OS.
  
  Old versions of OpenSSH C<ssh> may leave stdio streams in non-blocking
  mode. That can result on failures when writing to C<STDOUT> or
  C<STDERR> after using the module. In order to work-around this issue,
  Perl L<perlfunc/fcntl> can be used to unset the non-blocking flag:
  
    use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK);
    my $flags = fcntl(STDOUT, F_GETFL, 0);
    fcntl(STDOUT, F_SETFL, $flags & ~O_NONBLOCK);
  
  =head2 Reporting bugs and asking for help
  
  To report bugs send an email to the address that appear below or use
  the CPAN bug tracking system at L<http://rt.cpan.org>.
  
  B<Post questions related to how to use the module in PerlMonks>
  L<http://perlmonks.org/>, you will probably get faster responses than
  if you address me directly and I visit PerlMonks quite often, so I
  will see your question anyway.
  
  =head2 Commercial support
  
  Commercial support, professional services and custom software
  development around this module are available through my current
  company. Drop me an email with a rough description of your
  requirements and we will get back to you ASAP.
  
  =head2 My wishlist
  
  If you like this module and you are feeling generous, take a look at
  my Amazon Wish List: L<http://amzn.com/w/1WU1P6IR5QZ42>.
  
  Also consider contributing to the OpenSSH project this module builds
  upon: L<http://www.openssh.org/donations.html>.
  
  =head1 TODO
  
  - Tests for C<scp_*>, C<rsync_*> and C<sftp> methods
  
  - Make L</pipe_in> and L</pipe_out> methods L</open_ex> based
  
  - C<auto_discard_streams> feature for mod_perl2 and similar environments
  
  - Refactor open_ex support for multiple commands, maybe just keeping
    tunnel, ssh and raw
  
  Send your feature requests, ideas or any feedback, please!
  
  =head1 CONTRIBUTING CODE
  
  The source code of this module is hosted at GitHub:
  L<http://github.com/salva/p5-Net-OpenSSH>.
  
  Code contributions to the module are welcome but you should obey the
  following rules:
  
  =over 4
  
  =item Only Perl 5.8.4 required
  
  Yes, that's pretty old, but Net::OpenSSH is intended to be also used
  by system administrators that sometimes have to struggle with old
  systems. The reason to pick 5.8.4 is that it has been the default perl
  on Solaris for a long time.
  
  =item Avoid the "All the world's a Linux PC" syndrome
  
  The module should work on any (barely) sane Unix or Linux operating
  system. Specially, it should not be assumed that the over-featured GNU
  utilities and toolchain are available.
  
  =item Dependencies are optional
  
  In order to make the module very easy to install, no mandatory
  dependencies on other CPAN modules are allowed.
  
  Optional modules, that are loaded only on demand, are acceptable when
  they are used for adding new functionality (as it is done, for
  instance, with L<IO::Pty>).
  
  Glue code for integration with 3rd party modules is also allowed (as
  it is done with L<Expect>).
  
  Usage of language extension modules and alike is not acceptable.
  
  =item Tests should be lax
  
  We don't want false negatives when testing. In case of doubt tests
  should succeed.
  
  Also, in case of tests invoking some external program, it should be
  checked that the external program is available and that it works as
  expected or otherwise skip those tests.
  
  =item Backward compatibility
  
  Nowadays Net::OpenSSH is quite stable and there are lots of scripts
  out there using it that we don't want to break, so, keeping the API
  backward compatible is a top priority.
  
  Probably only security issues could now justify a backward
  incompatible change.
  
  =item Follow my coding style
  
  Look at the rest of the code.
  
  I let Emacs do the formatting for me using cperl-mode PerlStyle.
  
  =item Talk to me
  
  Before making a large change or implementing a new feature get in
  touch with me.
  
  I may have my own ideas about how things should be done. It is better
  if you know them before hand, otherwise, you risk getting your patch
  rejected.
  
  =back
  
  Well, actually you should know that I am quite good at rejecting
  patches but it is not my fault!
  
  Most of the patches I get are broken in some way: they don't follow
  the main module principles, sometimes the author didn't get the full
  picture and solved the issue in a short-sighted way, etc.
  
  In any case, you should not be discouraged to contribute. Even if your
  patch is not applied directly, seeing how it solves your requirements
  or, in the case of bugs, the underlying problem analysis may be very
  useful and help me to do it... my way.
  
  I always welcome documentation corrections and improvements.
  
  =head1 COPYRIGHT AND LICENSE
  
  Copyright (C) 2008-2022 by Salvador FandiE<ntilde>o
  (sfandino@yahoo.com)
  
  This library is free software; you can redistribute it and/or modify
  it under the same terms as Perl itself, either Perl version 5.10.0 or,
  at your option, any later version of Perl 5 you may have available.
  
  =cut
NET_OPENSSH

$fatpacked{"Net/OpenSSH/ConnectionCache.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'NET_OPENSSH_CONNECTIONCACHE';
  package Net::OpenSSH::ConnectionCache;
  
  use strict;
  use warnings;
  
  use Net::OpenSSH;
  use Net::OpenSSH::Constants qw(:error);
  
  use Data::Dumper;
  use Scalar::Util qw(weaken);
  
  our $MAX_SIZE = 20;
  our %cache;
  
  sub _factory {
      my $class = shift;
      my %opts = @_;
      my $dump = Data::Dumper->new([\%opts], ['s']);
      $dump->Indent(0);
      $dump->Sortkeys(1);
      $dump->Deepcopy(1);
      my $signature = $dump->Dump;
      my $ssh = $cache{$signature};
      if ($ssh and $ssh->error != OSSH_MASTER_FAILED) {
          if ($opts{async} or $ssh->wait_for_master) {
              return $cache{$signature} = $ssh;
          }
      }
      if ($MAX_SIZE <= keys %cache) {
          for (keys %cache) {
              $ssh = $cache{$_};
              $ssh or $ssh->error != OSSH_MASTER_FAILED or delete $cache{$_}
          }
          for (keys %cache) {
              last if ($MAX_SIZE <= keys %cache);
              weaken $cache{$_};
              if (defined $cache{$_}) {
                  $cache{$_} = $cache{$_}; # unweaken
              }
              else {
                  delete $cache{$_};
              }
          }
      }
      local $Net::OpenSSH::FACTORY;
      $cache{$signature} = $class->new(@_);
  }
  
  $Net::OpenSSH::FACTORY = \&_factory;
  
  sub clean_cache { %cache = () }
  
  END { %cache = () }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Net::OpenSSH::ConnectionCache - cache and reuse SSH connections transparently
  
  =head1 SYNOPSIS
  
    use Net::OpenSSH;
    use Net::OpenSSH::ConnectionCache;
  
    for (1..10) {
      my $ssh = Net::OpenSSH->new($host);
      $ssh->system("$cmd $_");
    }
  
  =head1 DESCRIPTION
  
  This module installs a C<$Net::OpenSSH::FACTORY> hook implementing a
  SSH connection caching scheme.
  
  C<$Net::OpenSSH::ConnectionCache::MAX_SIZE> controls the cache
  size. Once as many connections are allocated, the module will try to
  free any of them before allocating a new one.
  
  The function C<clean_cache> makes the module forget (and close) all
  the cached connections:
  
    Net::OpenSSH::ConnectionCache::clean_cache();
  
  =head1 COPYRIGHT AND LICENSE
  
  Copyright (C) 2011, 2014 by Salvador FandiE<ntilde>o
  (sfandino@yahoo.com)
  
  This library is free software; you can redistribute it and/or modify
  it under the same terms as Perl itself, either Perl version 5.10.0 or,
  at your option, any later version of Perl 5 you may have available.
  
  =cut
NET_OPENSSH_CONNECTIONCACHE

$fatpacked{"Net/OpenSSH/Constants.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'NET_OPENSSH_CONSTANTS';
  package Net::OpenSSH::Constants;
  
  our $VERSION = '0.51_07';
  
  use strict;
  use warnings;
  use Carp;
  use Scalar::Util ();
  
  require Exporter;
  our @ISA = qw(Exporter);
  our %EXPORT_TAGS = (error => [], _state => []);
  
  my %error = ( OSSH_MASTER_FAILED => 1,
                OSSH_SLAVE_FAILED => 2,
                OSSH_SLAVE_PIPE_FAILED => 3,
  	      OSSH_SLAVE_TIMEOUT => 4,
  	      OSSH_SLAVE_CMD_FAILED => 5,
  	      OSSH_SLAVE_SFTP_FAILED => 6,
                OSSH_ENCODING_ERROR => 7
              );
  
  for my $key (keys %error) {
      no strict 'refs';
      my $value = $error{$key};
      *{$key} = sub () { $value };
      push @{$EXPORT_TAGS{error}}, $key
  }
  
  my @states = qw(_STATE_START
                  _STATE_LOGIN
                  _STATE_AWAITING_MUX
                  _STATE_RUNNING
                  _STATE_KILLING
                  _STATE_GONE
                  _STATE_STOPPED);
  
  my $last_value;
  for my $state (@states) {
      no strict 'refs';
      my $value = Scalar::Util::dualvar(++$last_value, $state);
      *{$state} = sub () { $value };
      push @{$EXPORT_TAGS{_state}}, $state
  }
  
  our @EXPORT_OK = map { @{$EXPORT_TAGS{$_}} } keys %EXPORT_TAGS;
  $EXPORT_TAGS{all} = [@EXPORT_OK];
  
  1;
  
  __END__
  
  =head1 NAME
  
  Net::OpenSSH::Constants - Constant definitions for Net::OpenSSH
  
  =head1 SYNOPSIS
  
    use Net::OpenSSH::Constants qw(:error);
  
  =head1 DESCRIPTION
  
  This module exports the following constants:
  
  =over 4
  
  =item :error
  
    OSSH_MASTER_FAILED - some error related to the master SSH connection happened
    OSSH_SLAVE_FAILED - some error related to a slave SSH connection happened
    OSSH_SLAVE_PIPE_FAILED - unable to create pipe to communicate with slave process
    OSSH_SLAVE_TIMEOUT - slave process timeout
    OSSH_SLAVE_CMD_FAILED - child process exited with a non zero status
    OSSH_SLAVE_SFTP_FAILED - creation of SFTP client failed
    OSSH_ENCODING_ERROR - some error related to the encoding/decoding of strings happened
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  Copyright (C) 2008, 2009 by Salvador FandiE<ntilde>o (sfandino@yahoo.com)
  
  This library is free software; you can redistribute it and/or modify
  it under the same terms as Perl itself, either Perl version 5.10.0 or,
  at your option, any later version of Perl 5 you may have available.
  
  =cut
NET_OPENSSH_CONSTANTS

$fatpacked{"Net/OpenSSH/ModuleLoader.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'NET_OPENSSH_MODULELOADER';
  package Net::OpenSSH::ModuleLoader;
  
  use strict;
  use warnings;
  use Carp;
  
  our %loaded_module;
  
  use Exporter qw(import);
  our @EXPORT = qw(_load_module);
  
  sub _load_module {
      my ($module, $version) = @_;
      $loaded_module{$module} ||= do {
          my $err;
          do {
              local ($@, $SIG{__DIE__});
              my $ok = eval "require $module; 1";
              $err = $@;
              $ok;
          } or croak "unable to load Perl module $module: $err";
      };
      if (defined $version) {
          my $mv = do {
              local ($@, $SIG{__DIE__});
              eval "\$${module}::VERSION";
          } || 0;
  	(my $mv1 = $mv) =~ s/_\d*$//;
  	croak "$module version $version required, $mv is available"
  	    if $mv1 < $version;
      }
      1
  }
  
  1;
NET_OPENSSH_MODULELOADER

$fatpacked{"Net/OpenSSH/OSTracer.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'NET_OPENSSH_OSTRACER';
  package Net::OpenSSH::OSTracer;
  
  our $VERSION = '0.65_06';
  
  use strict;
  use warnings;
  
  use POSIX;
  
  our $cmd;
  our $type;
  our $output;
  our $sudo;
  our $delay;
  
  our @EXTRA_ARGS;
  
  my %type_by_os = (linux   => 'strace',
                    openbsd => 'ktrace',
                    freebsd => 'ktrace',
                    netbsd  => 'ktrace',
                    bsd     => 'ktrace',
                    'hp-ux' => 'tusc',
                    aix     => 'truss',
                    solaris => 'truss');
  
  sub trace {
      my $class = shift;
      my ($cmd, $type) = ($cmd, $type); # copy globals
  
  
      if (not defined $type) {
          my $os = lc $^O;
          if ( defined $cmd and $cmd =~ /([sk]trace|k?truss|tusc)$/) {
              $type = $1;
          }
          elsif ($os =~ /(linux|openbsd|freebsd|netbsd|bsd|hp-ux|aix|solaris)/) {
              $type = $type_by_os{$1};
          }
          else {
              Net::OpenSSH::_debug("unable to determine tracer type for OS $os");
              return;
          }
      }
  
      my $output1 = (defined $output ? $output : "/tmp/net_openssh_master") . ".$$";
      my $file = "$output1.$type";
      my $err = "$output1.txt";
  
      $cmd = $type unless defined $cmd;
  
      my @args;
      if ($type eq 'strace') {
          @args = (-o => $file, -p => $$, -s => 1024, '-fx');
      }
      elsif ($type eq 'ktruss') {
          @args = (-o => $file, -p => $$, -m => 1024, '-d');
      }
      elsif ($type eq 'ktrace') {
          @args = (-f => $file, -p => $$, '-id');
      }
      elsif ($type eq 'tusc') {
          @args = (-o => $file, -b => 1024, '-fa', $$)
      }
      elsif ($type eq 'truss') {
          @args = (-o => $file, -faep => $$);
      }
      else {
          Net::OpenSSH::_debug("tracer type $type not supported");
          return
      }
  
      my @cmd = (defined $sudo ? ($sudo, '-A', $cmd) : $cmd);
  
      my $pid = fork;
      unless ($pid) {
          unless (defined $pid) {
              Net::OpenSSH::_debug("unable to launch tracer, fork failed: $!");
              return;
          }
          my ($in, $out);
          if (open $in, '</dev/null'      and
              open $out, '>', $err        and
              POSIX::dup2(fileno $in, 0)  and
              POSIX::dup2(fileno $out, 1) and
              POSIX::dup2(fileno $out, 2)) {
              exec (@cmd, @EXTRA_ARGS, @args);
          }
          else {
              eval { Net::OpenSSH::_debug("Unable to redirect tracer IO: $!") };
          }
          POSIX::_exit(1);
      }
      sleep (defined $delay ? $delay : 1); # wait for the tracer to come up
      Net::OpenSSH::_debug("tracer attached, ssh pid: $$, tracer pid: $pid");
      1;
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Net::OpenSSH::OSTracer - trace ssh master process at the OS level
  
  =head1 SYNOPSIS
  
      use Net::OpenSSH;
      $Net::OpenSSH::debug |= 512;
  
      Net::OpenSSH->new($host)->system("echo hello world");
  
      system "less /tmp/net_openssh_master.*.strace";
  
  =head1 DESCRIPTION
  
  This is a Net::OpenSSH helper module that allows you to trace the
  master C<ssh> process at the operating system level using the proper
  utility available in your system (e.g., C<strace>, C<truss>,
  C<ktruss>, C<tusc>, etc.).
  
  This feature can be used when debugging your programs or to report
  bugs on the module.
  
  It is enabled setting the flag 512 on the C<$Net::OpenSSH::debug> variable:
  
    $Net::OpenSSH::debug |= 512;
  
  By default the output files of the tracer are saved as
  C</tmp/net_openssh_master.$pid.$tracer_type>.
  
  Also, the output send by the tracer to stdout/stderr is saved as
  C</tmp/net_openssh_master.$pid.txt>.
  
  The module can be configured through the following global variables:
  
  =over 4
  
  =item $Net::OpenSSH::OSTracer::type
  
  By default, the module decides which tracer to use in base to the
  operating system name. This variable allows one to select a different
  tracer.
  
  Currently accepted types are: C<strace> (Linux), C<ktrace> (*BSD),
  C<tusc> (HP-UX) and C<truss> (Solaris and AIX).
  
  =item $Net::OpenSSH::OSTracer::cmd
  
  Command to execute for tracing the C<ssh> process.
  
  By default, it infers it from the tracer type selected.
  
  =item $Net::OpenSSH::OSTracer::output
  
  Basename for the destination file. The PID of the C<ssh> process and
  the tracer type will be appended.
  
  =item $Net::OpenSSH::OSTracer::sudo
  
  This variable can be used to request the tracer to be run with C<sudo>
  (some operating systems as for example Ubuntu, do not allow one to
  attach tracers, even to your own processes, unless you do it as root).
  
  The variable has to be set with the path of the C<sudo> binary. For
  instance:
  
    $Net::OpenSSH::OSTracer::sudo = '/usr/bin/sudo';
  
  If you need to pass a password to C<sudo>, set the environment
  variable C<SUDO_ASKPASS>. For instance:
  
    SUDO_ASKPASS=/usr/bin/ssh-askpass
  
  =item $Net::OpenSSH::OSTracer::delay
  
  This variable can be used to delay the C<ssh> execution so that the
  tracer can attach the process first. This is specially handy when
  using C<sudo> with a password.
  
  =back
  
  =head1 BUGS
  
  This module has not been tested under all the operating systems is
  says to support.
  
  If you find any problem, just report it, please!
  
  =head1 COPYRIGHT AND LICENSE
  
  Copyright (C) 2012 by Salvador FandiE<ntilde>o
  (sfandino@yahoo.com)
  
  This library is free software; you can redistribute it and/or modify
  it under the same terms as Perl itself, either Perl version 5.10.0 or,
  at your option, any later version of Perl 5 you may have available.
  
  
  =cut
NET_OPENSSH_OSTRACER

$fatpacked{"Net/OpenSSH/ObjectRemote.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'NET_OPENSSH_OBJECTREMOTE';
  package Net::OpenSSH::ObjectRemote;
  
  use strict;
  use warnings;
  
  use Moo;
  
  with 'Object::Remote::Role::Connector::PerlInterpreter';
  
  has net_openssh => (is => 'ro', required => 1);
  
  sub final_perl_command {
      my $self = shift;
      my $perl_command = $self->perl_command;
      [ $self->net_openssh->make_remote_command(@$perl_command) ];
  }
  
  1;
NET_OPENSSH_OBJECTREMOTE

$fatpacked{"Net/OpenSSH/SSH.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'NET_OPENSSH_SSH';
  package Net::OpenSSH::SSH;
  
  1;
  
  __END__
  
  =head1 NAME
  
  Net::OpenSSH::SSH - Perl SSH client package implemented on top of OpenSSH
  
  =head1 DESCRIPTION
  
  Use the real thing: L<Net::OpenSSH>.
  
  This namespace is used so that the module gets indexed under the
  C<SSH> tag on popular CPAN search engines such as
  L<http://metacpan.org> and L<http://search.cpan.org>.
  
  =cut
NET_OPENSSH_SSH

$fatpacked{"Net/OpenSSH/ShellQuoter.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'NET_OPENSSH_SHELLQUOTER';
  package Net::OpenSSH::ShellQuoter;
  
  use strict;
  use warnings;
  use Carp;
  
  use Net::OpenSSH::ModuleLoader;
  
  my %alias = (bash  => 'POSIX',
               sh    => 'POSIX',
               ksh   => 'POSIX',
               ash   => 'POSIX',
               dash  => 'POSIX',
               pdksh => 'POSIX',
               mksh  => 'POSIX',
               lksh  => 'POSIX',
               zsh   => 'POSIX',
               fizsh => 'POSIX',
               posh  => 'POSIX',
               fish  => 'fish',
               tcsh  => 'csh');
  
  sub quoter {
      my ($class, $shell) = @_;
      $shell = 'POSIX' unless defined $shell;
      return $shell if ref $shell;
      if ($shell =~ /,/) {
          require Net::OpenSSH::ShellQuoter::Chain;
          return Net::OpenSSH::ShellQuoter::Chain->chain(split /\s*,\s*/, $shell);
      }
      else {
          $shell = $alias{$shell} if defined $alias{$shell};
          $shell =~ /^\w+$/ or croak "bad quoting style $shell";
          my $impl = "Net::OpenSSH::ShellQuoter::$shell";
          _load_module($impl);
          return $impl->new;
      }
  }
  
  1;
NET_OPENSSH_SHELLQUOTER

$fatpacked{"Net/OpenSSH/ShellQuoter/Chain.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'NET_OPENSSH_SHELLQUOTER_CHAIN';
  package Net::OpenSSH::ShellQuoter::Chain;
  
  use strict;
  use warnings;
  
  use Net::OpenSSH::ShellQuoter;
  
  sub chain {
      my $class = shift;
      my @quoters = map Net::OpenSSH::ShellQuoter->quoter($_), reverse @_;
      my $self = \@quoters;
      bless $self, $class;
      $self;
  }
  
  sub quote {
      my ($self, $arg) = @_;
      $arg = $_->quote($arg) for @$self;
      $arg;
  }
  
  sub quote_glob {
      my ($self, $arg) = @_;
      if (@$self) {
          $arg = $self->[0]->quote_glob($arg);
          $arg = $self->[$_]->quote($arg) for 1..$#$self;
      }
      $arg
  }
  
  sub shell_fragments {
      my $self = shift;
      @$self or return (wantarray ? () : '');
      $self->[-1]->shell_fragments(@_)
  }
  
  
  1;
NET_OPENSSH_SHELLQUOTER_CHAIN

$fatpacked{"Net/OpenSSH/ShellQuoter/MSCmd.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'NET_OPENSSH_SHELLQUOTER_MSCMD';
  package Net::OpenSSH::ShellQuoter::MSCmd;
  
  use strict;
  use warnings;
  use Carp;
  
  sub new { shift() }
  
  sub quote {
      shift;
      my $arg = shift;
      if ($arg =~ /[\r\n\0]/) {
          croak "can't quote newlines to pass through MS cmd.exe";
      }
      $arg =~ s/([()%!^"<>&|])/^$1/g;
      $arg;
  }
  
  *quote_glob = \&quote;
  
  my %fragments = ( stdin_discard             => '<NUL:',
                    stdout_discard            => '>NUL:',
                    stderr_discard            => '2>NUL:',
                    stdout_and_stderr_discard => '>NUL: 2>&1',
                    stderr_to_stdout          => '2>&1' );
  
  sub shell_fragments {
      shift;
      my @f = grep defined, @fragments{@_};
      wantarray ? @f : join(' ', @f);
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Net::OpenSSH::ShellQuoter::MSCmd - Quoter for Windows cmd.exe
  
  =head1 DESCRIPTION
  
  This quoter is intended for interaction with SSH servers running on
  Windows which invoke the requested commands through the C<cmd.exe> shell.
  
  Because of C<cmd.exe> not doing wildcard expansion (on Windows this
  task is left to the final command), glob quoting just quotes
  everything.
  
  Some Windows servers use C<Win32::CreateProcess> to run the C<cmd.exe>
  shell which runs the requested command. In that case, both the C<MSCmd>
  and C<MSWin> quoters have to be chained (and BTW, order matters):
  
     $ssh = Net::OpenSSH->new(...,
                              remote_shell => 'MSCmd,MSWin');
  
  Actually, C<cmd.exe> may require not quoting at all when the requested
  command is a builtin (for instance, C<echo>).
  
  =head1 COPYRIGHT AND LICENSE
  
  Copyright (C) 2008-2014 by Salvador FandiE<ntilde>o
  (sfandino@yahoo.com)
  
  This library is free software; you can redistribute it and/or modify
  it under the same terms as Perl itself, either Perl version 5.10.0 or,
  at your option, any later version of Perl 5 you may have available.
  
  =cut
NET_OPENSSH_SHELLQUOTER_MSCMD

$fatpacked{"Net/OpenSSH/ShellQuoter/MSWin.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'NET_OPENSSH_SHELLQUOTER_MSWIN';
  package Net::OpenSSH::ShellQuoter::MSWin;
  
  use strict;
  use warnings;
  use Carp;
  
  sub new { shift() }
  
  sub quote {
      shift;
      my $arg = shift;
      if ($arg eq '') {
          return '""';
      }
      if ($arg =~ /[ \t\n\x0b"]/) {
          $arg =~ s{(\\+)(?="|\z)}{$1$1}g;
          $arg =~ s{"}{\\"}g;
          return qq("$arg");
      }
      return $arg;
  }
  
  *quote_glob = \&quote;
  
  sub shell_fragments { wantarray ? () : '' }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Net::OpenSSH::ShellQuoter::MSWin - Quoter for Win32::CreateProcess
  
  =head1 DESCRIPTION
  
  This quoter is intended for interaction with SSH servers running on
  Windows which use the C<Win32::CreateProcess> system call to launch the
  requested command.
  
  Because of C<Win32::CreateProcess> not doing wildcard expansion, glob
  quoting just quotes everything.
  
  =head1 COPYRIGHT AND LICENSE
  
  Copyright (C) 2008-2014 by Salvador FandiE<ntilde>o
  (sfandino@yahoo.com)
  
  This library is free software; you can redistribute it and/or modify
  it under the same terms as Perl itself, either Perl version 5.10.0 or,
  at your option, any later version of Perl 5 you may have available.
  
  =cut
NET_OPENSSH_SHELLQUOTER_MSWIN

$fatpacked{"Net/OpenSSH/ShellQuoter/POSIX.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'NET_OPENSSH_SHELLQUOTER_POSIX';
  package Net::OpenSSH::ShellQuoter::POSIX;
  
  use strict;
  use warnings;
  use Carp;
  
  sub new { __PACKAGE__ }
  
  my $noquote_class = '.\\w/\\-@,:';
  my $glob_class    = '*?\\[\\],\\{\\}:!^~';
  
  sub quote {
      shift;
      my $quoted = join '',
          map { ( m|\A'\z|                  ? "\\'"    :
                  m|\A'|                    ? "\"$_\"" :
                  m|\A[$noquote_class]+\z|o ? $_       :
                                            "'$_'"   )
            } split /('+)/, $_[0];
      length $quoted ? $quoted : "''";
  }
  
  
  sub quote_glob {
      shift;
      my $arg = shift;
      my @parts;
      while ((pos $arg ||0) < length $arg) {
          if ($arg =~ m|\G('+)|gc) {
              push @parts, (length($1) > 1 ? "\"$1\"" : "\\'");
          }
          elsif ($arg =~ m|\G([$noquote_class$glob_class]+)|gco) {
              push @parts, $1;
          }
          elsif ($arg =~ m|\G(\\[$glob_class\\])|gco) {
              push @parts, $1;
          }
          elsif ($arg =~ m|\G\\|gc) {
              push @parts, '\\\\'
          }
          elsif ($arg =~ m|\G([^$glob_class\\']+)|gco) {
              push @parts, "'$1'";
          }
          else {
              require Data::Dumper;
              $arg =~ m|\G(.+)|gc;
              die "Internal error: unquotable string:\n". Data::Dumper::Dumper($1) ."\n";
          }
      }
      my $quoted = join('', @parts);
      length $quoted ? $quoted : "''";
  }
  
  my %fragments = ( stdin_discard             => '</dev/null',
                    stdout_discard            => '>/dev/null',
                    stderr_discard            => '2>/dev/null',
                    stdout_and_stderr_discard => '>/dev/null 2>&1',
                    stderr_to_stdout          => '2>&1' );
  
  sub shell_fragments {
      shift;
      my @f = grep defined, @fragments{@_};
      wantarray ? @f : join(' ', @f);
  }
  
  1;
NET_OPENSSH_SHELLQUOTER_POSIX

$fatpacked{"Net/OpenSSH/ShellQuoter/csh.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'NET_OPENSSH_SHELLQUOTER_CSH';
  package Net::OpenSSH::ShellQuoter::csh;
  
  use strict;
  use warnings;
  use Carp;
  
  # Fixme: copied from POSIX
  
  sub new { __PACKAGE__ }
  
  my $noquote_class = q(.\\w/\\-@,:);
  my $glob_class    = q(*?\\[\\],{}:!^~);
  my $escape_inside_single_quotes_class  = q(\!\n);
  
  sub _single_quote {
      my $arg = shift;
      $arg =~ s/([$escape_inside_single_quotes_class])/\\$1/go;
      "'$arg'"
  }
  
  sub quote {
      shift;
      my $quoted = join '',
          map { ( m|\A'\z|                  ? "\\'"             :
                  m|\A'|                    ? "\"$_\""          :
                  m|\A[$noquote_class]*\z|o ? $_                :
                                              _single_quote($_) )
            } split /(')/o, $_[0];
      length $quoted ? $quoted : "''";
  }
  
  
  sub quote_glob {
      shift;
      my $arg = shift;
      my @parts;
      while ((pos $arg ||0) < length $arg) {
          if ($arg =~ m|\G('+)|gc) {
              push @parts, (length($1) > 1 ? "\"$1\"" : "\\'");
          }
          elsif ($arg =~ m|\G([$noquote_class$glob_class]+)|gco) {
              push @parts, $1;
          }
          elsif ($arg =~ m|\G(\\[$glob_class\\])|gco) {
              push @parts, $1;
          }
          elsif ($arg =~ m|\G([^$glob_class\\']+)|gco) {
              push @parts, _single_quote($1);
          }
          else {
              require Data::Dumper;
              $arg =~ m|\G(.+)|gc;
              die "Internal error: unquotable string:\n". Data::Dumper::Dumper($1) ."\n";
          }
      }
      my $quoted = join('', @parts);
      length $quoted ? $quoted : "''";
  }
  
  my %fragments = ( stdin_discard             => '</dev/null',
                    stdout_discard            => '>/dev/null',
                    stdout_and_stderr_discard => '>&/dev/null' );
  
  sub shell_fragments {
      shift;
      my @f = grep defined, @fragments{@_};
      wantarray ? @f : join(' ', @f);
  }
  
  1;
NET_OPENSSH_SHELLQUOTER_CSH

$fatpacked{"Net/OpenSSH/ShellQuoter/fish.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'NET_OPENSSH_SHELLQUOTER_FISH';
  package Net::OpenSSH::ShellQuoter::fish;
  
  use strict;
  use warnings;
  use Carp;
  
  sub new { __PACKAGE__ }
  
  my $noquote_class = '.\\w/\\-@,:';
  my $glob_class    = '*?\\[\\],\\{\\}:!^~';
  
  sub quote {
      my $quoted = $_[1];
      return $quoted if $quoted =~ /\A[$noquote_class]+\z/o;
      $quoted =~ s/([\'\\])/\\$1/g;
      "'$quoted'"
  }
  
  sub quote_glob {
      shift;
      my $arg = shift;
      my @parts;
      while ((pos $arg || 0) < length $arg) {
          if ($arg =~ m|\G('+)|gc) {
              push @parts, (length($1) > 1 ? "\"$1\"" : "\\'");
          }
          elsif ($arg =~ m|\G([$noquote_class$glob_class]+)|gco) {
              push @parts, $1;
          }
          elsif ($arg =~ m|\G(\\[$glob_class\\])|gco) {
              push @parts, $1;
          }
          elsif ($arg =~ m|\G\\|gc) {
              push @parts, '\\\\'
          }
          elsif ($arg =~ m|\G([^$glob_class\\']+)|gco) {
              push @parts, "'$1'";
          }
          else {
              require Data::Dumper;
              $arg =~ m|\G(.+)|gc;
              die "Internal error: unquotable string:\n". Data::Dumper::Dumper($1) ."\n";
          }
      }
      my $quoted = join('', @parts);
      length $quoted ? $quoted : "''";
  }
  
  my %fragments = ( stdin_discard             => '</dev/null',
                    stdout_discard            => '>/dev/null',
                    stderr_discard            => '2>/dev/null',
                    stdout_and_stderr_discard => '>/dev/null 2>&1',
                    stderr_to_stdout          => '2>&1' );
  
  sub shell_fragments {
      shift;
      my @f = grep defined, @fragments{@_};
      wantarray ? @f : join(' ', @f);
  }
  
  1;
NET_OPENSSH_SHELLQUOTER_FISH

$fatpacked{"Parser/MGC.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PARSER_MGC';
  #  You may distribute under the terms of either the GNU General Public License
  #  or the Artistic License (the same terms as Perl itself)
  #
  #  (C) Paul Evans, 2010-2022 -- leonerd@leonerd.org.uk
  
  package Parser::MGC 0.21;
  
  use v5.14;
  use warnings;
  
  use Carp;
  use Feature::Compat::Try;
  
  use Scalar::Util qw( blessed );
  
  =head1 NAME
  
  C<Parser::MGC> - build simple recursive-descent parsers
  
  =head1 SYNOPSIS
  
     package My::Grammar::Parser;
     use base qw( Parser::MGC );
  
     sub parse
     {
        my $self = shift;
  
        $self->sequence_of( sub {
           $self->any_of(
              sub { $self->token_int },
              sub { $self->token_string },
              sub { \$self->token_ident },
              sub { $self->scope_of( "(", \&parse, ")" ) }
           );
        } );
     }
  
     my $parser = My::Grammar::Parser->new;
  
     my $tree = $parser->from_file( $ARGV[0] );
  
     ...
  
  =head1 DESCRIPTION
  
  This base class provides a low-level framework for building recursive-descent
  parsers that consume a given input string from left to right, returning a
  parse structure. It takes its name from the C<m//gc> regexps used to implement
  the token parsing behaviour.
  
  It provides a number of token-parsing methods, which each extract a
  grammatical token from the string. It also provides wrapping methods that can
  be used to build up a possibly-recursive grammar structure, by applying a
  structure around other parts of parsing code.
  
  =head2 Backtracking
  
  Each method, both token and structural, atomically either consumes a prefix of
  the string and returns its result, or fails and consumes nothing. This makes
  it simple to implement grammars that require backtracking.
  
  Several structure-forming methods have some form of "optional" behaviour; they
  can optionally consume some amount of input or take some particular choice,
  but if the code invoked inside that subsequently fails, the structure can
  backtrack and take some different behaviour. This is usually what is required
  when testing whether the structure of the input string matches some part of
  the grammar that is optional, or has multiple choices.
  
  However, once the choice of grammar has been made, it is often useful to be
  able to fix on that one choice, thus making subsequent failures propagate up
  rather than taking that alternative behaviour. Control of this backtracking
  is given by the C<commit> method; and careful use of this method is one of the
  key advantages that C<Parser::MGC> has over more simple parsing using single
  regexps alone.
  
  =head2 Stall Detection
  
  Most of the methods in this class have bounded execution time, but some
  methods (L</list_of> and L</sequence_of>) repeatedly recuse into other code
  to build up a list of results until some ending condition is reached. A
  possible class of bug is that whatever they recurse into might successfully
  match an empty string, and thus make no progress.
  
  These methods will automatically detect this situation if they repeatedly
  encounter the same string position more than a certain number of times (given
  by the C<stallcount> argument). If this count is reached, the entire parse
  attempt will be aborted by the L</die> method.
  
  =cut
  
  =head1 CONSTRUCTOR
  
  =cut
  
  =head2 new
  
     $parser = Parser::MGC->new( %args )
  
  Returns a new instance of a C<Parser::MGC> object. This must be called on a
  subclass that provides method of the name provided as C<toplevel>, by default
  called C<parse>.
  
  Takes the following named arguments
  
  =over 8
  
  =item toplevel => STRING
  
  Name of the toplevel method to use to start the parse from. If not supplied,
  will try to use a method called C<parse>.
  
  =item patterns => HASH
  
  Keys in this hash should map to quoted regexp (C<qr//>) references, to
  override the default patterns used to match tokens. See C<PATTERNS> below
  
  =item accept_0o_oct => BOOL
  
  If true, the C<token_int> method will also accept integers with a C<0o> prefix
  as octal.
  
  =item stallcount => INT
  
  I<Since version 0.21.>
  
  The number of times that the stall-detector would have to see the same
  position before it aborts the parse attempt. If not supplied, a default of
  C<10> will apply.
  
  =back
  
  =cut
  
  =head1 PATTERNS
  
  The following pattern names are recognised. They may be passed to the
  constructor in the C<patterns> hash, or provided as a class method under the
  name C<pattern_I<name>>.
  
  =over 4
  
  =item * ws
  
  Pattern used to skip whitespace between tokens. Defaults to C</[\s\n\t]+/>
  
  =item * comment
  
  Pattern used to skip comments between tokens. Undefined by default.
  
  =item * int
  
  Pattern used to parse an integer by C<token_int>. Defaults to
  C</-?(?:0x[[:xdigit:]]+|[[:digit:]]+)/>. If C<accept_0o_oct> is given, then
  this will be expanded to match C</0o[0-7]+/> as well.
  
  =item * float
  
  Pattern used to parse a floating-point number by C<token_float>. Defaults to
  C</-?(?:\d*\.\d+|\d+\.)(?:e-?\d+)?|-?\d+e-?\d+/i>.
  
  =item * ident
  
  Pattern used to parse an identifier by C<token_ident>. Defaults to
  C</[[:alpha:]_]\w*/>
  
  =item * string_delim
  
  Pattern used to delimit a string by C<token_string>. Defaults to C</["']/>.
  
  =back
  
  =cut
  
  my @patterns = qw(
     ws
     comment
     int
     float
     ident
     string_delim
  );
  
  use constant pattern_ws      => qr/[\s\n\t]+/;
  use constant pattern_comment => undef;
  use constant pattern_int     => qr/-?(?:0x[[:xdigit:]]+|[[:digit:]]+)/;
  use constant pattern_float   => qr/-?(?:\d*\.\d+|\d+\.)(?:e-?\d+)?|-?\d+e-?\d+/i;
  use constant pattern_ident   => qr/[[:alpha:]_]\w*/;
  use constant pattern_string_delim => qr/["']/;
  
  use constant DEFAULT_STALLCOUNT => 10;
  
  sub new
  {
     my $class = shift;
     my %args = @_;
  
     my $toplevel = $args{toplevel} || "parse";
  
     $class->can( $toplevel ) or
        croak "Expected to be a subclass that can ->$toplevel";
  
     my $self = bless {
        toplevel => $toplevel,
        patterns => {},
        scope_level => 0,
        stallcount => $args{stallcount} // DEFAULT_STALLCOUNT,
     }, $class;
  
     $self->{patterns}{$_} = $args{patterns}{$_} || $self->${\"pattern_$_"} for @patterns;
  
     if( $args{accept_0o_oct} ) {
        $self->{patterns}{int} = qr/0o[0-7]+|$self->{patterns}{int}/;
     }
  
     if( defined $self->{patterns}{comment} ) {
        $self->{patterns}{_skip} = qr/$self->{patterns}{ws}|$self->{patterns}{comment}/;
     }
     else {
        $self->{patterns}{_skip} = $self->{patterns}{ws};
     }
  
     return $self;
  }
  
  =head1 SUBCLASSING METHODS
  
  The following optional methods may be defined by subclasses, to customise
  their parsing.
  
  =head2 on_parse_start
  
     $parser->on_parse_start
  
  I<Since version 0.21.>
  
  If defined, is invoked by the C<from_*> method that begins a new parse
  operation, just before invoking the toplevel structure method.
  
  =head2 on_parse_end
  
     $result = $parser->on_parse_end( $result )
  
  I<Since version 0.21.>
  
  If defined, is invoked by the C<from_*> method once it has finished the
  toplevel structure method. This is passed the tentative result from the
  structure method, and whatever it returns becomes the result of the C<from_*>
  method itself.
  
  =cut
  
  =head1 METHODS
  
  =cut
  
  =head2 from_string
  
     $result = $parser->from_string( $str )
  
  Parse the given literal string and return the result from the toplevel method.
  
  =cut
  
  sub from_string
  {
     my $self = shift;
     my ( $str ) = @_;
  
     $self->{str} = $str;
  
     pos $self->{str} = 0;
  
     if( my $code = $self->can( "on_parse_start" ) ) {
        $self->$code;
     }
  
     my $toplevel = $self->{toplevel};
     my $result = $self->$toplevel;
  
     $self->at_eos or
        $self->fail( "Expected end of input" );
  
     if( my $code = $self->can( "on_parse_end" ) ) {
        $result = $self->$code( $result );
     }
  
     return $result;
  }
  
  =head2 from_file
  
     $result = $parser->from_file( $file, %opts )
  
  Parse the given file, which may be a pathname in a string, or an opened IO
  handle, and return the result from the toplevel method.
  
  The following options are recognised:
  
  =over 8
  
  =item binmode => STRING
  
  If set, applies the given binmode to the filehandle before reading. Typically
  this can be used to set the encoding of the file.
  
     $parser->from_file( $file, binmode => ":encoding(UTF-8)" )
  
  =back
  
  =cut
  
  sub from_file
  {
     my $self = shift;
     my ( $file, %opts ) = @_;
  
     defined $file or croak "Expected a filename to ->from_file";
  
     $self->{filename} = $file;
  
     my $fh;
     if( ref $file ) {
        $fh = $file;
     }
     else {
        open $fh, "<", $file or die "Cannot open $file for reading - $!";
     }
  
     binmode $fh, $opts{binmode} if $opts{binmode};
  
     $self->from_string( do { local $/; <$fh>; } );
  }
  
  =head2 filename
  
     $filename = $parser->filename
  
  I<Since version 0.20.>
  
  Returns the name of the file currently being parsed, if invoked from within
  L</from_file>.
  
  =cut
  
  sub filename
  {
     my $self = shift;
     return $self->{filename};
  }
  
  =head2 from_reader
  
     $result = $parser->from_reader( \&reader )
  
  I<Since version 0.05.>
  
  Parse the input which is read by the C<reader> function. This function will be
  called in scalar context to generate portions of string to parse, being passed
  the C<$parser> object. The function should return C<undef> when it has no more
  string to return.
  
     $reader->( $parser )
  
  Note that because it is not generally possible to detect exactly when more
  input may be required due to failed regexp parsing, the reader function is
  only invoked during searching for skippable whitespace. This makes it suitable
  for reading lines of a file in the common case where lines are considered as
  skippable whitespace, or for reading lines of input interactively from a
  user. It cannot be used in all cases (for example, reading fixed-size buffers
  from a file) because two successive invocations may split a single token
  across the buffer boundaries, and cause parse failures.
  
  =cut
  
  sub from_reader
  {
     my $self = shift;
     my ( $reader ) = @_;
  
     local $self->{reader} = $reader;
  
     $self->{str} = "";
     pos $self->{str} = 0;
  
     my $result = $self->parse;
  
     $self->at_eos or
        $self->fail( "Expected end of input" );
  
     return $result;
  }
  
  =head2 pos
  
     $pos = $parser->pos
  
  I<Since version 0.09.>
  
  Returns the current parse position, as a character offset from the beginning
  of the file or string.
  
  =cut
  
  sub pos
  {
     my $self = shift;
     return pos $self->{str};
  }
  
  =head2 take
  
     $str = $parser->take( $len )
  
  I<Since version 0.16.>
  
  Returns the next C<$len> characters directly from the input, prior to any
  whitespace or comment skipping. This does I<not> take account of any
  end-of-scope marker that may be pending. It is intended for use by parsers of
  partially-binary protocols, or other situations in which it would be incorrect
  for the end-of-scope marker to take effect at this time.
  
  =cut
  
  sub take
  {
     my $self = shift;
     my ( $len ) = @_;
  
     my $start = pos( $self->{str} );
  
     pos( $self->{str} ) += $len;
  
     return substr( $self->{str}, $start, $len );
  }
  
  =head2 where
  
     ( $lineno, $col, $text ) = $parser->where
  
  Returns the current parse position, as a line and column number, and
  the entire current line of text. The first line is numbered 1, and the first
  column is numbered 0.
  
  =cut
  
  sub where
  {
     my $self = shift;
     my ( $pos ) = @_;
  
     defined $pos or $pos = pos $self->{str};
  
     my $str = $self->{str};
  
     my $sol = $pos;
     $sol-- if $sol > 0 and substr( $str, $sol, 1 ) =~ m/^[\r\n]$/;
     $sol-- while $sol > 0 and substr( $str, $sol-1, 1 ) !~ m/^[\r\n]$/;
  
     my $eol = $pos;
     $eol++ while $eol < length($str) and substr( $str, $eol, 1 ) !~ m/^[\r\n]$/;
  
     my $line = substr( $str, $sol, $eol - $sol );
  
     my $col = $pos - $sol;
     my $lineno = ( () = substr( $str, 0, $pos ) =~ m/\n/g ) + 1;
  
     return ( $lineno, $col, $line );
  }
  
  =head2 fail
  
  =head2 fail_from
  
     $parser->fail( $message )
  
     $parser->fail_from( $pos, $message )
  
  I<C<fail_from> since version 0.09.>
  
  Aborts the current parse attempt with the given message string. The failure
  message will include the line and column position, and the line of input that
  failed at the current parse position (C<fail>), or a position earlier obtained
  using the C<pos> method (C<fail_from>).
  
  This failure will propagate up to the inner-most structure parsing method that
  has not been committed; or will cause the entire parser to fail if there are
  no further options to take.
  
  =cut
  
  sub fail
  {
     my $self = shift;
     my ( $message ) = @_;
     $self->fail_from( $self->pos, $message );
  }
  
  sub fail_from
  {
     my $self = shift;
     my ( $pos, $message ) = @_;
     die Parser::MGC::Failure->new( $message, $self, $pos );
  }
  
  # On perl 5.32 onwards we can use the nicer `isa` infix operator
  # Problem is it won't even parse correctly on older perls so we'll have to go
  # the long way around
  *_isa_failure = ( $^V ge v5.32 )
     ? do { eval 'use experimental "isa"; sub { $_[0] isa Parser::MGC::Failure }' // die $@ }
     : do { require Scalar::Util; 
            sub { Scalar::Util::blessed($_[0]) and $_[0]->isa( "Parser::MGC::Failure" ) } };
  
  =head2 die
  
  =head2 die_from
  
     $parser->die( $message )
  
     $parser->die_from( $pos, $message )
  
  I<Since version 0.20.>
  
  Throws an exception that propagates as normal for C<die>, entirely out of the
  entire parser and to the caller of the toplevel C<from_*> method that invoked
  it, bypassing all of the back-tracking logic.
  
  This is much like using core's C<die> directly, except that the message string
  will include the line and column position, and the line of input that the
  parser was working on, as it does in the L</fail> method.
  
  This method is intended for reporting fatal errors where the parsed input was
  correctly recognised at a grammar level, but is requesting something that
  cannot be fulfilled semantically.
  
  =cut
  
  sub die :method
  {
     my $self = shift;
     my ( $message ) = @_;
     $self->die_from( $self->pos, $message );
  }
  
  sub die_from
  {
     my $self = shift;
     my ( $pos, $message ) = @_;
     # Convenient just to use the ->STRING method of a Failure object but don't
     # throw it directly
     die Parser::MGC::Failure->new( $message, $self, $pos )->STRING;
  }
  
  =head2 at_eos
  
     $eos = $parser->at_eos
  
  Returns true if the input string is at the end of the string.
  
  =cut
  
  sub at_eos
  {
     my $self = shift;
  
     # Save pos() before skipping ws so we don't break the substring_before method
     my $pos = pos $self->{str};
  
     $self->skip_ws;
  
     my $at_eos;
     if( pos( $self->{str} ) >= length $self->{str} ) {
        $at_eos = 1;
     }
     elsif( defined $self->{endofscope} ) {
        $at_eos = $self->{str} =~ m/\G$self->{endofscope}/;
     }
     else {
        $at_eos = 0;
     }
  
     pos( $self->{str} ) = $pos;
  
     return $at_eos;
  }
  
  =head2 scope_level
  
     $level = $parser->scope_level
  
  I<Since version 0.05.>
  
  Returns the number of nested C<scope_of> calls that have been made.
  
  =cut
  
  sub scope_level
  {
     my $self = shift;
     return $self->{scope_level};
  }
  
  =head2 include_string
  
     $result = $parser->include_string( $str, %opts )
  
  I<Since version 0.21.>
  
  Parses a given string into the existing parser object.
  
  The current parser state is moved aside from the duration of this method, and
  is replaced by the given string. Then the toplevel parser method (or a
  different as specified) is invoked over it. Its result is returned by this
  method.
  
  This would typically be used to handle some sort of "include" or "macro
  expansion" ability, by injecting new content in as if the current parse
  location had encountered it. Other than the internal parser state, other
  object fields are not altered, so whatever effects the invoked parsing methods
  will have on it can continue to inspect and alter it as required.
  
  The following options are recognised:
  
  =over 8
  
  =item filename => STRING
  
  If set, provides a filename (or other descriptive text) to pretend for the
  source of this string. It need not be a real file on the filesystem; it could
  for example explain the source of the string in some other way. It is the
  value reported by the L</filename> method and printed in failure messages.
  
  =item toplevel => STRING | CODE
  
  If set, provides the toplevel parser method to use within this inclusion,
  overriding the object's defined default.
  
  =back
  
  =cut
  
  sub include_string
  {
     my $self = shift;
     my ( $str, %opts ) = @_;
  
     # local'ize everything out of the way
     local @{$self}{qw( str filename reader )};
  
     $self->{str} = $str;
     pos($self->{str}) = 0;
  
     $self->{filename} = $opts{filename};
  
     my $toplevel = $opts{toplevel} // $self->{toplevel};
     my $result = $self->$toplevel;
  
     return $result;
  }
  
  =head1 STRUCTURE-FORMING METHODS
  
  The following methods may be used to build a grammatical structure out of the
  defined basic token-parsing methods. Each takes at least one code reference,
  which will be passed the actual C<$parser> object as its first argument.
  
  Anywhere that a code reference is expected also permits a plain string giving
  the name of a method to invoke. This is sufficient in many simple cases, such
  as
  
     $self->any_of(
        'token_int',
        'token_string',
        ...
     );
  
  =cut
  
  =head2 maybe
  
     $ret = $parser->maybe( $code )
  
  Attempts to execute the given C<$code> in scalar context, and returns what it
  returned, accepting that it might fail. C<$code> may either be a CODE
  reference or a method name given as a string.
  
  If the code fails (either by calling C<fail> itself, or by propagating a
  failure from another method it invoked) before it has invoked C<commit>, then
  none of the input string will be consumed; the current parsing position will
  be restored. C<undef> will be returned in this case.
  
  If it calls C<commit> then any subsequent failure will be propagated to the
  caller, rather than returning C<undef>.
  
  This may be considered to be similar to the C<?> regexp qualifier.
  
     sub parse_declaration
     {
        my $self = shift;
  
        [ $self->parse_type,
          $self->token_ident,
          $self->maybe( sub {
             $self->expect( "=" );
             $self->parse_expression
          } ),
        ];
     }
  
  =cut
  
  sub maybe
  {
     my $self = shift;
     my ( $code ) = @_;
  
     my $pos = pos $self->{str};
  
     my $committed = 0;
     local $self->{committer} = sub { $committed++ };
  
     try {
        return $self->$code;
     }
     catch ( $e ) {
        pos($self->{str}) = $pos;
  
        die $e if $committed or not _isa_failure( $e );
        return undef;
     }
  }
  
  =head2 scope_of
  
     $ret = $parser->scope_of( $start, $code, $stop )
  
  Expects to find the C<$start> pattern, then attempts to execute the given
  C<$code>, then expects to find the C<$stop> pattern. Returns whatever the
  code returned. C<$code> may either be a CODE reference of a method name given
  as a string.
  
  While the code is being executed, the C<$stop> pattern will be used by the
  token parsing methods as an end-of-scope marker; causing them to raise a
  failure if called at the end of a scope.
  
     sub parse_block
     {
        my $self = shift;
  
        $self->scope_of( "{", 'parse_statements', "}" );
     }
  
  If the C<$start> pattern is undefined, it is presumed the caller has already
  checked for this. This is useful when the stop pattern needs to be calculated
  based on the start pattern.
  
     sub parse_bracketed
     {
        my $self = shift;
  
        my $delim = $self->expect( qr/[\(\[\<\{]/ );
        $delim =~ tr/([<{/)]>}/;
  
        $self->scope_of( undef, 'parse_body', $delim );
     }
  
  This method does not have any optional parts to it; any failures are
  immediately propagated to the caller.
  
  =cut
  
  sub scope_of
  {
     my $self = shift;
     $self->_scope_of( 0, @_ );
  }
  
  sub _scope_of
  {
     my $self = shift;
     my ( $commit_if_started, $start, $code, $stop ) = @_;
  
     ref $stop or $stop = qr/\Q$stop/;
  
     $self->expect( $start ) if defined $start;
  
     $self->commit if $commit_if_started;
  
     local $self->{endofscope} = $stop;
     local $self->{scope_level} = $self->{scope_level} + 1;
  
     my $ret = $self->$code;
  
     $self->expect( $stop );
  
     return $ret;
  }
  
  =head2 committed_scope_of
  
     $ret = $parser->committed_scope_of( $start, $code, $stop )
  
  I<Since version 0.16.>
  
  A variant of L</scope_of> that calls L</commit> after a successful match of
  the start pattern. This is usually what you want if using C<scope_of> from
  within an C<any_of> choice, if no other alternative following this one could
  possibly match if the start pattern has.
  
  =cut
  
  sub committed_scope_of
  {
     my $self = shift;
     $self->_scope_of( 1, @_ );
  }
  
  =head2 list_of
  
     $ret = $parser->list_of( $sep, $code )
  
  Expects to find a list of instances of something parsed by C<$code>,
  separated by the C<$sep> pattern. Returns an ARRAY ref containing a list of
  the return values from the C<$code>. A single trailing delimiter is allowed,
  and does not affect the return value. C<$code> may either be a CODE reference
  or a method name given as a string. It is called in list context, and whatever
  values it returns are appended to the eventual result - similar to perl's
  C<map>.
  
  This method does not consider it an error if the returned list is empty; that
  is, that the scope ended before any item instances were parsed from it.
  
     sub parse_numbers
     {
        my $self = shift;
  
        $self->list_of( ",", 'token_int' );
     }
  
  If the code fails (either by invoking C<fail> itself, or by propagating a
  failure from another method it invoked) before it has invoked C<commit> on a
  particular item, then the item is aborted and the parsing position will be
  restored to the beginning of that failed item. The list of results from
  previous successful attempts will be returned.
  
  If it calls C<commit> within an item then any subsequent failure for that item
  will cause the entire C<list_of> to fail, propagating that to the caller.
  
  =cut
  
  sub list_of
  {
     my $self = shift;
     my ( $sep, $code ) = @_;
  
     ref $sep or $sep = qr/\Q$sep/ if defined $sep;
  
     my $committed;
     local $self->{committer} = sub { $committed++ };
  
     my @ret;
  
     my @lastpos;
  
     while( !$self->at_eos ) {
        $committed = 0;
        my $pos = pos $self->{str};
  
        push @lastpos, $pos;
        if( @lastpos > $self->{stallcount} ) {
           shift @lastpos;
           $self->die( ref($self) . " failed to make progress" ) if $lastpos[0] == $pos;
        }
  
        try {
           push @ret, $self->$code;
           next;
        }
        catch ( $e ) {
           pos($self->{str}) = $pos;
           die $e if $committed or not _isa_failure( $e );
  
           last;
        }
     }
     continue {
        if( defined $sep ) {
           $self->skip_ws;
           $self->{str} =~ m/\G$sep/gc or last;
        }
     }
  
     return \@ret;
  }
  
  =head2 sequence_of
  
     $ret = $parser->sequence_of( $code )
  
  A shortcut for calling C<list_of> with an empty string as separator; expects
  to find at least one instance of something parsed by C<$code>, separated only
  by skipped whitespace.
  
  This may be considered to be similar to the C<+> or C<*> regexp qualifiers.
  
     sub parse_statements
     {
        my $self = shift;
  
        $self->sequence_of( 'parse_statement' );
     }
  
  The interaction of failures in the code and the C<commit> method is identical
  to that of C<list_of>.
  
  =cut
  
  sub sequence_of
  {
     my $self = shift;
     my ( $code ) = @_;
  
     $self->list_of( undef, $code );
  }
  
  =head2 any_of
  
     $ret = $parser->any_of( @codes )
  
  I<Since version 0.06.>
  
  Expects that one of the given code instances can parse something from the
  input, returning what it returned. Each code instance may indicate a failure
  to parse by calling the C<fail> method or otherwise propagating a failure.
  Each code instance may either be a CODE reference or a method name given as a
  string.
  
  This may be considered to be similar to the C<|> regexp operator for forming
  alternations of possible parse trees.
  
     sub parse_statement
     {
        my $self = shift;
  
        $self->any_of(
           sub { $self->parse_declaration; $self->expect(";") },
           sub { $self->parse_expression; $self->expect(";") },
           sub { $self->parse_block },
        );
     }
  
  If the code for a given choice fails (either by invoking C<fail> itself, or by
  propagating a failure from another method it invoked) before it has invoked
  C<commit> itself, then the parsing position restored and the next choice will
  be attempted.
  
  If it calls C<commit> then any subsequent failure for that choice will cause
  the entire C<any_of> to fail, propagating that to the caller and no further
  choices will be attempted.
  
  If none of the choices match then a simple failure message is printed:
  
     Found nothing parseable
  
  As this is unlikely to be helpful to users, a better message can be provided
  by the final choice instead. Don't forget to C<commit> before printing the
  failure message, or it won't count.
  
     $self->any_of(
        'token_int',
        'token_string',
        ...,
  
        sub { $self->commit; $self->fail( "Expected an int or string" ) }
     );
  
  =cut
  
  sub any_of
  {
     my $self = shift;
  
     while( @_ ) {
        my $code = shift;
        my $pos = pos $self->{str};
  
        my $committed = 0;
        local $self->{committer} = sub { $committed++ };
  
        try {
           return $self->$code;
        }
        catch ( $e ) {
           pos( $self->{str} ) = $pos;
  
           die $e if $committed or not _isa_failure( $e );
        }
     }
  
     $self->fail( "Found nothing parseable" );
  }
  
  sub one_of {
     croak "Parser::MGC->one_of is deprecated; use ->any_of instead";
  }
  
  =head2 commit
  
     $parser->commit
  
  Calling this method will cancel the backtracking behaviour of the innermost
  C<maybe>, C<list_of>, C<sequence_of>, or C<any_of> structure forming method.
  That is, if later code then calls C<fail>, the exception will be propagated
  out of C<maybe>, no further list items will be attempted by C<list_of> or
  C<sequence_of>, and no further code blocks will be attempted by C<any_of>.
  
  Typically this will be called once the grammatical structure alter has been
  determined, ensuring that any further failures are raised as real exceptions,
  rather than by attempting other alternatives.
  
   sub parse_statement
   {
      my $self = shift;
  
      $self->any_of(
         ...
         sub {
            $self->scope_of( "{",
               sub { $self->commit; $self->parse_statements; },
            "}" ),
         },
      );
   }
  
  Though in this common pattern, L</committed_scope_of> may be used instead.
  
  =cut
  
  sub commit
  {
     my $self = shift;
     if( $self->{committer} ) {
        $self->{committer}->();
     }
     else {
        croak "Cannot commit except within a backtrack-able structure";
     }
  }
  
  =head1 TOKEN PARSING METHODS
  
  The following methods attempt to consume some part of the input string, to be
  used as part of the parsing process.
  
  =cut
  
  sub skip_ws
  {
     my $self = shift;
  
     my $pattern = $self->{patterns}{_skip};
  
     {
        1 while $self->{str} =~ m/\G$pattern/gc;
  
        return if pos( $self->{str} ) < length $self->{str};
  
        return unless $self->{reader};
  
        my $more = $self->{reader}->( $self );
        if( defined $more ) {
           my $pos = pos( $self->{str} );
           $self->{str} .= $more;
           pos( $self->{str} ) = $pos;
  
           redo;
        }
  
        undef $self->{reader};
        return;
     }
  }
  
  =head2 expect
  
     $str = $parser->expect( $literal )
  
     $str = $parser->expect( qr/pattern/ )
  
     @groups = $parser->expect( qr/pattern/ )
  
  Expects to find a literal string or regexp pattern match, and consumes it.
  In scalar context, this method returns the string that was captured. In list
  context it returns the matching substring and the contents of any subgroups
  contained in the pattern.
  
  This method will raise a parse error (by calling C<fail>) if the regexp fails
  to match. Note that if the pattern could match an empty string (such as for
  example C<qr/\d*/>), the pattern will always match, even if it has to match an
  empty string. This method will not consider a failure if the regexp matches
  with zero-width.
  
  =head2 maybe_expect
  
     $str = $parser->maybe_expect( ... )
  
     @groups = $parser->maybe_expect( ... )
  
  I<Since version 0.10.>
  
  A convenient shortcut equivalent to calling C<expect> within C<maybe>, but
  implemented more efficiently, avoiding the exception-handling set up by
  C<maybe>. Returns C<undef> or an empty list if the match fails.
  
  =cut
  
  sub maybe_expect
  {
     my $self = shift;
     my ( $expect ) = @_;
  
     ref $expect or $expect = qr/\Q$expect/;
  
     $self->skip_ws;
     $self->{str} =~ m/\G$expect/gc or return;
  
     return substr( $self->{str}, $-[0], $+[0]-$-[0] ) if !wantarray;
     return map { defined $-[$_] ? substr( $self->{str}, $-[$_], $+[$_]-$-[$_] ) : undef } 0 .. $#+;
  }
  
  sub expect
  {
     my $self = shift;
     my ( $expect ) = @_;
  
     ref $expect or $expect = qr/\Q$expect/;
  
     if( wantarray ) {
        my @ret = $self->maybe_expect( $expect ) or
           $self->fail( "Expected $expect" );
        return @ret;
     }
     else {
        defined( my $ret = $self->maybe_expect( $expect ) ) or
           $self->fail( "Expected $expect" );
        return $ret;
     }
  }
  
  =head2 substring_before
  
     $str = $parser->substring_before( $literal )
  
     $str = $parser->substring_before( qr/pattern/ )
  
  I<Since version 0.06.>
  
  Expects to possibly find a literal string or regexp pattern match. If it finds
  such, consume all the input text before but excluding this match, and return
  it. If it fails to find a match before the end of the current scope, consumes
  all the input text until the end of scope and return it.
  
  This method does not consume the part of input that matches, only the text
  before it. It is not considered a failure if the substring before this match
  is empty. If a non-empty match is required, use the C<fail> method:
  
     sub token_nonempty_part
     {
        my $self = shift;
  
        my $str = $parser->substring_before( "," );
        length $str or $self->fail( "Expected a string fragment before ," );
  
        return $str;
     }
  
  Note that unlike most of the other token parsing methods, this method does not
  consume either leading or trailing whitespace around the substring. It is
  expected that this method would be used as part a parser to read quoted
  strings, or similar cases where whitespace should be preserved.
  
  =head2 nonempty_substring_before
  
     $str = $parser->nonempty_substring_before( $literal )
  
     $str = $parser->nonempty_substring_before( qr/pattern/ )
  
  I<Since version 0.20.>
  
  A variant of L</substring_before> which fails if the matched part is empty.
  
  The example above could have been written:
  
     sub token_nonempty_part
     {
        my $self = shift;
  
        return $parser->nonempty_substring_before( "," );
     }
  
  This is often useful for breaking out of repeating loops; e.g.
  
     sub token_escaped_string
     {
        my $self = shift;
        $self->expect( '"' );
  
        my $ret = "";
        1 while $self->any_of(
           sub { $ret .= $self->nonempty_substring_before( qr/%|$/m ); 1 }
           sub { my $escape = ( $self->expect( qr/%(.)/ ) )[1];
                 $ret .= _handle_escape( $escape );
                 1 },
           sub { 0 },
        )
  
        return $ret;
     }
  
  =cut
  
  sub _substring_before
  {
     my $self = shift;
     my ( $expect, $fail_if_empty ) = @_;
  
     ref $expect or $expect = qr/\Q$expect/;
  
     my $endre = ( defined $self->{endofscope} ) ?
        qr/$expect|$self->{endofscope}/ :
        $expect;
  
     # NO skip_ws
  
     my $start = pos $self->{str};
     my $end;
     if( $self->{str} =~ m/\G(?s:.*?)($endre)/ ) {
        $end = $-[1];
     }
     else {
        $end = length $self->{str};
     }
  
     $self->fail( "Expected to find a non-empty substring before $expect" )
        if $fail_if_empty and $end == $start;
  
     return $self->take( $end - $start );
  }
  
  sub substring_before
  {
     my $self = shift;
     return $self->_substring_before( $_[0], 0 );
  }
  
  sub nonempty_substring_before
  {
     my $self = shift;
     return $self->_substring_before( $_[0], 1 );
  }
  
  =head2 generic_token
  
     $val = $parser->generic_token( $name, $re, $convert )
  
  I<Since version 0.08.>
  
  Expects to find a token matching the precompiled regexp C<$re>. If provided,
  the C<$convert> CODE reference can be used to convert the string into a more
  convenient form. C<$name> is used in the failure message if the pattern fails
  to match.
  
  If provided, the C<$convert> function will be passed the parser and the
  matching substring; the value it returns is returned from C<generic_token>.
  
     $convert->( $parser, $substr )
  
  If not provided, the substring will be returned as it stands.
  
  This method is mostly provided for subclasses to define their own token types.
  For example:
  
     sub token_hex
     {
        my $self = shift;
        $self->generic_token( hex => qr/[0-9A-F]{2}h/, sub { hex $_[1] } );
     }
  
  =cut
  
  sub generic_token
  {
     my $self = shift;
     my ( $name, $re, $convert ) = @_;
  
     $self->fail( "Expected $name" ) if $self->at_eos;
  
     $self->skip_ws;
     $self->{str} =~ m/\G$re/gc or
        $self->fail( "Expected $name" );
  
     my $match = substr( $self->{str}, $-[0], $+[0] - $-[0] );
  
     return $convert ? $convert->( $self, $match ) : $match;
  }
  
  sub _token_generic
  {
     my $self = shift;
     my %args = @_;
  
     my $name    = $args{name};
     my $re      = $args{pattern} ? $self->{patterns}{ $args{pattern} } : $args{re};
     my $convert = $args{convert};
  
     $self->generic_token( $name, $re, $convert );
  }
  
  =head2 token_int
  
     $int = $parser->token_int
  
  Expects to find an integer in decimal, octal or hexadecimal notation, and
  consumes it. Negative integers, preceeded by C<->, are also recognised.
  
  =cut
  
  sub token_int
  {
     my $self = shift;
     $self->_token_generic(
        name => "int",
  
        pattern => "int",
        convert => sub {
           my $int = $_[1];
           my $sign = ( $int =~ s/^-// ) ? -1 : 1;
  
           $int =~ s/^0o/0/;
  
           return $sign * oct $int if $int =~ m/^0/;
           return $sign * $int;
        },
     );
  }
  
  =head2 token_float
  
     $float = $parser->token_float
  
  I<Since version 0.04.>
  
  Expects to find a number expressed in floating-point notation; a sequence of
  digits possibly prefixed by C<->, possibly containing a decimal point,
  possibly followed by an exponent specified by C<e> followed by an integer. The
  numerical value is then returned.
  
  =cut
  
  sub token_float
  {
     my $self = shift;
     $self->_token_generic(
        name => "float",
  
        pattern => "float",
        convert => sub { $_[1] + 0 },
     );
  }
  
  =head2 token_number
  
     $number = $parser->token_number
  
  I<Since version 0.09.>
  
  Expects to find a number expressed in either of the above forms.
  
  =cut
  
  sub token_number
  {
     my $self = shift;
     $self->any_of( \&token_float, \&token_int );
  }
  
  =head2 token_string
  
     $str = $parser->token_string
  
  Expects to find a quoted string, and consumes it. The string should be quoted
  using C<"> or C<'> quote marks.
  
  The content of the quoted string can contain character escapes similar to
  those accepted by C or Perl. Specifically, the following forms are recognised:
  
     \a               Bell ("alert")
     \b               Backspace
     \e               Escape
     \f               Form feed
     \n               Newline
     \r               Return
     \t               Horizontal Tab
     \0, \012         Octal character
     \x34, \x{5678}   Hexadecimal character
  
  C's C<\v> for vertical tab is not supported as it is rarely used in practice
  and it collides with Perl's C<\v> regexp escape. Perl's C<\c> for forming other
  control characters is also not supported.
  
  =cut
  
  my %escapes = (
     a => "\a",
     b => "\b",
     e => "\e",
     f => "\f",
     n => "\n",
     r => "\r",
     t => "\t",
  );
  
  sub token_string
  {
     my $self = shift;
  
     $self->fail( "Expected string" ) if $self->at_eos;
  
     my $pos = pos $self->{str};
  
     $self->skip_ws;
     $self->{str} =~ m/\G($self->{patterns}{string_delim})/gc or
        $self->fail( "Expected string delimiter" );
  
     my $delim = $1;
  
     $self->{str} =~ m/
        \G(
           (?:
              \\[0-7]{1,3}     # octal escape
             |\\x[0-9A-F]{2}   # 2-digit hex escape
             |\\x\{[0-9A-F]+\} # {}-delimited hex escape
             |\\.              # symbolic escape
             |[^\\$delim]+     # plain chunk
           )*?
        )$delim/gcix or
           pos($self->{str}) = $pos, $self->fail( "Expected contents of string" );
  
     my $string = $1;
  
     $string =~ s<\\(?:([0-7]{1,3})|x([0-9A-F]{2})|x\{([0-9A-F]+)\}|(.))>
                 [defined $1 ? chr oct $1 :
                  defined $2 ? chr hex $2 :
                  defined $3 ? chr hex $3 :
                               exists $escapes{$4} ? $escapes{$4} : $4]egi;
  
     return $string;
  }
  
  =head2 token_ident
  
     $ident = $parser->token_ident
  
  Expects to find an identifier, and consumes it.
  
  =cut
  
  sub token_ident
  {
     my $self = shift;
     $self->_token_generic(
        name => "ident",
  
        pattern => "ident",
     );
  }
  
  =head2 token_kw
  
     $keyword = $parser->token_kw( @keywords )
  
  Expects to find a keyword, and consumes it. A keyword is defined as an
  identifier which is exactly one of the literal values passed in.
  
  =cut
  
  sub token_kw
  {
     my $self = shift;
     my @acceptable = @_;
  
     $self->skip_ws;
  
     my $pos = pos $self->{str};
  
     defined( my $kw = $self->token_ident ) or
        return undef;
  
     grep { $_ eq $kw } @acceptable or
        pos($self->{str}) = $pos, $self->fail( "Expected any of ".join( ", ", @acceptable ) );
  
     return $kw;
  }
  
  package # hide from indexer
     Parser::MGC::Failure;
  
  sub new
  {
     my $class = shift;
     my $self = bless {}, $class;
     @{$self}{qw( message parser pos )} = @_;
     return $self;
  }
  
  use overload '""' => "STRING";
  sub STRING
  {
     my $self = shift;
  
     my $parser = $self->{parser};
     my ( $linenum, $col, $text ) = $parser->where( $self->{pos} );
  
     # Column number only counts characters. There may be tabs in there.
     # Rather than trying to calculate the visual column number, just print the
     # indentation as it stands.
  
     my $indent = substr( $text, 0, $col );
     $indent =~ s/[^ \t]/ /g; # blank out all the non-whitespace
  
     my $filename = $parser->filename;
     my $in_file = ( defined $filename and !ref $filename )
                      ? "in $filename " : "";
  
     return "$self->{message} ${in_file}on line $linenum at:\n" . 
            "$text\n" . 
            "$indent^\n";
  }
  
  # Provide fallback operators for cmp, eq, etc...
  use overload fallback => 1;
  
  =head1 EXAMPLES
  
  =head2 Accumulating Results Using Variables
  
  Although the structure-forming methods all return a value, obtained from their
  nested parsing code, it can sometimes be more convenient to use a variable to
  accumulate a result in instead. For example, consider the following parser
  method, designed to parse a set of C<name: "value"> assignments, such as might
  be found in a configuration file, or YAML/JSON-style mapping value.
  
     sub parse_dict
     {
        my $self = shift;
  
        my %ret;
        $self->list_of( ",", sub {
           my $key = $self->token_ident;
           exists $ret{$key} and $self->fail( "Already have a mapping for '$key'" );
  
           $self->expect( ":" );
  
           $ret{$key} = $self->parse_value;
        } );
  
        return \%ret
     }
  
  Instead of using the return value from C<list_of>, this method accumulates
  values in the C<%ret> hash, eventually returning a reference to it as its
  result. Because of this, it can perform some error checking while it parses;
  namely, rejecting duplicate keys.
  
  =head1 TODO
  
  =over 4
  
  =item *
  
  Make unescaping of string constants more customisable. Possibly consider
  instead a C<parse_string_generic> using a loop over C<substring_before>.
  
  =item *
  
  Easy ability for subclasses to define more token types as methods. Perhaps
  provide a class method such as
  
     __PACKAGE__->has_token( hex => qr/[0-9A-F]+/i, sub { hex $_[1] } );
  
  =item *
  
  Investigate how well C<from_reader> can cope with buffer splitting across
  other tokens than simply skippable whitespace
  
  =back
  
  =head1 AUTHOR
  
  Paul Evans <leonerd@leonerd.org.uk>
  
  =cut
  
  0x55AA;
PARSER_MGC

$fatpacked{"Parser/MGC/Examples/EvaluateExpression.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PARSER_MGC_EXAMPLES_EVALUATEEXPRESSION';
  package Parser::MGC::Examples::EvaluateExpression;
  
  =head1 NAME
  
  C<Parser::MGC::Examples::EvaluateExpression> - an example parser to evaluate simple numerical expressions
  
  =head1 DESCRIPTION
  
  This evaluator-parser takes simple mathematical expressions involving the four
  basic arithmetic operators (+, -, *, /) applied to integers, and returns the
  numerical result. It handles operator precedence, with * and / having a higher
  level than + and -, and copes with parentheses.
  
  Operator precedence is implemented by using two different parsing functions to
  handle the two different precedence levels.
  
  =cut
  
  =head2 Boilerplate
  
  We start off by declaring a package and subclassing L<Parser::MGC>.
  
     package ExprParser;
     use base qw( Parser::MGC );
  
     use strict;
     use warnings;
  
  =head2 parse
  
  The topmost parsing function, C<parse>, handles the outermost level of
  operator precedence, the + and - operators. It first parses a single term from
  the input by callling C<parse_term> to obtain its value.
  
  It then uses the C<any_of> structure-forming method to look for either a + or -
  operator which would indicate another term will follow it. If it finds either
  of these, it parses the next term from after the operator by another call to
  C<parse_term> and then adds or subtracts the value of it from the running
  total.
  
  The C<any_of> call itself is used as the conditional expression of a C<while>
  loop, to ensure it gets called multiple times. Whenever another term has been
  parsed, the body function returns a true value, to indicate that the while
  loop should be invoked again. Only when there are no more + or - operators,
  indicating no more terms, does the body return false, causing the while loop
  to stop.
  
  This continues until there are no more + or - operators, when the overall
  total value is returned to the caller.
  
  =cut
  
  =pod
  
     sub parse
     {
        my $self = shift;
  
        my $val = $self->parse_term
  
        1 while $self->any_of(
           sub { $self->expect( "+" ); $val += $self->parse_term; 1 },
           sub { $self->expect( "-" ); $val -= $self->parse_term; 1 },
           sub { 0 },
        );
  
        return $val;
     }
  
  =cut
  
  =pod
  
  This function recognises input matching the following EBNF grammar:
  
     EXPR = TERM { ( '+' | '-' ) TERM };
  
  =cut
  
  =head2 parse_term
  
  Called by C<parse>, the next function is C<parse_term> which has a similar
  structure. This function implements the next level of operator precedence, of
  the * and / operators. In a similar fashion to the previous function, this one
  parses a single factor from the input by calling C<parse_factor>, and then
  looks for * or / operators, multiplying or dividing the value by the next
  factor it expects to find after those. This continues until there are no more
  * or / operators, when the overall product is returned.
  
  =cut
  
  =pod
  
     sub parse_term
     {
        my $self = shift;
  
        my $val = $self->parse_factor;
  
        1 while $self->any_of(
           sub { $self->expect( "*" ); $val *= $self->parse_factor; 1 },
           sub { $self->expect( "/" ); $val /= $self->parse_factor; 1 },
           sub { 0 },
        );
  
        return $val;
     }
  
  =cut
  
  =pod
  
  This function recognises input matching the following EBNF grammar:
  
     TERM = FACTOR { ( '*' | '/' ) FACTOR };
  
  =cut
  
  =head2 parse_factor
  
  Finally, the innermost C<parse_factor> function is called by C<parse_term> to
  parse out the actual numerical values. This is also the point at which the
  grammar can recurse, recognising a parenthesized expression. It uses an
  C<any_of> with two alternative function bodies, to cover these two cases.
  
  The first case, to handle a parenthesized sub-expression, consists of a call
  to C<scope_of>. This call would expect to find a C<(> symbol to indicate the
  parenthesized expression. If it finds one, it will recurse back to the
  toplevel C<parse> method to obtain its value, then expects the final C<)>
  symbol. The value of this factor is then the value of the sub-expression
  contained within the parentheses.
  
  If the first case fails, because it does not find that leading C<(> symbol,
  the second case is attempted instead. This handles an actual integer constant.
  This case is simply a call to the C<token_int> method of the underlying class,
  which recognises various string forms of integer constants, returning their
  numerical value.
  
  =cut
  
  =pod
  
     sub parse_factor
     {
        my $self = shift;
  
        $self->any_of(
           sub { $self->scope_of( "(", sub { $self->parse }, ")" ) },
           sub { $self->token_int },
        );
     }
  
  =cut
  
  =pod
  
  This function recognises input matching the following EBNF grammar:
  
     FACTOR = '(' EXPR ')'
            | integer
  
  =cut
  
  =head1 EXAMPLES OF OPERATION
  
  =head2 A single integer
  
  The simplest form of operation of this parser is when it is given a single
  integer value as its input; for example C<"15">.
  
   INPUT:    15
   POSITION: ^
  
  The outermost call to C<parse> will call C<parse_term>, which in turn calls
  C<parse_factor>.
  
   INPUT:    15
   POSITION  ^
   CALLS:    parse
              => parse_term
               => parse_factor
  
  The C<any_of> inside C<parse_factor> will first attempt to find a
  parenthesized sub-expression by using C<scope_of>, but this will fail because
  it does not start with an open parenthesis symbol. The C<any_of> will then
  attempt the second case, calling C<token_int> which will succeed at obtaining
  an integer value from the input stream, consuming it by advancing the stream
  position. The value of 15 is then returned by C<parse_factor> back to
  C<parse_term> where it is stored in the C<$val> lexical.
  
   INPUT:    15
   POSITION:   ^
   CALLS:    parse
              => parse_term -- $val = 15
  
  At this point, the C<any_of> inside C<parse_term> will attempt to find a * or
  / operator, but both will fail because there is none, causing the final
  alternative function to be invoked, which stops the C<while> loop executing.
  The value of 15 is then returned to the outer caller, C<parse>. A similar
  process happens there, where it fails to find a + or - operator, and thus the
  final value of 15 is returned as the result of the entire parsing operation.
  
   INPUT:    15
   OUTPUT:   15
  
  =head2 A simple sum of two integers
  
  Next lets consider a case that actually requires some real parsing, such as an
  expression requesting the sum of two values; C<"6 + 9">.
  
   INPUT:    6 + 9
   POSITION: ^
  
  This parsing operation starts the same as the previous; with C<parse> calling
  C<parse_term> which in turn calls C<parse_factor>.
  
   INPUT:    6 + 9
   POSITION: ^
   CALLS:    parse
              => parse_term
               => parse_factor
  
  As before, the C<any_of> inside C<parse_factor> first attempts and fails to
  find a parenthesized sub-expression and so tries C<token_int> instead. As
  before this obtains an integer value from the stream and advances the
  position. This value is again returned to C<parse_term>. As before, the
  C<any_of> attempts but fails to find a * or / operator so the value gets
  returned to C<parse> to be stored in C<$val>.
  
   INPUT:    6 + 9
   POSITION:  ^
   CALLS:    parse -- $val = 6
  
  This time, the C<any_of> in the outer C<parse> method attempts to find a +
  operator and succeeds, because there is one at the next position in the
  stream. This causes the first case to continue, making another call to
  C<parse_term>.
  
   INPUT:    6 + 9
   POSITION:    ^
   CALLS:    parse -- $val = 6
              => parse_term
  
  This call to C<parse_term> proceeds much like the first, eventually returning
  the value 9 by consuming it from the input stream. This value is added to
  C<$val> by the code inside the C<any_of> call.
  
   INPUT:    6 + 9
   POSITION:      ^
   CALLS:    parse -- $val = 15
  
  C<parse> then calls C<any_of> a second time, which attempts to find another
  operator. This time there is none, so it returns false, which stops the
  C<while> loop and the value is returned as the final result of the operation.
  
   INPUT:    6 + 9
   OUTPUT:   15
  
  =head2 Operator precedence
  
  The two kinds of operators (+ and - vs * and /) are split across two different
  method calls to allow them to implement precedence; to say that some of the
  operators bind more tightly than others. Those operators that are implemented
  in more inwardly-nested functions bind tighter than the ones implemented
  further out.
  
  To see this in operation consider an expression that mixes the two kinds of
  operators, such as C<"15 - 2 * 3">
  
   INPUT:    15 - 2 * 3
   POSITION: ^
  
  The parsing operation starts by calling down from C<parse> all the way to
  C<token_int> which extracts the first integer, 15, from the stream and returns
  it all the way up to C<parse> as before:
  
   INPUT:    15 - 2 * 3
   POSITION:   ^
   CALLS:    parse -- $val = 15
  
  As before, the C<parse> function looks for a * or - operator by its C<any_of>
  test, and finds this time the - operator, which then causes it to call
  C<parse_term> to parse its value:
  
   INPUT:    15 - 2 * 3
   POSITION:     ^
   CALLS:    parse -- $val = 15
              => parse_term
  
  Again, C<parse_term> starts by calling C<parse_factor> which extracts the next
  integer from the stream and returns it. C<parse_factor> temporarily stores
  that in its own C<$val> lexical (which remember, is a lexical variable local
  to that call, so is distinct from the one in C<parse>).
  
   INPUT:    15 - 2 * 3
   POSITION:       ^
   CALLS:    parse -- $val = 15
              => parse_term -- $val = 2
  
  This time, when C<parse_term> attempts its own C<any_of> test to look for a *
  or / operator, it manages to find one. By a process similar to the way that
  the outer C<parse> method forms a sum of terms, C<parse_term> forms a product
  of factors by calling down to C<parse_factor> and accumulating the result.
  Here it will call C<parse_factor> again, which returns the value 3. This gets
  multiplied into C<$var>.
  
   INPUT:    15 - 2 * 3
   POSITION:           ^
   CALLS:    parse -- $val = 15
              => parse_term -- $val = 6
  
  C<parse_term> will try again to look for a * or / operator, but this time
  fails to find one, and so returns its final result, 6, back to C<parse>, which
  then subtracts it from its own C<$val>.
  
   INPUT:    15 - 2 * 3
   POSITION:           ^
   CALLS:    parse -- $val = 9
  
  The outer C<parse> call similarly fails to find any more + or - operators and
  so returns the final result of the parsing operation.
  
   INPUT:    15 - 2 * 3
   OUTPUT:   9
  
  By implementing the * and / operators separately in a different piece of logic
  inside the one that implements the + and - operators, we have ensured that
  they operate more greedily. That is, that they bind tighter, consuming their
  values first, before the outer + and - operators. This is the way that
  operator precedence is implemented.
  
  =head2 Parentheses
  
  This grammar, like many others, provides a way for expressions to override the
  usual operator precedence by supplying a sub-expression in parentheses. The
  expression inside those parentheses is parsed in the usual way, and then its
  result stands in place of the entire parenthesized part, overriding whatever
  rules might have governed the order between those operators inside it and
  those outside.
  
  In this parser we implement this as a recursive call, where one possibility
  of the innermost part (the C<parse_factor> function or the C<FACTOR> EBNF
  rule) is to recurse back to the outermost thing, inside parentheses. This
  example examines what happens to the input string C<"(15 - 2) * 3">.
  
   INPUT:    (15 - 2) * 3
   POSITION: ^
  
  As with all the other examples the parsing operation starts by C<parse>
  calling C<parse_term> which calls C<parse_factor>. This time, the first case
  within the C<any_of> in C<parse_factor> does successfully manage to find an
  open parenthesis, so consumes it. It then stores the close parenthesis pattern
  as the end-of-scope marker, and makes a recursive call back to the parse
  method again.
  
   INPUT:    (15 - 2) * 3
   POSITION:  ^
   CALLS:    parse
              => parse_term
               => parse_factor
                => parse                 EOS = ")"
  
  The operation of the inner call to C<parse> proceeds much like the first few
  examples, calling down through C<parse_term> to C<parse_factor> to obtain
  the 15.
  
   INPUT:    (15 - 2) * 3
   POSITION:    ^
   CALLS:    parse
              => parse_term
               => parse_factor
                => parse -- $val = 15    EOS = ")"
  
  Similar to previous examples, this then finds the - operator, and parses
  another term to subtract from it.
  
   INPUT:    (15 - 2) * 3
   POSITION:        ^
   CALLS:    parse
              => parse_term
               => parse_factor
                => parse -- $val = 13    EOS = ")"
  
  At this point, the C<any_of> test in the inner call to C<parse> tries again to
  look for a + or - operator, and this time fails because it believes it is at
  the end of the input. It isn't really at the end of the string, of course, but
  it believes it to be at the end because of the "end-of-scope" pattern that the
  call to C<scope_of> established. This pretends that the input has finished
  whenever the next part of the input matches the end-of-scope pattern.
  
  Because this inner call to C<parse> now believes it has got to the end of its
  input, it returns its final answer back to the caller, which in this case was
  the C<scope_of> call that C<parse_factor> made. As the C<scope_of> call
  returns, it consumes the input matching the end-of-scope pattern. This return
  value is then stored by C<parse_term>.
  
   INPUT:    (15 - 2) * 3
   POSITION:         ^
   CALLS:    parse
              => parse_term -- $val = 13
  
  At this point, C<parse_term> proceeds as before, finding and extracting the *
  operator and calling C<parse_factor> a second time, multiplying them together
  and returning that to the outer C<parse> call.
  
   INPUT:    (15 - 2) * 3
   POSITION:             ^
   CALLS:    parse -- $val = 39
  
  At this point C<parse> fails to extract any more operators because it is at
  the (real) end of input, so returns the final answer.
  
   INPUT:    (15 - 2) * 3
   OUTPUT:   39
PARSER_MGC_EXAMPLES_EVALUATEEXPRESSION

$fatpacked{"Regexp/Common.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'REGEXP_COMMON';
  package Regexp::Common;
  
  use 5.10.0;
  use strict;
  
  use warnings;
  no  warnings 'syntax';
  
  our $VERSION = '2017060201';
  our %RE;
  our %sub_interface;
  our $AUTOLOAD;
  
  
  sub _croak {
      require Carp;
      goto &Carp::croak;
  }
  
  sub _carp {
      require Carp;
      goto &Carp::carp;
  }
  
  sub new {
      my ($class, @data) = @_;
      my %self;
      tie %self, $class, @data;
      return \%self;
  }
  
  sub TIEHASH {
      my ($class, @data) = @_;
      bless \@data, $class;
  }
  
  sub FETCH {
      my ($self, $extra) = @_;
      return bless ref($self)->new(@$self, $extra), ref($self);
  }
  
  my %imports = map {$_ => "Regexp::Common::$_"}
                qw /balanced CC     comment   delimited lingua list
                    net      number profanity SEN       URI    whitespace
                    zip/;
  
  sub import {
      shift;  # Shift off the class.
      tie %RE, __PACKAGE__;
      {
          no strict 'refs';
          *{caller() . "::RE"} = \%RE;
      }
  
      my $saw_import;
      my $no_defaults;
      my %exclude;
      foreach my $entry (grep {!/^RE_/} @_) {
          if ($entry eq 'pattern') {
              no strict 'refs';
              *{caller() . "::pattern"} = \&pattern;
              next;
          }
          # This used to prevent $; from being set. We still recognize it,
          # but we won't do anything.
          if ($entry eq 'clean') {
              next;
          }
          if ($entry eq 'no_defaults') {
              $no_defaults ++;
              next;
          }
          if (my $module = $imports {$entry}) {
              $saw_import ++;
              eval "require $module;";
              die $@ if $@;
              next;
          }
          if ($entry =~ /^!(.*)/ && $imports {$1}) {
              $exclude {$1} ++;
              next;
          }
          # As a last resort, try to load the argument.
          my $module = $entry =~ /^Regexp::Common/
                              ? $entry
                              : "Regexp::Common::" . $entry;
          eval "require $module;";
          die $@ if $@;
      }
  
      unless ($saw_import || $no_defaults) {
          foreach my $module (values %imports) {
              next if $exclude {$module};
              eval "require $module;";
              die $@ if $@;
          }
      }
  
      my %exported;
      foreach my $entry (grep {/^RE_/} @_) {
          if ($entry =~ /^RE_(\w+_)?ALL$/) {
              my $m  = defined $1 ? $1 : "";
              my $re = qr /^RE_${m}.*$/;
              while (my ($sub, $interface) = each %sub_interface) {
                  next if $exported {$sub};
                  next unless $sub =~ /$re/;
                  {
                      no strict 'refs';
                      *{caller() . "::$sub"} = $interface;
                  }
                  $exported {$sub} ++;
              }
          }
          else {
              next if $exported {$entry};
              _croak "Can't export unknown subroutine &$entry"
                  unless $sub_interface {$entry};
              {
                  no strict 'refs';
                  *{caller() . "::$entry"} = $sub_interface {$entry};
              }
              $exported {$entry} ++;
          }
      }
  }
  
  sub AUTOLOAD { _croak "Can't $AUTOLOAD" }
  
  sub DESTROY {}
  
  my %cache;
  
  my $fpat = qr/^(-\w+)/;
  
  sub _decache {
          my @args = @{tied %{$_[0]}};
          my @nonflags = grep {!/$fpat/} @args;
          my $cache = get_cache(@nonflags);
          _croak "Can't create unknown regex: \$RE{"
              . join("}{",@args) . "}"
                  unless exists $cache->{__VAL__};
          _croak "Perl $] does not support the pattern "
              . "\$RE{" . join("}{",@args)
              . "}.\nYou need Perl $cache->{__VAL__}{version} or later"
                  unless ($cache->{__VAL__}{version}||0) <= $];
          my %flags = ( %{$cache->{__VAL__}{default}},
                        map { /$fpat\Q$;\E(.*)/ ? ($1 => $2)
                            : /$fpat/           ? ($1 => undef)
                            :                     ()
                            } @args);
          $cache->{__VAL__}->_clone_with(\@args, \%flags);
  }
  
  use overload q{""} => \&_decache;
  
  
  sub get_cache {
          my $cache = \%cache;
          foreach (@_) {
                  $cache = $cache->{$_}
                        || ($cache->{$_} = {});
          }
          return $cache;
  }
  
  sub croak_version {
          my ($entry, @args) = @_;
  }
  
  sub pattern {
          my %spec = @_;
          _croak 'pattern() requires argument: name => [ @list ]'
                  unless $spec{name} && ref $spec{name} eq 'ARRAY';
          _croak 'pattern() requires argument: create => $sub_ref_or_string'
                  unless $spec{create};
  
          if (ref $spec{create} ne "CODE") {
                  my $fixed_str = "$spec{create}";
                  $spec{create} = sub { $fixed_str }
          }
  
          my @nonflags;
          my %default;
          foreach ( @{$spec{name}} ) {
                  if (/$fpat=(.*)/) {
                          $default{$1} = $2;
                  }
                  elsif (/$fpat\s*$/) {
                          $default{$1} = undef;
                  }
                  else {
                          push @nonflags, $_;
                  }
          }
  
          my $entry = get_cache(@nonflags);
  
          if ($entry->{__VAL__}) {
                  _carp "Overriding \$RE{"
                     . join("}{",@nonflags)
                     . "}";
          }
  
          $entry->{__VAL__} = bless {
                                  create  => $spec{create},
                                  match   => $spec{match} || \&generic_match,
                                  subs    => $spec{subs}  || \&generic_subs,
                                  version => $spec{version},
                                  default => \%default,
                              }, 'Regexp::Common::Entry';
  
          foreach (@nonflags) {s/\W/X/g}
          my $subname = "RE_" . join ("_", @nonflags);
          $sub_interface{$subname} = sub {
                  push @_ => undef if @_ % 2;
                  my %flags = @_;
                  my $pat = $spec{create}->($entry->{__VAL__},
                                 {%default, %flags}, \@nonflags);
                  if (exists $flags{-keep}) { $pat =~ s/\Q(?k:/(/g; }
                  else { $pat =~ s/\Q(?k:/(?:/g; }
                  return exists $flags {-i} ? qr /(?i:$pat)/ : qr/$pat/;
          };
  
          return 1;
  }
  
  sub generic_match {$_ [1] =~  /$_[0]/}
  sub generic_subs  {$_ [1] =~ s/$_[0]/$_[2]/}
  
  sub matches {
          my ($self, $str) = @_;
          my $entry = $self -> _decache;
          $entry -> {match} -> ($entry, $str);
  }
  
  sub subs {
          my ($self, $str, $newstr) = @_;
          my $entry = $self -> _decache;
          $entry -> {subs} -> ($entry, $str, $newstr);
          return $str;
  }
  
  
  package Regexp::Common::Entry;
  # use Carp;
  
  use overload
      q{""} => sub {
          my ($self) = @_;
          my $pat = $self->{create}->($self, $self->{flags}, $self->{args});
          if (exists $self->{flags}{-keep}) {
              $pat =~ s/\Q(?k:/(/g;
          }
          else {
              $pat =~ s/\Q(?k:/(?:/g;
          }
          if (exists $self->{flags}{-i})   { $pat = "(?i)$pat" }
          return $pat;
      };
  
  sub _clone_with {
      my ($self, $args, $flags) = @_;
      bless { %$self, args=>$args, flags=>$flags }, ref $self;
  }
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Regexp::Common - Provide commonly requested regular expressions
  
  =head1 SYNOPSIS
  
   # STANDARD USAGE 
  
   use Regexp::Common;
  
   while (<>) {
       /$RE{num}{real}/               and print q{a number};
       /$RE{quoted}/                  and print q{a ['"`] quoted string};
      m[$RE{delimited}{-delim=>'/'}]  and print q{a /.../ sequence};
       /$RE{balanced}{-parens=>'()'}/ and print q{balanced parentheses};
       /$RE{profanity}/               and print q{a #*@%-ing word};
   }
  
  
   # SUBROUTINE-BASED INTERFACE
  
   use Regexp::Common 'RE_ALL';
  
   while (<>) {
       $_ =~ RE_num_real()              and print q{a number};
       $_ =~ RE_quoted()                and print q{a ['"`] quoted string};
       $_ =~ RE_delimited(-delim=>'/')  and print q{a /.../ sequence};
       $_ =~ RE_balanced(-parens=>'()'} and print q{balanced parentheses};
       $_ =~ RE_profanity()             and print q{a #*@%-ing word};
   }
  
  
   # IN-LINE MATCHING...
  
   if ( $RE{num}{int}->matches($text) ) {...}
  
  
   # ...AND SUBSTITUTION
  
   my $cropped = $RE{ws}{crop}->subs($uncropped);
  
  
   # ROLL-YOUR-OWN PATTERNS
  
   use Regexp::Common 'pattern';
  
   pattern name   => ['name', 'mine'],
           create => '(?i:J[.]?\s+A[.]?\s+Perl-Hacker)',
           ;
  
   my $name_matcher = $RE{name}{mine};
  
   pattern name    => [ 'lineof', '-char=_' ],
           create  => sub {
                          my $flags = shift;
                          my $char = quotemeta $flags->{-char};
                          return '(?:^$char+$)';
                      },
           match   => sub {
                          my ($self, $str) = @_;
                          return $str !~ /[^$self->{flags}{-char}]/;
                      },
           subs   => sub {
                          my ($self, $str, $replacement) = @_;
                          $_[1] =~ s/^$self->{flags}{-char}+$//g;
                     },
           ;
  
   my $asterisks = $RE{lineof}{-char=>'*'};
  
   # DECIDING WHICH PATTERNS TO LOAD.
  
   use Regexp::Common qw /comment number/;  # Comment and number patterns.
   use Regexp::Common qw /no_defaults/;     # Don't load any patterns.
   use Regexp::Common qw /!delimited/;      # All, but delimited patterns.
  
  
  =head1 DESCRIPTION
  
  By default, this module exports a single hash (C<%RE>) that stores or generates
  commonly needed regular expressions (see L<"List of available patterns">).
  
  There is an alternative, subroutine-based syntax described in
  L<"Subroutine-based interface">.
  
  
  =head2 General syntax for requesting patterns
  
  To access a particular pattern, C<%RE> is treated as a hierarchical hash of
  hashes (of hashes...), with each successive key being an identifier. For
  example, to access the pattern that matches real numbers, you 
  specify:
  
          $RE{num}{real}
          
  and to access the pattern that matches integers: 
  
          $RE{num}{int}
  
  Deeper layers of the hash are used to specify I<flags>: arguments that
  modify the resulting pattern in some way. The keys used to access these
  layers are prefixed with a minus sign and may have a value; if a value
  is given, it's done by using a multidimensional key.
  For example, to access the pattern that
  matches base-2 real numbers with embedded commas separating
  groups of three digits (e.g. 10,101,110.110101101):
  
          $RE{num}{real}{-base => 2}{-sep => ','}{-group => 3}
  
  Through the magic of Perl, these flag layers may be specified in any order
  (and even interspersed through the identifier keys!)
  so you could get the same pattern with:
  
          $RE{num}{real}{-sep => ','}{-group => 3}{-base => 2}
  
  or:
  
          $RE{num}{-base => 2}{real}{-group => 3}{-sep => ','}
  
  or even:
  
          $RE{-base => 2}{-group => 3}{-sep => ','}{num}{real}
  
  etc.
  
  Note, however, that the relative order of amongst the identifier keys
  I<is> significant. That is:
  
          $RE{list}{set}
  
  would not be the same as:
  
          $RE{set}{list}
  
  =head2 Flag syntax
  
  In versions prior to 2.113, flags could also be written as
  C<{"-flag=value"}>. This no longer works, although C<{"-flag$;value"}>
  still does. However, C<< {-flag => 'value'} >> is the preferred syntax.
  
  =head2 Universal flags
  
  Normally, flags are specific to a single pattern.
  However, there is two flags that all patterns may specify.
  
  =over 4
  
  =item C<-keep>
  
  By default, the patterns provided by C<%RE> contain no capturing
  parentheses. However, if the C<-keep> flag is specified (it requires
  no value) then any significant substrings that the pattern matches
  are captured. For example:
  
          if ($str =~ $RE{num}{real}{-keep}) {
                  $number   = $1;
                  $whole    = $3;
                  $decimals = $5;
          }
  
  Special care is needed if a "kept" pattern is interpolated into a
  larger regular expression, as the presence of other capturing
  parentheses is likely to change the "number variables" into which significant
  substrings are saved.
  
  See also L<"Adding new regular expressions">, which describes how to create
  new patterns with "optional" capturing brackets that respond to C<-keep>.
  
  =item C<-i>
  
  Some patterns or subpatterns only match lowercase or uppercase letters.
  If one wants the do case insensitive matching, one option is to use
  the C</i> regexp modifier, or the special sequence C<(?i)>. But if the
  functional interface is used, one does not have this option. The 
  C<-i> switch solves this problem; by using it, the pattern will do
  case insensitive matching.
  
  =back
  
  =head2 OO interface and inline matching/substitution
  
  The patterns returned from C<%RE> are objects, so rather than writing:
  
          if ($str =~ /$RE{some}{pattern}/ ) {...}
  
  you can write:
  
          if ( $RE{some}{pattern}->matches($str) ) {...}
  
  For matching this would seem to have no great advantage apart from readability
  (but see below).
  
  For substitutions, it has other significant benefits. Frequently you want to
  perform a substitution on a string without changing the original. Most people
  use this:
  
          $changed = $original;
          $changed =~ s/$RE{some}{pattern}/$replacement/;
  
  The more adept use:
  
          ($changed = $original) =~ s/$RE{some}{pattern}/$replacement/;
  
  Regexp::Common allows you do write this:
  
          $changed = $RE{some}{pattern}->subs($original=>$replacement);
  
  Apart from reducing precedence-angst, this approach has the added
  advantages that the substitution behaviour can be optimized from the 
  regular expression, and the replacement string can be provided by
  default (see L<"Adding new regular expressions">).
  
  For example, in the implementation of this substitution:
  
          $cropped = $RE{ws}{crop}->subs($uncropped);
  
  the default empty string is provided automatically, and the substitution is
  optimized to use:
  
          $uncropped =~ s/^\s+//;
          $uncropped =~ s/\s+$//;
  
  rather than:
  
          $uncropped =~ s/^\s+|\s+$//g;
  
  
  =head2 Subroutine-based interface
  
  The hash-based interface was chosen because it allows regexes to be
  effortlessly interpolated, and because it also allows them to be
  "curried". For example:
  
          my $num = $RE{num}{int};
  
          my $commad     = $num->{-sep=>','}{-group=>3};
          my $duodecimal = $num->{-base=>12};
  
  
  However, the use of tied hashes does make the access to Regexp::Common
  patterns slower than it might otherwise be. In contexts where impatience
  overrules laziness, Regexp::Common provides an additional
  subroutine-based interface.
  
  For each (sub-)entry in the C<%RE> hash (C<$RE{key1}{key2}{etc}>), there
  is a corresponding exportable subroutine: C<RE_key1_key2_etc()>. The name of
  each subroutine is the underscore-separated concatenation of the I<non-flag>
  keys that locate the same pattern in C<%RE>. Flags are passed to the subroutine
  in its argument list. Thus:
  
          use Regexp::Common qw( RE_ws_crop RE_num_real RE_profanity );
  
          $str =~ RE_ws_crop() and die "Surrounded by whitespace";
  
          $str =~ RE_num_real(-base=>8, -sep=>" ") or next;
  
          $offensive = RE_profanity(-keep);
          $str =~ s/$offensive/$bad{$1}++; "<expletive deleted>"/ge;
  
  Note that, unlike the hash-based interface (which returns objects), these
  subroutines return ordinary C<qr>'d regular expressions. Hence they do not
  curry, nor do they provide the OO match and substitution inlining described
  in the previous section.
  
  It is also possible to export subroutines for all available patterns like so:
  
          use Regexp::Common 'RE_ALL';
  
  Or you can export all subroutines with a common prefix of keys like so:
  
          use Regexp::Common 'RE_num_ALL';
  
  which will export C<RE_num_int> and C<RE_num_real> (and if you have
  create more patterns who have first key I<num>, those will be exported
  as well). In general, I<RE_key1_..._keyn_ALL> will export all subroutines
  whose pattern names have first keys I<key1> ... I<keyn>.
  
  
  =head2 Adding new regular expressions
  
  You can add your own regular expressions to the C<%RE> hash at run-time,
  using the exportable C<pattern> subroutine. It expects a hash-like list of 
  key/value pairs that specify the behaviour of the pattern. The various
  possible argument pairs are:
  
  =over 4
  
  =item C<name =E<gt> [ @list ]>
  
  A required argument that specifies the name of the pattern, and any
  flags it may take, via a reference to a list of strings. For example:
  
           pattern name => [qw( line of -char )],
                   # other args here
                   ;
  
  This specifies an entry C<$RE{line}{of}>, which may take a C<-char> flag.
  
  Flags may also be specified with a default value, which is then used whenever
  the flag is specified without an explicit value (but not when the flag is
  omitted). For example:
  
           pattern name => [qw( line of -char=_ )],
                   # default char is '_'
                   # other args here
                   ;
  
  
  =item C<create =E<gt> $sub_ref_or_string>
  
  A required argument that specifies either a string that is to be returned
  as the pattern:
  
          pattern name    => [qw( line of underscores )],
                  create  => q/(?:^_+$)/
                  ;
  
  or a reference to a subroutine that will be called to create the pattern:
  
          pattern name    => [qw( line of -char=_ )],
                  create  => sub {
                                  my ($self, $flags) = @_;
                                  my $char = quotemeta $flags->{-char};
                                  return '(?:^$char+$)';
                              },
                  ;
  
  If the subroutine version is used, the subroutine will be called with 
  three arguments: a reference to the pattern object itself, a reference
  to a hash containing the flags and their values,
  and a reference to an array containing the non-flag keys. 
  
  Whatever the subroutine returns is stringified as the pattern.
  
  No matter how the pattern is created, it is immediately postprocessed to
  include or exclude capturing parentheses (according to the value of the
  C<-keep> flag). To specify such "optional" capturing parentheses within
  the regular expression associated with C<create>, use the notation
  C<(?k:...)>. Any parentheses of this type will be converted to C<(...)>
  when the C<-keep> flag is specified, or C<(?:...)> when it is not.
  It is a Regexp::Common convention that the outermost capturing parentheses
  always capture the entire pattern, but this is not enforced.
  
  
  =item C<match =E<gt> $sub_ref>
  
  An optional argument that specifies a subroutine that is to be called when
  the C<$RE{...}-E<gt>matches(...)> method of this pattern is invoked.
  
  The subroutine should expect two arguments: a reference to the pattern object
  itself, and the string to be matched against.
  
  It should return the same types of values as a C<m/.../> does.
  
       pattern name    => [qw( line of -char )],
               create  => sub {...},
               match   => sub {
                               my ($self, $str) = @_;
                               $str !~ /[^$self->{flags}{-char}]/;
                          },
               ;
  
  
  =item C<subs =E<gt> $sub_ref>
  
  An optional argument that specifies a subroutine that is to be called when
  the C<$RE{...}-E<gt>subs(...)> method of this pattern is invoked.
  
  The subroutine should expect three arguments: a reference to the pattern object
  itself, the string to be changed, and the value to be substituted into it.
  The third argument may be C<undef>, indicating the default substitution is
  required.
  
  The subroutine should return the same types of values as an C<s/.../.../> does.
  
  For example:
  
       pattern name    => [ 'lineof', '-char=_' ],
               create  => sub {...},
               subs    => sub {
                            my ($self, $str, $ignore_replacement) = @_;
                            $_[1] =~ s/^$self->{flags}{-char}+$//g;
                          },
               ;
  
  Note that such a subroutine will almost always need to modify C<$_[1]> directly.
  
  
  =item C<version =E<gt> $minimum_perl_version>
  
  If this argument is given, it specifies the minimum version of perl required
  to use the new pattern. Attempts to use the pattern with earlier versions of
  perl will generate a fatal diagnostic.
  
  =back
  
  =head2 Loading specific sets of patterns.
  
  By default, all the sets of patterns listed below are made available.
  However, it is possible to indicate which sets of patterns should
  be made available - the wanted sets should be given as arguments to
  C<use>. Alternatively, it is also possible to indicate which sets of
  patterns should not be made available - those sets will be given as
  argument to the C<use> statement, but are preceded with an exclaimation
  mark. The argument I<no_defaults> indicates none of the default patterns
  should be made available. This is useful for instance if all you want
  is the C<pattern()> subroutine.
  
  Examples:
  
   use Regexp::Common qw /comment number/;  # Comment and number patterns.
   use Regexp::Common qw /no_defaults/;     # Don't load any patterns.
   use Regexp::Common qw /!delimited/;      # All, but delimited patterns.
  
  It's also possible to load your own set of patterns. If you have a
  module C<Regexp::Common::my_patterns> that makes patterns available,
  you can have it made available with
  
   use Regexp::Common qw /my_patterns/;
  
  Note that the default patterns will still be made available - only if
  you use I<no_defaults>, or mention one of the default sets explicitly,
  the non mentioned defaults aren't made available.
  
  =head2 List of available patterns
  
  The patterns listed below are currently available. Each set of patterns
  has its own manual page describing the details. For each pattern set
  named I<name>, the manual page I<Regexp::Common::name> describes the
  details.
  
  Currently available are:
  
  =over 4
  
  =item Regexp::Common::balanced
  
  Provides regexes for strings with balanced parenthesized delimiters.
  
  =item Regexp::Common::comment
  
  Provides regexes for comments of various languages (43 languages
  currently).
  
  =item Regexp::Common::delimited
  
  Provides regexes for delimited strings.
  
  =item Regexp::Common::lingua
  
  Provides regexes for palindromes.
  
  =item Regexp::Common::list
  
  Provides regexes for lists.
  
  =item Regexp::Common::net
  
  Provides regexes for IPv4, IPv6, and MAC addresses.
  
  =item Regexp::Common::number
  
  Provides regexes for numbers (integers and reals).
  
  =item Regexp::Common::profanity
  
  Provides regexes for profanity.
  
  =item Regexp::Common::whitespace
  
  Provides regexes for leading and trailing whitespace.
  
  =item Regexp::Common::zip
  
  Provides regexes for zip codes.
  
  =back
  
  =head2 Forthcoming patterns and features
  
  Future releases of the module will also provide patterns for the following:
  
          * email addresses 
          * HTML/XML tags
          * more numerical matchers,
          * mail headers (including multiline ones),
          * more URLS
          * telephone numbers of various countries
          * currency (universal 3 letter format, Latin-1, currency names)
          * dates
          * binary formats (e.g. UUencoded, MIMEd)
  
  If you have other patterns or pattern generators that you think would be
  generally useful, please send them to the maintainer -- preferably as source
  code using the C<pattern> subroutine. Submissions that include a set of
  tests will be especially welcome.
  
  
  =head1 DIAGNOSTICS
  
  =over 4
  
  =item C<Can't export unknown subroutine %s>
  
  The subroutine-based interface didn't recognize the requested subroutine.
  Often caused by a spelling mistake or an incompletely specified name.
  
          
  =item C<Can't create unknown regex: $RE{...}>
  
  Regexp::Common doesn't have a generator for the requested pattern.
  Often indicates a misspelt or missing parameter.
  
  =item
  C<Perl %f does not support the pattern $RE{...}.
  You need Perl %f or later>
  
  The requested pattern requires advanced regex features (e.g. recursion)
  that not available in your version of Perl. Time to upgrade.
  
  =item C<< pattern() requires argument: name => [ @list ] >>
  
  Every user-defined pattern specification must have a name.
  
  =item C<< pattern() requires argument: create => $sub_ref_or_string >>
  
  Every user-defined pattern specification must provide a pattern creation
  mechanism: either a pattern string or a reference to a subroutine that
  returns the pattern string.
  
  =item C<Base must be between 1 and 36>
  
  The C<< $RE{num}{real}{-base=>'I<N>'} >> pattern uses the characters [0-9A-Z]
  to represent the digits of various bases. Hence it only produces
  regular expressions for bases up to hexatricensimal.
  
  =item C<Must specify delimiter in $RE{delimited}>
  
  The pattern has no default delimiter.
  You need to write: C<< $RE{delimited}{-delim=>I<X>'} >> for some character I<X>
  
  =back
  
  =head1 ACKNOWLEDGEMENTS
  
  Deepest thanks to the many people who have encouraged and contributed to this
  project, especially: Elijah, Jarkko, Tom, Nat, Ed, and Vivek.
  
  Further thanks go to: Alexandr Ciornii, Blair Zajac, Bob Stockdale,
  Charles Thomas, Chris Vertonghen, the CPAN Testers, David Hand,
  Fany, Geoffrey Leach, Hermann-Marcus Behrens, Jerome Quelin, Jim Cromie,
  Lars Wilke, Linda Julien, Mike Arms, Mike Castle, Mikko, Murat Uenalan,
  RafaE<235>l Garcia-Suarez, Ron Savage, Sam Vilain, Slaven Rezic, Smylers,
  Tim Maher, and all the others I've forgotten.
  
  =head1 AUTHOR
  
  Damian Conway (damian@conway.org)
  
  =head1 MAINTENANCE
  
  This package is maintained by Abigail S<(I<regexp-common@abigail.be>)>.
  
  =head1 BUGS AND IRRITATIONS
  
  Bound to be plenty.
  
  For a start, there are many common regexes missing.
  Send them in to I<regexp-common@abigail.be>.
  
  There are some POD issues when installing this module using a pre-5.6.0 perl;
  some manual pages may not install, or may not install correctly using a perl
  that is that old. You might consider upgrading your perl.
  
  =head1 NOT A BUG
  
  =over 4
  
  =item *
  
  The various patterns are not anchored. That is, a pattern like 
  C<< $RE {num} {int} >> will match against "abc4def", because a 
  substring of the subject matches. This is by design, and not a
  bug. If you want the pattern to be anchored, use something like:
  
   my $integer = $RE {num} {int};
   $subj =~ /^$integer$/ and print "Matches!\n";
  
  =back
  
  =head1 LICENSE and COPYRIGHT
  
  This software is Copyright (c) 2001 - 2017, Damian Conway and Abigail.
  
  This module is free software, and maybe used under any of the following
  licenses:
  
   1) The Perl Artistic License.     See the file COPYRIGHT.AL.
   2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2.
   3) The BSD License.               See the file COPYRIGHT.BSD.
   4) The MIT License.               See the file COPYRIGHT.MIT.
REGEXP_COMMON

$fatpacked{"Regexp/Common/CC.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'REGEXP_COMMON_CC';
  package Regexp::Common::CC;
  
  use 5.10.0;
  
  use strict;
  use warnings;
  no  warnings 'syntax';
  
  use Regexp::Common qw /pattern clean no_defaults/;
  use Regexp::Common::_support qw /luhn/;
  
  our $VERSION = '2017060201';
  
  my @cards = (
      # Name           Prefix                    Length           mod 10
      [Mastercard   =>   '5[1-5]',                16,                1],
      [Visa         =>   '4',                     [13, 16],          1],
      [Amex         =>   '3[47]',                 15,                1],
     # Carte Blanche
     ['Diners Club' =>   '3(?:0[0-5]|[68])',      14,                1],
      [Discover     =>   '6011',                  16,                1],
      [enRoute      =>   '2(?:014|149)',          15,                0],
      [JCB          => [['3',                     16,                1],
                        ['2131|1800',             15,                1]]],
  );
  
  
  foreach my $card (@cards) {
      my ($name, $prefix, $length, $mod) = @$card;
  
      # Skip the harder ones for now.
      next if ref $prefix || ref $length;
      next unless $mod;
  
      my $times = $length + $mod;
      pattern name    => [CC => $name],
              create  => sub {
                  use re 'eval';
                  qr <((?=($prefix))[0-9]{$length})
                      (?(?{Regexp::Common::_support::luhn $1})|(?!))>x
              }
      ;
  }
  
  
  
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Regexp::Common::CC -- provide patterns for credit card numbers.
  
  =head1 SYNOPSIS
  
      use Regexp::Common qw /CC/;
  
      while (<>) {
          /^$RE{CC}{Mastercard}$/   and  print "Mastercard card number\n";
      }
  
  =head1 DESCRIPTION
  
  Please consult the manual of L<Regexp::Common> for a general description
  of the works of this interface.
  
  Do not use this module directly, but load it via I<Regexp::Common>.
  
  This module offers patterns for credit card numbers of several major
  credit card types. Currently, the supported cards are: I<Mastercard>,
  I<Amex>, I<Diners Club>, and I<Discover>.
  
  
  =head1 SEE ALSO
  
  L<Regexp::Common> for a general description of how to use this interface.
  
  =over 4
  
  =item L<http://www.beachnet.com/~hstiles/cardtype.html>
  
  Credit Card Validation - Check Digits 
  
  =item L<http://euro.ecom.cmu.edu/resources/elibrary/everycc.htm>
  
  Everything you ever wanted to know about CC's
  
  =item L<http://www.webopedia.com/TERM/L/Luhn_formula.html>
  
  Luhn formula
  
  =back
  
  =head1 AUTHORS
  
  Damian Conway S<(I<damian@conway.org>)> and
  Abigail S<(I<regexp-common@abigail.be>)>.
  
  =head1 MAINTENANCE
  
  This package is maintained by Abigail S<(I<regexp-common@abigail.be>)>.
  
  =head1 BUGS AND IRRITATIONS
  
  Bound to be plenty. Send them in to S<I<regexp-common@abigail.be>>.
  
  =head1 LICENSE and COPYRIGHT
  
  This software is Copyright (c) 2001 - 2017, Damian Conway and Abigail.
  
  This module is free software, and maybe used under any of the following
  licenses:
  
   1) The Perl Artistic License.     See the file COPYRIGHT.AL.
   2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2.
   3) The BSD License.               See the file COPYRIGHT.BSD.
   4) The MIT License.               See the file COPYRIGHT.MIT.
  
  =cut
REGEXP_COMMON_CC

$fatpacked{"Regexp/Common/SEN.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'REGEXP_COMMON_SEN';
  package Regexp::Common::SEN;
  
  use 5.10.0;
  
  use strict;
  use warnings;
  no  warnings 'syntax';
  
  use Regexp::Common qw /pattern clean no_defaults/;
  
  our $VERSION = '2017060201';
  
  =begin does_not_exist
  
  sub par11 {
      my $string = shift;
      my $sum    = 0;
      for my $i (0 .. length ($string) - 1) {
          my $c = substr ($string, $i, 1);
          $sum += $c * (length ($string) - $i)
      }
      !($sum % 11)
  }
  
  =end does_not_exist
  =cut
  
  # http://www.ssa.gov/history/ssn/geocard.html
  pattern name   => [qw /SEN USA SSN -sep=-/],
          create => sub {
              my $sep = $_ [1] {-sep};
              "(?k:(?k:[1-9][0-9][0-9]|0[1-9][0-9]|00[1-9])$sep"   .
                  "(?k:[1-9][0-9]|0[1-9])$sep"                     .
                  "(?k:[1-9][0-9][0-9][0-9]|0[1-9][0-9][0-9]|"     .
                                           "00[1-9][0-9]|000[1-9]))"
          },
          ;
  
  =begin does_not_exist
  
  It's not clear whether this is the right checksum.
  
  # http://www.google.nl/search?q=cache:8m1zKNYrEO0J:www.enschede.nl/nieuw/projecten/aanbesteding/integratie/pve%2520Bijlage%25207.5.doc+Sofi+nummer+formaat&hl=en&start=56&lr=lang_en|lang_nl&ie=UTF-8
  pattern name   => [qw /SEN Netherlands SoFi/],
          create => sub {
              # 9 digits (d1 d2 d3 d4 d5 d6 d7 d8 d9)
              # 9*d1 + 8*d2 + 7*d3 + 6*d4 + 5*d5 + 4*d6 + 3*d7 + 2*d8 + 1*d9 
              # == 0 mod 11.
              qr /([0-9]{9})(?(?{par11 ($^N)})|(?!))/;
          }
          ;
  
  =end does_not_exist
  =cut
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Regexp::Common::SEN -- provide regexes for Social-Economical Numbers.
  
  =head1 SYNOPSIS
  
   use Regexp::Common qw /SEN/;
  
   while (<>) {
       /^$RE{SEN}{USA}{SSN}$/    and  print "Social Security Number\n";
   }
  
  
  =head1 DESCRIPTION
  
  Please consult the manual of L<Regexp::Common> for a general description
  of the works of this interface.
  
  Do not use this module directly, but load it via I<Regexp::Common>.
  
  =head2 C<$RE{SEN}{USA}{SSN}{-sep}>
  
  Returns a pattern that matches an American Social Security Number (SSN).
  SSNs consist of three groups of numbers, separated by a hyphen (C<->).
  This pattern only checks for a valid structure, that is, it validates
  whether a number is valid SSN, was a valid SSN, or maybe a valid SSN
  in the future. There are almost a billion possible SSNs, and about 
  400 million are in use, or have been in use. 
  
  If C<-sep=I<P>> is specified, the pattern I<P> is used as the
  separator between the groups of numbers.
  
  Under C<-keep> (see L<Regexp::Common>):
  
  =over 4
  
  =item $1
  
  captures the entire SSN.
  
  =item $2
  
  captures the first group of digits (the area number).
  
  =item $3
  
  captures the second group of digits (the group number).
  
  =item $4
  
  captures the third group of digits (the serial number).
  
  =back
  
  =head1 SEE ALSO
  
  L<Regexp::Common> for a general description of how to use this interface.
  
  =head1 AUTHORS
  
  Damian Conway and Abigail.
  
  =head1 MAINTENANCE
  
  This package is maintained by Abigail S<(I<regexp-common@abigail.be>)>.
  
  =head1 BUGS AND IRRITATIONS
  
  Bound to be plenty.
  
  For a start, there are many common regexes missing.
  Send them in to I<regexp-common@abigail.be>.
  
  =head1 LICENSE and COPYRIGHT
  
  This software is Copyright (c) 2001 - 2017, Damian Conway and Abigail.
  
  This module is free software, and maybe used under any of the following
  licenses:
  
   1) The Perl Artistic License.     See the file COPYRIGHT.AL.
   2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2.
   3) The BSD License.               See the file COPYRIGHT.BSD.
   4) The MIT License.               See the file COPYRIGHT.MIT.
  
  =cut
REGEXP_COMMON_SEN

$fatpacked{"Regexp/Common/URI.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'REGEXP_COMMON_URI';
  package Regexp::Common::URI;
  
  use 5.10.0;
  
  use strict;
  use warnings;
  no  warnings 'syntax';
  
  use Exporter ();
  
  our @ISA       = qw /Exporter/;
  our @EXPORT_OK = qw /register_uri/;
  
  use Regexp::Common qw /pattern clean no_defaults/;
  
  our $VERSION = '2017060201';
  
  # Use 'require' here, not 'use', so we delay running them after we are compiled.
  # We also do it using an 'eval'; this saves us from have repeated similar
  # lines. The eval is further explained in 'perldoc -f require'.
  my @uris = qw /fax file ftp gopher http pop prospero news tel telnet tv wais/;
  foreach my $uri (@uris) {
      eval "require Regexp::Common::URI::$uri";
      die $@ if $@;
  }
  
  my %uris;
  
  sub register_uri {
      my ($scheme, $uri) = @_;
      $uris {$scheme} = $uri;
  }
  
  pattern name    => [qw (URI)],
          create  => sub {my $uri =  join '|' => values %uris;
                             $uri =~ s/\(\?k:/(?:/g;
                        "(?k:$uri)";
          },
          ;
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Regexp::Common::URI -- provide patterns for URIs.
  
  =head1 SYNOPSIS
  
      use Regexp::Common qw /URI/;
  
      while (<>) {
          /$RE{URI}{HTTP}/       and  print "Contains an HTTP URI.\n";
      }
  
  =head1 DESCRIPTION
  
  Patterns for the following URIs are supported: fax, file, FTP, gopher,
  HTTP, news, NTTP, pop, prospero, tel, telnet, tv and WAIS.
  Each is documented in the I<Regexp::Common::URI::B<scheme>>,
  manual page, for the appropriate scheme (in lowercase), except for
  I<NNTP> URIs which are found in I<Regexp::Common::URI::news>.
  
  =head2 C<$RE{URI}>
  
  Return a pattern that recognizes any of the supported URIs. With
  C<{-keep}>, only the entire URI is returned (in C<$1>).
  
  =head1 REFERENCES
  
  =over 4
  
  =item B<[DRAFT-URI-TV]>
  
  Zigmond, D. and Vickers, M: I<Uniform Resource Identifiers for
  Television Broadcasts>. December 2000.
  
  =item B<[DRAFT-URL-FTP]>
  
  Casey, James: I<A FTP URL Format>. November 1996.
  
  =item B<[RFC 1035]>
  
  Mockapetris, P.: I<DOMAIN NAMES - IMPLEMENTATION AND SPECIFICATION>.
  November 1987.
  
  =item B<[RFC 1738]>
  
  Berners-Lee, Tim, Masinter, L., McCahill, M.: I<Uniform Resource
  Locators (URL)>. December 1994.
  
  =item B<[RFC 2396]>
  
  Berners-Lee, Tim, Fielding, R., and Masinter, L.: I<Uniform Resource
  Identifiers (URI): Generic Syntax>. August 1998.
  
  =item B<[RFC 2616]>
  
  Fielding, R., Gettys, J., Mogul, J., Frystyk, H., Masinter, L., 
  Leach, P. and Berners-Lee, Tim: I<Hypertext Transfer Protocol -- HTTP/1.1>.
  June 1999.
  
  =item B<[RFC 2806]>
  
  Vaha-Sipila, A.: I<URLs for Telephone Calls>. April 2000.
  
  =back
  
  =head1 SEE ALSO
  
  L<Regexp::Common> for a general description of how to use this interface.
  
  =head1 AUTHOR
  
  Damian Conway (damian@conway.org)
  
  =head1 MAINTENANCE
  
  This package is maintained by Abigail S<(I<regexp-common@abigail.be>)>.
  
  =head1 BUGS AND IRRITATIONS
  
  Bound to be plenty.
  
  For a start, there are many common regexes missing.
  Send them in to I<regexp-common@abigail.be>.
  
  =head1 LICENSE and COPYRIGHT
  
  This software is Copyright (c) 2001 - 2017, Damian Conway and Abigail.
  
  This module is free software, and maybe used under any of the following
  licenses:
  
   1) The Perl Artistic License.     See the file COPYRIGHT.AL.
   2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2.
   3) The BSD License.               See the file COPYRIGHT.BSD.
   4) The MIT License.               See the file COPYRIGHT.MIT.
  
  =cut
REGEXP_COMMON_URI

$fatpacked{"Regexp/Common/URI/RFC1035.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'REGEXP_COMMON_URI_RFC1035';
  package Regexp::Common::URI::RFC1035;
  
  use Regexp::Common qw /pattern clean no_defaults/;
  
  use strict;
  use warnings;
  
  use vars qw /$VERSION/;
  $VERSION = '2017060201';
  
  use vars qw /@EXPORT @EXPORT_OK %EXPORT_TAGS @ISA/;
  
  use Exporter ();
  @ISA = qw /Exporter/;
  
  my %vars;
  
  BEGIN {
      $vars {low}     = [qw /$digit $letter $let_dig $let_dig_hyp $ldh_str/];
      $vars {parts}   = [qw /$label $subdomain/];
      $vars {domain}  = [qw /$domain/];
  }
  
  use vars map {@$_} values %vars;
  
  @EXPORT      = qw /$host/;
  @EXPORT_OK   = map {@$_} values %vars;
  %EXPORT_TAGS = (%vars, ALL => [@EXPORT_OK]);
  
  # RFC 1035.
  $digit             = "[0-9]";
  $letter            = "[A-Za-z]";
  $let_dig           = "[A-Za-z0-9]";
  $let_dig_hyp       = "[-A-Za-z0-9]";
  $ldh_str           = "(?:[-A-Za-z0-9]+)";
  $label             = "(?:$letter(?:(?:$ldh_str){0,61}$let_dig)?)";
  $subdomain         = "(?:$label(?:[.]$label)*)";
  $domain            = "(?: |(?:$subdomain))";
  
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Regexp::Common::URI::RFC1035 -- Definitions from RFC1035;
  
  =head1 SYNOPSIS
  
      use Regexp::Common::URI::RFC1035 qw /:ALL/;
  
  =head1 DESCRIPTION
  
  This package exports definitions from RFC1035. It's intended
  usage is for Regexp::Common::URI submodules only. Its interface
  might change without notice.
  
  =head1 REFERENCES
  
  =over 4
  
  =item B<[RFC 1035]>
  
  Mockapetris, P.: I<DOMAIN NAMES - IMPLEMENTATION AND SPECIFICATION>.
  November 1987.
  
  =back
  
  =head1 AUTHOR
  
  Damian Conway (damian@conway.org)
  
  =head1 MAINTENANCE
  
  This package is maintained by Abigail S<(I<regexp-common@abigail.be>)>.
  
  =head1 BUGS AND IRRITATIONS
  
  Bound to be plenty.
  
  =head1 LICENSE and COPYRIGHT
  
  This software is Copyright (c) 2001 - 2017, Damian Conway and Abigail.
  
  This module is free software, and maybe used under any of the following
  licenses:
  
   1) The Perl Artistic License.     See the file COPYRIGHT.AL.
   2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2.
   3) The BSD License.               See the file COPYRIGHT.BSD.
   4) The MIT License.               See the file COPYRIGHT.MIT.
  
  =cut
REGEXP_COMMON_URI_RFC1035

$fatpacked{"Regexp/Common/URI/RFC1738.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'REGEXP_COMMON_URI_RFC1738';
  package Regexp::Common::URI::RFC1738;
  
  use Regexp::Common qw /pattern clean no_defaults/;
  
  use strict;
  use warnings;
  
  use vars qw /$VERSION/;
  $VERSION = '2017060201';
  
  use vars qw /@EXPORT @EXPORT_OK %EXPORT_TAGS @ISA/;
  
  use Exporter ();
  @ISA = qw /Exporter/;
  
  
  my %vars;
  
  BEGIN {
      $vars {low}     = [qw /$digit $digits $hialpha $lowalpha $alpha $alphadigit
                             $safe $extra $national $punctuation $unreserved
                             $unreserved_range $reserved $uchar $uchars $xchar
                             $xchars $hex $escape/];
  
      $vars {connect} = [qw /$port $hostnumber $toplabel $domainlabel $hostname
                             $host $hostport $user $password $login/];
  
      $vars {parts}   = [qw /$fsegment $fpath $group $article $grouppart
                             $search $database $wtype $wpath $psegment
                             $fieldname $fieldvalue $fieldspec $ppath/];
  }
  
  use vars map {@$_} values %vars;
  
  @EXPORT      = qw /$host/;
  @EXPORT_OK   = map {@$_} values %vars;
  %EXPORT_TAGS = (%vars, ALL => [@EXPORT_OK]);
  
  # RFC 1738, base definitions.
  
  # Lowlevel definitions.
  $digit             =  '[0-9]';
  $digits            =  '[0-9]+';
  $hialpha           =  '[A-Z]';
  $lowalpha          =  '[a-z]';
  $alpha             =  '[a-zA-Z]';                 # lowalpha | hialpha
  $alphadigit        =  '[a-zA-Z0-9]';              # alpha    | digit
  $safe              =  '[-$_.+]';
  $extra             =  "[!*'(),]";
  $national          =  '[][{}|\\^~`]';
  $punctuation       =  '[<>#%"]';
  $unreserved_range  = q [-a-zA-Z0-9$_.+!*'(),];  # alphadigit | safe | extra
  $unreserved        =  "[$unreserved_range]";
  $reserved          =  '[;/?:@&=]';
  $hex               =  '[a-fA-F0-9]';
  $escape            =  "(?:%$hex$hex)";
  $uchar             =  "(?:$unreserved|$escape)";
  $uchars            =  "(?:(?:$unreserved|$escape)*)";
  $xchar             =  "(?:[$unreserved_range;/?:\@&=]|$escape)";
  $xchars            =  "(?:(?:[$unreserved_range;/?:\@&=]|$escape)*)";
  
  # Connection related stuff.
  $port              =  "(?:$digits)";
  $hostnumber        =  "(?:$digits\[.]$digits\[.]$digits\[.]$digits)";
  $toplabel          =  "(?:$alpha\[-a-zA-Z0-9]*$alphadigit|$alpha)";
  $domainlabel       =  "(?:(?:$alphadigit\[-a-zA-Z0-9]*)?$alphadigit)";
  $hostname          =  "(?:(?:$domainlabel\[.])*$toplabel)";
  $host              =  "(?:$hostname|$hostnumber)";
  $hostport          =  "(?:$host(?::$port)?)";
  
  $user              =  "(?:(?:[$unreserved_range;?&=]|$escape)*)";
  $password          =  "(?:(?:[$unreserved_range;?&=]|$escape)*)";
  $login             =  "(?:(?:$user(?::$password)?\@)?$hostport)";
  
  # Parts (might require more if we add more URIs).
  
  # FTP/file
  $fsegment          =  "(?:(?:[$unreserved_range:\@&=]|$escape)*)";
  $fpath             =  "(?:$fsegment(?:/$fsegment)*)";
  
  # NNTP/news.
  $group             =  "(?:$alpha\[-A-Za-z0-9.+_]*)";
  $article           =  "(?:(?:[$unreserved_range;/?:&=]|$escape)+" .
                        '@' . "$host)";
  $grouppart         =  "(?:[*]|$article|$group)"; # It's important that
                                                   # $article goes before
                                                   # $group.
  
  # WAIS.
  $search            =  "(?:(?:[$unreserved_range;:\@&=]|$escape)*)";
  $database          =  $uchars;
  $wtype             =  $uchars;
  $wpath             =  $uchars;
  
  # prospero
  $psegment          =  "(?:(?:[$unreserved_range?:\@&=]|$escape)*)";
  $fieldname         =  "(?:(?:[$unreserved_range?:\@&]|$escape)*)";
  $fieldvalue        =  "(?:(?:[$unreserved_range?:\@&]|$escape)*)";
  $fieldspec         =  "(?:;$fieldname=$fieldvalue)";
  $ppath             =  "(?:$psegment(?:/$psegment)*)";
  
  #
  # The various '(?:(?:[$unreserved_range ...]|$escape)*)' above need
  # some loop unrolling to speed up the match.
  #
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Regexp::Common::URI::RFC1738 -- Definitions from RFC1738;
  
  =head1 SYNOPSIS
  
      use Regexp::Common::URI::RFC1738 qw /:ALL/;
  
  =head1 DESCRIPTION
  
  This package exports definitions from RFC1738. It's intended
  usage is for Regexp::Common::URI submodules only. Its interface
  might change without notice.
  
  =head1 REFERENCES
  
  =over 4
  
  =item B<[RFC 1738]>
  
  Berners-Lee, Tim, Masinter, L., McCahill, M.: I<Uniform Resource
  Locators (URL)>. December 1994.
  
  =back
  
  =head1 AUTHOR
  
  Abigail S<(I<regexp-common@abigail.be>)>.
  
  =head1 BUGS AND IRRITATIONS
  
  Bound to be plenty.
  
  =head1 LICENSE and COPYRIGHT
  
  This software is Copyright (c) 2001 - 2017, Damian Conway and Abigail.
  
  This module is free software, and maybe used under any of the following
  licenses:
  
   1) The Perl Artistic License.     See the file COPYRIGHT.AL.
   2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2.
   3) The BSD License.               See the file COPYRIGHT.BSD.
   4) The MIT License.               See the file COPYRIGHT.MIT.
  
  =cut
REGEXP_COMMON_URI_RFC1738

$fatpacked{"Regexp/Common/URI/RFC1808.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'REGEXP_COMMON_URI_RFC1808';
  package Regexp::Common::URI::RFC1808;
  
  BEGIN {
      # This makes sure 'use warnings' doesn't bomb out on 5.005_*;
      # warnings won't be enabled on those old versions though.
      if ($] < 5.006 && !exists $INC {"warnings.pm"}) {
          $INC {"warnings.pm"} = 1;
          no strict 'refs';
          *{"warnings::unimport"} = sub {0};
      }
  }
  
  use strict;
  use warnings;
  
  use vars qw /$VERSION/;
  $VERSION = '2017060201';
  
  use vars qw /@EXPORT @EXPORT_OK %EXPORT_TAGS @ISA/;
  
  use Exporter ();
  @ISA = qw /Exporter/;
  
  
  my %vars;
  
  BEGIN {
      $vars {low}     = [qw /$punctuation $reserved_range $reserved $national
                             $extra $safe $digit $digits $hialpha $lowalpha
                             $alpha $alphadigit $hex $escape $unreserved_range
                             $unreserved $uchar $uchars $pchar_range $pchar
                             $pchars/],
  
      $vars {parts}   = [qw /$fragment $query $param $params $segment
                             $fsegment $path $net_loc $scheme $rel_path
                             $abs_path $net_path $relativeURL $generic_RL
                             $absoluteURL $URL/],
  }
  
  use vars map {@$_} values %vars;
  
  @EXPORT      = qw /$host/;
  @EXPORT_OK   = map {@$_} values %vars;
  %EXPORT_TAGS = (%vars, ALL => [@EXPORT_OK]);
  
  # RFC 1808, base definitions.
  
  # Lowlevel definitions.
  $punctuation       =  '[<>#%"]';
  $reserved_range    = q [;/?:@&=];
  $reserved          =  "[$reserved_range]";
  $national          =  '[][{}|\\^~`]';
  $extra             =  "[!*'(),]";
  $safe              =  '[-$_.+]';
  
  $digit             =  '[0-9]';
  $digits            =  '[0-9]+';
  $hialpha           =  '[A-Z]';
  $lowalpha          =  '[a-z]';
  $alpha             =  '[a-zA-Z]';                 # lowalpha | hialpha
  $alphadigit        =  '[a-zA-Z0-9]';              # alpha    | digit
  
  $hex               =  '[a-fA-F0-9]';
  $escape            =  "(?:%$hex$hex)";
  
  $unreserved_range  = q [-a-zA-Z0-9$_.+!*'(),];  # alphadigit | safe | extra
  $unreserved        =  "[$unreserved_range]";
  $uchar             =  "(?:$unreserved|$escape)";
  $uchars            =  "(?:(?:$unreserved+|$escape)*)";
  
  $pchar_range       = qq [$unreserved_range:\@&=];
  $pchar             =  "(?:[$pchar_range]|$escape)";
  $pchars            =  "(?:(?:[$pchar_range]+|$escape)*)";
  
  
  # Parts
  $fragment          =  "(?:(?:[$unreserved_range$reserved_range]+|$escape)*)";
  $query             =  "(?:(?:[$unreserved_range$reserved_range]+|$escape)*)";
  
  $param             =  "(?:(?:[$pchar_range/]+|$escape)*)";
  $params            =  "(?:$param(?:;$param)*)";
  
  $segment           =  "(?:(?:[$pchar_range]+|$escape)*)";
  $fsegment          =  "(?:(?:[$pchar_range]+|$escape)+)";
  $path              =  "(?:$fsegment(?:/$segment)*)";
  
  $net_loc           =  "(?:(?:[$pchar_range;?]+|$escape)*)";
  $scheme            =  "(?:(?:[-a-zA-Z0-9+.]+|$escape)+)";
  
  $rel_path          =  "(?:$path?(?:;$params)?(?:?$query)?)";
  $abs_path          =  "(?:/$rel_path)";
  $net_path          =  "(?://$net_loc$abs_path?)";
  
  $relativeURL       =  "(?:$net_path|$abs_path|$rel_path)";
  $generic_RL        =  "(?:$scheme:$relativeURL)";
  $absoluteURL       =  "(?:$generic_RL|" .
                  "(?:$scheme:(?:[$unreserved_range$reserved_range]+|$escape)*))";
  $URL               =  "(?:(?:$absoluteURL|$relativeURL)(?:#$fragment)?)";
  
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Regexp::Common::URI::RFC1808 -- Definitions from RFC1808;
  
  =head1 SYNOPSIS
  
      use Regexp::Common::URI::RFC1808 qw /:ALL/;
  
  =head1 DESCRIPTION
  
  This package exports definitions from RFC1808. It's intended
  usage is for Regexp::Common::URI submodules only. Its interface
  might change without notice.
  
  =head1 REFERENCES
  
  =over 4
  
  =item B<[RFC 1808]>
  
  Fielding, R.: I<Relative Uniform Resource Locators (URL)>. June 1995.
  
  =back
  
  =head1 AUTHOR
  
  Damian Conway (damian@conway.org)
  
  =head1 MAINTENANCE
  
  This package is maintained by Abigail S<(I<regexp-common@abigail.be>)>.
  
  =head1 BUGS AND IRRITATIONS
  
  Bound to be plenty.
  
  =head1 LICENSE and COPYRIGHT
  
  This software is Copyright (c) 2001 - 2017, Damian Conway and Abigail.
  
  This module is free software, and maybe used under any of the following
  licenses:
  
   1) The Perl Artistic License.     See the file COPYRIGHT.AL.
   2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2.
   3) The BSD License.               See the file COPYRIGHT.BSD.
   4) The MIT License.               See the file COPYRIGHT.MIT.
  
  =cut
REGEXP_COMMON_URI_RFC1808

$fatpacked{"Regexp/Common/URI/RFC2384.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'REGEXP_COMMON_URI_RFC2384';
  package Regexp::Common::URI::RFC2384;
  
  
  use Regexp::Common qw /pattern clean no_defaults/;
  use Regexp::Common::URI::RFC1738 qw /$unreserved_range $escape $hostport/;
  
  use strict;
  use warnings;
  
  use vars qw /$VERSION/;
  $VERSION = '2017060201';
  
  use vars qw /@EXPORT @EXPORT_OK %EXPORT_TAGS @ISA/;
  
  use Exporter ();
  @ISA = qw /Exporter/;
  
  
  my %vars;
  
  BEGIN {
      $vars {low}     = [qw /$achar_range $achar $achars $achar_more/];
      $vars {connect} = [qw /$enc_sasl $enc_user $enc_ext $enc_auth_type $auth
                             $user_auth $server/];
      $vars {parts}   = [qw /$pop_url/];
  }
  
  use vars map {@$_} values %vars;
  
  @EXPORT      = qw /$host/;
  @EXPORT_OK   = map {@$_} values %vars;
  %EXPORT_TAGS = (%vars, ALL => [@EXPORT_OK]);
  
  # RFC 2384, POP3.
  
  # Lowlevel definitions.
  $achar_range       =  "$unreserved_range&=~";
  $achar             =  "(?:[$achar_range]|$escape)";
  $achars            =  "(?:(?:[$achar_range]+|$escape)*)";
  $achar_more        =  "(?:(?:[$achar_range]+|$escape)+)";
  $enc_sasl          =  $achar_more;
  $enc_user          =  $achar_more;
  $enc_ext           =  "(?:[+](?:APOP|$achar_more))";
  $enc_auth_type     =  "(?:$enc_sasl|$enc_ext)";
  $auth              =  "(?:;AUTH=(?:[*]|$enc_auth_type))";
  $user_auth         =  "(?:$enc_user$auth?)";
  $server            =  "(?:(?:$user_auth\@)?$hostport)";
  $pop_url           =  "(?:pop://$server)";
  
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Regexp::Common::URI::RFC2384 -- Definitions from RFC2384;
  
  =head1 SYNOPSIS
  
      use Regexp::Common::URI::RFC2384 qw /:ALL/;
  
  =head1 DESCRIPTION
  
  This package exports definitions from RFC2384. It's intended
  usage is for Regexp::Common::URI submodules only. Its interface
  might change without notice.
  
  =head1 REFERENCES
  
  =over 4
  
  =item B<[RFC 2384]>
  
  Gellens, R.: I<POP URL scheme> August 1998.
  
  =back
  
  =head1 AUTHOR
  
  Abigail S<(I<regexp-common@abigail.be>)>.
  
  =head1 BUGS AND IRRITATIONS
  
  Bound to be plenty.
  
  =head1 LICENSE and COPYRIGHT
  
  This software is Copyright (c) 2001 - 2017, Damian Conway and Abigail.
  
  This module is free software, and maybe used under any of the following
  licenses:
  
   1) The Perl Artistic License.     See the file COPYRIGHT.AL.
   2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2.
   3) The BSD License.               See the file COPYRIGHT.BSD.
   4) The MIT License.               See the file COPYRIGHT.MIT.
  
  =cut
REGEXP_COMMON_URI_RFC2384

$fatpacked{"Regexp/Common/URI/RFC2396.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'REGEXP_COMMON_URI_RFC2396';
  package Regexp::Common::URI::RFC2396;
  
  use Regexp::Common qw /pattern clean no_defaults/;
  
  use strict;
  use warnings;
  
  use vars qw /$VERSION/;
  $VERSION = '2017060201';
  
  use vars qw /@EXPORT @EXPORT_OK %EXPORT_TAGS @ISA/;
  
  use Exporter ();
  @ISA = qw /Exporter/;
  
  
  my %vars;
  
  BEGIN {
      $vars {low}     = [qw /$digit $upalpha $lowalpha $alpha $alphanum $hex
                             $escaped $mark $unreserved $reserved $pchar $uric
                             $urics $userinfo $userinfo_no_colon $uric_no_slash/];
      $vars {parts}   = [qw /$query $fragment $param $segment $path_segments
                             $ftp_segments $rel_segment $abs_path $rel_path
                             $path/];
      $vars {connect} = [qw /$port $IPv4address $toplabel $domainlabel $hostname
                             $host $hostport $server $reg_name $authority/];
      $vars {URI}     = [qw /$scheme $net_path $opaque_part $hier_part
                             $relativeURI $absoluteURI $URI_reference/];
  }
  
  use vars map {@$_} values %vars;
  
  @EXPORT      = ();
  @EXPORT_OK   = map {@$_} values %vars;
  %EXPORT_TAGS = (%vars, ALL => [@EXPORT_OK]);
  
  # RFC 2396, base definitions.
  $digit             =  '[0-9]';
  $upalpha           =  '[A-Z]';
  $lowalpha          =  '[a-z]';
  $alpha             =  '[a-zA-Z]';                # lowalpha | upalpha
  $alphanum          =  '[a-zA-Z0-9]';             # alpha    | digit
  $hex               =  '[a-fA-F0-9]';
  $escaped           =  "(?:%$hex$hex)";
  $mark              =  "[\\-_.!~*'()]";
  $unreserved        =  "[a-zA-Z0-9\\-_.!~*'()]";  # alphanum | mark
                        # %61-%7A, %41-%5A, %30-%39
                        #  a - z    A - Z    0 - 9
                        # %21, %27, %28, %29, %2A, %2D, %2E, %5F, %7E
                        #  !    '    (    )    *    -    .    _    ~
  $reserved          =  "[;/?:@&=+\$,]";
  $pchar             =  "(?:[a-zA-Z0-9\\-_.!~*'():\@&=+\$,]|$escaped)";
                                        # unreserved | escaped | [:@&=+$,]
  $uric              =  "(?:[;/?:\@&=+\$,a-zA-Z0-9\\-_.!~*'()]|$escaped)";
                                        # reserved | unreserved | escaped
  $urics             =  "(?:(?:[;/?:\@&=+\$,a-zA-Z0-9\\-_.!~*'()]+|"     .
                        "$escaped)*)";
  
  $query             =  $urics;
  $fragment          =  $urics;
  $param             =  "(?:(?:[a-zA-Z0-9\\-_.!~*'():\@&=+\$,]+|$escaped)*)";
  $segment           =  "(?:$param(?:;$param)*)";
  $path_segments     =  "(?:$segment(?:/$segment)*)";
  $ftp_segments      =  "(?:$param(?:/$param)*)";   # NOT from RFC 2396.
  $rel_segment       =  "(?:(?:[a-zA-Z0-9\\-_.!~*'();\@&=+\$,]*|$escaped)+)";
  $abs_path          =  "(?:/$path_segments)";
  $rel_path          =  "(?:$rel_segment(?:$abs_path)?)";
  $path              =  "(?:(?:$abs_path|$rel_path)?)";
  
  $port              =  "(?:$digit*)";
  $IPv4address       =  "(?:$digit+[.]$digit+[.]$digit+[.]$digit+)";
  $toplabel          =  "(?:$alpha"."[-a-zA-Z0-9]*$alphanum|$alpha)";
  $domainlabel       =  "(?:(?:$alphanum"."[-a-zA-Z0-9]*)?$alphanum)";
  $hostname          =  "(?:(?:$domainlabel\[.])*$toplabel\[.]?)";
  $host              =  "(?:$hostname|$IPv4address)";
  $hostport          =  "(?:$host(?::$port)?)";
  
  $userinfo          =  "(?:(?:[a-zA-Z0-9\\-_.!~*'();:&=+\$,]+|$escaped)*)";
  $userinfo_no_colon =  "(?:(?:[a-zA-Z0-9\\-_.!~*'();&=+\$,]+|$escaped)*)";
  $server            =  "(?:(?:$userinfo\@)?$hostport)";
  
  $reg_name          =  "(?:(?:[a-zA-Z0-9\\-_.!~*'()\$,;:\@&=+]*|$escaped)+)";
  $authority         =  "(?:$server|$reg_name)";
  
  $scheme            =  "(?:$alpha"."[a-zA-Z0-9+\\-.]*)";
  
  $net_path          =  "(?://$authority$abs_path?)";
  $uric_no_slash     =  "(?:[a-zA-Z0-9\\-_.!~*'();?:\@&=+\$,]|$escaped)";
  $opaque_part       =  "(?:$uric_no_slash$urics)";
  $hier_part         =  "(?:(?:$net_path|$abs_path)(?:[?]$query)?)";
  
  $relativeURI       =  "(?:(?:$net_path|$abs_path|$rel_path)(?:[?]$query)?";
  $absoluteURI       =  "(?:$scheme:(?:$hier_part|$opaque_part))";
  $URI_reference     =  "(?:(?:$absoluteURI|$relativeURI)?(?:#$fragment)?)";
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Regexp::Common::URI::RFC2396 -- Definitions from RFC2396;
  
  =head1 SYNOPSIS
  
      use Regexp::Common::URI::RFC2396 qw /:ALL/;
  
  =head1 DESCRIPTION
  
  This package exports definitions from RFC2396. It's intended
  usage is for Regexp::Common::URI submodules only. Its interface
  might change without notice.
  
  =head1 REFERENCES
  
  =over 4
  
  =item B<[RFC 2396]>
  
  Berners-Lee, Tim, Fielding, R., and Masinter, L.: I<Uniform Resource
  Identifiers (URI): Generic Syntax>. August 1998.
  
  =back
  
  =head1 AUTHOR
  
  Damian Conway (damian@conway.org)
  
  =head1 MAINTENANCE
  
  This package is maintained by Abigail S<(I<regexp-common@abigail.be>)>.
  
  =head1 BUGS AND IRRITATIONS
  
  Bound to be plenty.
  
  =head1 LICENSE and COPYRIGHT
  
  This software is Copyright (c) 2001 - 2017, Damian Conway and Abigail.
  
  This module is free software, and maybe used under any of the following
  licenses:
  
   1) The Perl Artistic License.     See the file COPYRIGHT.AL.
   2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2.
   3) The BSD License.               See the file COPYRIGHT.BSD.
   4) The MIT License.               See the file COPYRIGHT.MIT.
  
  =cut
REGEXP_COMMON_URI_RFC2396

$fatpacked{"Regexp/Common/URI/RFC2806.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'REGEXP_COMMON_URI_RFC2806';
  package Regexp::Common::URI::RFC2806;
  
  use Regexp::Common::URI::RFC1035 qw /$domain/;
  use Regexp::Common::URI::RFC2396 qw /$unreserved $escaped $hex/;
  
  use strict;
  use warnings;
  
  use vars qw /$VERSION/;
  $VERSION = '2017060201';
  
  use vars qw /@EXPORT @EXPORT_OK %EXPORT_TAGS @ISA/;
  
  use Exporter ();
  @ISA = qw /Exporter/;
  
  
  my %vars;
  
  BEGIN {
      $vars {low}     = [qw /$dtmf_digit $wait_for_dial_tone $one_second_pause
                             $pause_character $visual_separator $phonedigit
                             $escaped_no_dquote $quoted_string $token_char
                             $token_chars/];
      $vars {parts}   = [qw /$future_extension/];
      $vars {connect} = [qw /$provider_hostname $provider_tag $service_provider
                             $private_prefix $local_network_prefix 
                             $global_network_prefix $network_prefix/];
      $vars {phone}   = [qw /$phone_context_ident $phone_context_tag
                             $area_specifier $post_dial $isdn_subaddress
                             $t33_subaddress $local_phone_number
                             $local_phone_number_no_future
                             $base_phone_number $global_phone_number
                             $global_phone_number_no_future $telephone_subscriber
                             $telephone_subscriber_no_future/];
      $vars {fax}     = [qw /$fax_local_phone $fax_local_phone_no_future
                             $fax_global_phone $fax_global_phone_no_future
                             $fax_subscriber $fax_subscriber_no_future/];
      $vars {modem}   = [qw //];
  }
  
  use vars map {@$_} values %vars;
  
  @EXPORT      = ();
  @EXPORT_OK   = map {@$_} values %vars;
  %EXPORT_TAGS = (%vars, ALL => [@EXPORT_OK]);
  
  
  # RFC 2806, URIs for tel, fax & modem.
  $dtmf_digit        =  "(?:[*#ABCD])";
  $wait_for_dial_tone=  "(?:w)";
  $one_second_pause  =  "(?:p)";
  $pause_character   =  "(?:[wp])";   # wait_for_dial_tone | one_second_pause.
  $visual_separator  =  "(?:[\\-.()])";
  $phonedigit        =  "(?:[0-9\\-.()])";  # DIGIT | visual_separator
  $escaped_no_dquote =  "(?:%(?:[01]$hex)|2[013-9A-Fa-f]|[3-9A-Fa-f]$hex)";
  $quoted_string     =  "(?:%22(?:(?:%5C(?:$unreserved|$escaped))|" .
                                "$unreserved+|$escaped_no_dquote)*%22)";
                        # It is unclear wether we can allow only unreserved
                        # characters to unescaped, or can we also use uric
                        # characters that are unescaped? Or pchars?
  $token_char        =  "(?:[!'*\\-.0-9A-Z_a-z~]|" .
                            "%(?:2[13-7ABDEabde]|3[0-9]|4[1-9A-Fa-f]|" .
                                "5[AEFaef]|6[0-9A-Fa-f]|7[0-9ACEace]))";
                        # Only allowing unreserved chars to be unescaped.
  $token_chars       =  "(?:(?:[!'*\\-.0-9A-Z_a-z~]+|"                   .
                              "%(?:2[13-7ABDEabde]|3[0-9]|4[1-9A-Fa-f]|" .
                                  "5[AEFaef]|6[0-9A-Fa-f]|7[0-9ACEace]))*)";
  $future_extension  =  "(?:;$token_chars"                       .
                        "(?:=(?:(?:$token_chars(?:[?]$token_chars)?)|" .
                        "$quoted_string))?)";
  $provider_hostname =   $domain;
  $provider_tag      =  "(?:tsp)";
  $service_provider  =  "(?:;$provider_tag=$provider_hostname)";
  $private_prefix    =  "(?:(?:[!'E-OQ-VX-Z_e-oq-vx-z~]|"                   .
                           "(?:%(?:2[124-7CFcf]|3[AC-Fac-f]|4[05-9A-Fa-f]|" .
                                  "5[1-689A-Fa-f]|6[05-9A-Fa-f]|"           .
                                  "7[1-689A-Ea-e])))"                       .
                           "(?:[!'()*\\-.0-9A-Z_a-z~]+|"                    .
                           "(?:%(?:2[1-9A-Fa-f]|3[AC-Fac-f]|"               .
                              "[4-6][0-9A-Fa-f]|7[0-9A-Ea-e])))*)";
  $local_network_prefix
                     =  "(?:[0-9\\-.()*#ABCDwp]+)";
  $global_network_prefix
                     =  "(?:[+][0-9\\-.()]+)";
  $network_prefix    =  "(?:$global_network_prefix|$local_network_prefix)";
  $phone_context_ident
                     =  "(?:$network_prefix|$private_prefix)";
  $phone_context_tag =  "(?:phone-context)";
  $area_specifier    =  "(?:;$phone_context_tag=$phone_context_ident)";
  $post_dial         =  "(?:;postd=[0-9\\-.()*#ABCDwp]+)";
  $isdn_subaddress   =  "(?:;isub=[0-9\\-.()]+)";
  $t33_subaddress    =  "(?:;tsub=[0-9\\-.()]+)";
  
  $local_phone_number=  "(?:[0-9\\-.()*#ABCDwp]+$isdn_subaddress?"      .
                           "$post_dial?$area_specifier"                 .
                           "(?:$area_specifier|$service_provider|"      .
                              "$future_extension)*)";
  $local_phone_number_no_future
                     =  "(?:[0-9\\-.()*#ABCDwp]+$isdn_subaddress?"      .
                           "$post_dial?$area_specifier"                 .
                           "(?:$area_specifier|$service_provider)*)";
  $fax_local_phone   =  "(?:[0-9\\-.()*#ABCDwp]+$isdn_subaddress?"      .
                           "$t33_subaddress?$post_dial?$area_specifier" .
                           "(?:$area_specifier|$service_provider|"      .
                              "$future_extension)*)";
  $fax_local_phone_no_future
                     =  "(?:[0-9\\-.()*#ABCDwp]+$isdn_subaddress?"      .
                           "$t33_subaddress?$post_dial?$area_specifier" .
                           "(?:$area_specifier|$service_provider)*)";
  $base_phone_number =  "(?:[0-9\\-.()]+)";
  $global_phone_number
                     =  "(?:[+]$base_phone_number$isdn_subaddress?"     .
                                                "$post_dial?"           .
                           "(?:$area_specifier|$service_provider|"      .
                              "$future_extension)*)";
  $global_phone_number_no_future
                     =  "(?:[+]$base_phone_number$isdn_subaddress?"     .
                                                "$post_dial?"           .
                           "(?:$area_specifier|$service_provider)*)";
  $fax_global_phone  =  "(?:[+]$base_phone_number$isdn_subaddress?"     .
                                "$t33_subaddress?$post_dial?"           .
                           "(?:$area_specifier|$service_provider|"      .
                              "$future_extension)*)";
  $fax_global_phone_no_future
                     =  "(?:[+]$base_phone_number$isdn_subaddress?"     .
                                "$t33_subaddress?$post_dial?"           .
                           "(?:$area_specifier|$service_provider)*)";
  $telephone_subscriber
                     =  "(?:$global_phone_number|$local_phone_number)";
  $telephone_subscriber_no_future
                     =  "(?:$global_phone_number_no_future|" .
                           "$local_phone_number_no_future)";
  $fax_subscriber    =  "(?:$fax_global_phone|$fax_local_phone)";
  $fax_subscriber_no_future
                     =  "(?:$fax_global_phone_no_future|"    .
                           "$fax_local_phone_no_future)";
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Regexp::Common::URI::RFC2806 -- Definitions from RFC2806;
  
  =head1 SYNOPSIS
  
      use Regexp::Common::URI::RFC2806 qw /:ALL/;
  
  =head1 DESCRIPTION
  
  This package exports definitions from RFC2806. It's intended
  usage is for Regexp::Common::URI submodules only. Its interface
  might change without notice.
  
  =head1 REFERENCES
  
  =over 4
  
  =item B<[RFC 2616]>
  
  Fielding, R., Gettys, J., Mogul, J., Frystyk, H., Masinter, L., 
  Leach, P. and Berners-Lee, Tim: I<Hypertext Transfer Protocol -- HTTP/1.1>.
  June 1999.
  
  =back
  
  =head1 AUTHOR
  
  Damian Conway (damian@conway.org)
  
  =head1 MAINTENANCE
  
  This package is maintained by Abigail S<(I<regexp-common@abigail.be>)>.
  
  =head1 BUGS AND IRRITATIONS
  
  Bound to be plenty.
  
  =head1 LICENSE and COPYRIGHT
  
  This software is Copyright (c) 2001 - 2017, Damian Conway and Abigail.
  
  This module is free software, and maybe used under any of the following
  licenses:
  
   1) The Perl Artistic License.     See the file COPYRIGHT.AL.
   2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2.
   3) The BSD License.               See the file COPYRIGHT.BSD.
   4) The MIT License.               See the file COPYRIGHT.MIT.
  
  =cut
REGEXP_COMMON_URI_RFC2806

$fatpacked{"Regexp/Common/URI/fax.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'REGEXP_COMMON_URI_FAX';
  package Regexp::Common::URI::fax;
  
  use Regexp::Common               qw /pattern clean no_defaults/;
  use Regexp::Common::URI          qw /register_uri/;
  use Regexp::Common::URI::RFC2806 qw /$fax_subscriber 
                                       $fax_subscriber_no_future/;
  
  use strict;
  use warnings;
  
  use vars qw /$VERSION/;
  $VERSION = '2017060201';
  
  
  my $fax_scheme  = 'fax';
  my $fax_uri     = "(?k:(?k:$fax_scheme):(?k:$fax_subscriber))";
  my $fax_uri_nf  = "(?k:(?k:$fax_scheme):(?k:$fax_subscriber_no_future))";
  
  register_uri $fax_scheme => $fax_uri;
  
  pattern name    => [qw (URI fax)],
          create  => $fax_uri
          ;
  
  pattern name    => [qw (URI fax nofuture)],
          create  => $fax_uri_nf
          ;
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Regexp::Common::URI::fax -- Returns a pattern for fax URIs.
  
  =head1 SYNOPSIS
  
      use Regexp::Common qw /URI/;
  
      while (<>) {
          /$RE{URI}{fax}/       and  print "Contains a fax URI.\n";
      }
  
  =head1 DESCRIPTION
  
  =head2 $RE{URI}{fax}
  
  Returns a pattern that matches I<fax> URIs, as defined by RFC 2806.
  Under C<{-keep}>, the following are returned:
  
  =over 4
  
  =item $1
  
  The complete URI.
  
  =item $2
  
  The scheme.
  
  =item $3
  
  The phone number, including any possible add-ons like ISDN subaddress,
  a post dial part, area specifier, service provider, etc.
  
  =back
  
  =head2 C<$RE{URI}{fax}{nofuture}>
  
  As above (including what's returned by C<{-keep}>), with the exception
  that I<future extensions> are not allowed. Without allowing 
  those I<future extensions>, it becomes much easier to check a URI if
  the correct syntax for post dial, service provider, phone context,
  etc has been used - otherwise the regex could always classify them
  as a I<future extension>.
  
  =head1 REFERENCES
  
  =over 4
  
  =item B<[RFC 1035]>
  
  Mockapetris, P.: I<DOMAIN NAMES - IMPLEMENTATION AND SPECIFICATION>.
  November 1987.
  
  =item B<[RFC 2396]>
  
  Berners-Lee, Tim, Fielding, R., and Masinter, L.: I<Uniform Resource
  Identifiers (URI): Generic Syntax>. August 1998.
  
  =item B<[RFC 2806]>
  
  Vaha-Sipila, A.: I<URLs for Telephone Calls>. April 2000.
  
  =back
  
  =head1 SEE ALSO
  
  L<Regexp::Common::URI> for other supported URIs.
  
  =head1 AUTHOR
  
  Damian Conway (damian@conway.org)
  
  =head1 MAINTENANCE
  
  This package is maintained by Abigail S<(I<regexp-common@abigail.be>)>.
  
  =head1 BUGS AND IRRITATIONS
  
  Bound to be plenty.
  
  =head1 LICENSE and COPYRIGHT
  
  This software is Copyright (c) 2001 - 2017, Damian Conway and Abigail.
  
  This module is free software, and maybe used under any of the following
  licenses:
  
   1) The Perl Artistic License.     See the file COPYRIGHT.AL.
   2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2.
   3) The BSD License.               See the file COPYRIGHT.BSD.
   4) The MIT License.               See the file COPYRIGHT.MIT.
  
  =cut
REGEXP_COMMON_URI_FAX

$fatpacked{"Regexp/Common/URI/file.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'REGEXP_COMMON_URI_FILE';
  package Regexp::Common::URI::file;
  
  use Regexp::Common               qw /pattern clean no_defaults/;
  use Regexp::Common::URI          qw /register_uri/;
  use Regexp::Common::URI::RFC1738 qw /$host $fpath/;
  
  use strict;
  use warnings;
  
  use vars qw /$VERSION/;
  $VERSION = '2017060201';
  
  
  my $scheme = 'file';
  my $uri    = "(?k:(?k:$scheme)://(?k:(?k:(?:$host|localhost)?)" .
               "(?k:/(?k:$fpath))))";
  
  register_uri $scheme => $uri;
  
  pattern name    => [qw (URI file)],
          create  => $uri,
          ;
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Regexp::Common::URI::file -- Returns a pattern for file URIs.
  
  =head1 SYNOPSIS
  
      use Regexp::Common qw /URI/;
  
      while (<>) {
          /$RE{URI}{file}/       and  print "Contains a file URI.\n";
      }
  
  =head1 DESCRIPTION
  
  =head2 $RE{URI}{file}
  
  Returns a pattern that matches I<file> URIs, as defined by RFC 1738.
  File URIs have the form:
  
      "file:" "//" [ host | "localhost" ] "/" fpath
  
  Under C<{-keep}>, the following are returned:
  
  =over 4
  
  =item $1
  
  The complete URI.
  
  =item $2
  
  The scheme.
  
  =item $3
  
  The part of the URI following "file://".
  
  =item $4
  
  The hostname.
  
  =item $5
  
  The path name, including the leading slash.
  
  =item $6
  
  The path name, without the leading slash.
  
  =back
  
  =head1 REFERENCES
  
  =over 4
  
  =item B<[RFC 1738]>
  
  Berners-Lee, Tim, Masinter, L., McCahill, M.: I<Uniform Resource
  Locators (URL)>. December 1994.
  
  =back
  
  =head1 SEE ALSO
  
  L<Regexp::Common::URI> for other supported URIs.
  
  =head1 AUTHOR
  
  Damian Conway (damian@conway.org)
  
  =head1 MAINTENANCE
  
  This package is maintained by Abigail S<(I<regexp-common@abigail.be>)>.
  
  =head1 BUGS AND IRRITATIONS
  
  Bound to be plenty.
  
  =head1 LICENSE and COPYRIGHT
  
  This software is Copyright (c) 2001 - 2017, Damian Conway and Abigail.
  
  This module is free software, and maybe used under any of the following
  licenses:
  
   1) The Perl Artistic License.     See the file COPYRIGHT.AL.
   2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2.
   3) The BSD License.               See the file COPYRIGHT.BSD.
   4) The MIT License.               See the file COPYRIGHT.MIT.
  
  =cut
REGEXP_COMMON_URI_FILE

$fatpacked{"Regexp/Common/URI/ftp.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'REGEXP_COMMON_URI_FTP';
  package Regexp::Common::URI::ftp;
  
  use Regexp::Common               qw /pattern clean no_defaults/;
  use Regexp::Common::URI          qw /register_uri/;
  use Regexp::Common::URI::RFC2396 qw /$host $port $ftp_segments $userinfo
                                       $userinfo_no_colon/;
  
  use strict;
  use warnings;
  
  use vars qw /$VERSION/;
  $VERSION = '2017060201';
  
  
  my $ftp_uri = "(?k:(?k:ftp)://(?:(?k:$userinfo)(?k:)\@)?(?k:$host)" .
                "(?::(?k:$port))?(?k:/(?k:(?k:$ftp_segments)"         .
                "(?:;type=(?k:[AIai]))?))?)";
  
  my $ftp_uri_password =
                "(?k:(?k:ftp)://(?:(?k:$userinfo_no_colon)"           .
                "(?::(?k:$userinfo_no_colon))?\@)?(?k:$host)"         .
                "(?::(?k:$port))?(?k:/(?k:(?k:$ftp_segments)"         .
                "(?:;type=(?k:[AIai]))?))?)";
  
  register_uri FTP => $ftp_uri;
  
  pattern name    => [qw (URI FTP), "-type=[AIai]", "-password="],
          create  => sub {
              my $uri    =  exists $_ [1] -> {-password} &&
                          !defined $_ [1] -> {-password} ? $ftp_uri_password
                                                         : $ftp_uri;
              my $type   =  $_ [1] -> {-type};
              $uri       =~ s/\[AIai\]/$type/;
              $uri;
          }
          ;
  
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Regexp::Common::URI::ftp -- Returns a pattern for FTP URIs.
  
  =head1 SYNOPSIS
  
      use Regexp::Common qw /URI/;
  
      while (<>) {
          /$RE{URI}{FTP}/       and  print "Contains an FTP URI.\n";
      }
  
  =head1 DESCRIPTION
  
  =head2 $RE{URI}{FTP}{-type}{-password};
  
  Returns a regex for FTP URIs. Note: FTP URIs are not formally defined.
  RFC 1738 defines FTP URLs, but parts of that RFC have been obsoleted
  by RFC 2396. However, the differences between RFC 1738 and RFC 2396 
  are such that they aren't applicable straightforwardly to FTP URIs.
  
  There are two main problems:
  
  =over 4
  
  =item Passwords.
  
  RFC 1738 allowed an optional username and an optional password (separated
  by a colon) in the FTP URL. Hence, colons were not allowed in either the
  username or the password. RFC 2396 strongly recommends passwords should
  not be used in URIs. It does allow for I<userinfo> instead. This userinfo
  part may contain colons, and hence contain more than one colon. The regexp
  returned follows the RFC 2396 specification, unless the I<{-password}>
  option is given; then the regex allows for an optional username and
  password, separated by a colon.
  
  =item The ;type specifier.
  
  RFC 1738 does not allow semi-colons in FTP path names, because a semi-colon
  is a reserved character for FTP URIs. The semi-colon is used to separate
  the path from the option I<type> specifier. However, in RFC 2396, paths
  consist of slash separated segments, and each segment is a semi-colon 
  separated group of parameters. Straigthforward application of RFC 2396
  would mean that a trailing I<type> specifier couldn't be distinguished
  from the last segment of the path having a two parameters, the last one
  starting with I<type=>. Therefore we have opted to disallow a semi-colon
  in the path part of an FTP URI.
  
  Furthermore, RFC 1738 allows three values for the type specifier, I<A>,
  I<I> and I<D> (either upper case or lower case). However, the internet
  draft about FTP URIs B<[DRAFT-FTP-URL]> (which expired in May 1997) notes
  the lack of consistent implementation of the I<D> parameter and drops I<D>
  from the set of possible values. We follow this practise; however, RFC 1738
  behaviour can be archieved by using the I<-type => "[ADIadi]"> parameter.
  
  =back
  
  FTP URIs have the following syntax:
  
      "ftp:" "//" [ userinfo "@" ] host [ ":" port ]
                  [ "/" path [ ";type=" value ]]
  
  When using I<{-password}>, we have the syntax:
  
      "ftp:" "//" [ user [ ":" password ] "@" ] host [ ":" port ]
                  [ "/" path [ ";type=" value ]]
  
  Under C<{-keep}>, the following are returned:
  
  =over 4
  
  =item $1
  
  The complete URI.
  
  =item $2
  
  The scheme.
  
  =item $3
  
  The userinfo, or if I<{-password}> is used, the username.
  
  =item $4
  
  If I<{-password}> is used, the password, else C<undef>.
  
  =item $5
  
  The hostname or IP address.
  
  =item $6
  
  The port number.
  
  =item $7
  
  The full path and type specification, including the leading slash.
  
  =item $8
  
  The full path and type specification, without the leading slash.
  
  =item $9
  
  The full path, without the type specification nor the leading slash.
  
  =item $10
  
  The value of the type specification.
  
  =back
  
  =head1 REFERENCES
  
  =over 4
  
  =item B<[DRAFT-URL-FTP]>
  
  Casey, James: I<A FTP URL Format>. November 1996.
  
  =item B<[RFC 1738]>
  
  Berners-Lee, Tim, Masinter, L., McCahill, M.: I<Uniform Resource
  Locators (URL)>. December 1994.
  
  =item B<[RFC 2396]>
  
  Berners-Lee, Tim, Fielding, R., and Masinter, L.: I<Uniform Resource
  Identifiers (URI): Generic Syntax>. August 1998.
  
  =back
  
  =head1 SEE ALSO
  
  L<Regexp::Common::URI> for other supported URIs.
  
  =head1 AUTHOR
  
  Damian Conway (damian@conway.org)
  
  =head1 MAINTENANCE
  
  This package is maintained by Abigail S<(I<regexp-common@abigail.be>)>.
  
  =head1 BUGS AND IRRITATIONS
  
  Bound to be plenty.
  
  =head1 LICENSE and COPYRIGHT
  
  This software is Copyright (c) 2001 - 2017, Damian Conway and Abigail.
  
  This module is free software, and maybe used under any of the following
  licenses:
  
   1) The Perl Artistic License.     See the file COPYRIGHT.AL.
   2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2.
   3) The BSD License.               See the file COPYRIGHT.BSD.
   4) The MIT License.               See the file COPYRIGHT.MIT.
  
  =cut
REGEXP_COMMON_URI_FTP

$fatpacked{"Regexp/Common/URI/gopher.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'REGEXP_COMMON_URI_GOPHER';
  package Regexp::Common::URI::gopher;
  
  use Regexp::Common               qw /pattern clean no_defaults/;
  use Regexp::Common::URI          qw /register_uri/;
  use Regexp::Common::URI::RFC1738 qw /$host $port $uchars/;
  use Regexp::Common::URI::RFC1808 qw /$pchars $pchar_range/;
  
  use strict;
  use warnings;
  
  use vars qw /$VERSION/;
  $VERSION = '2017060201';
  
  
  my $pchars_notab      = "(?:(?:[$pchar_range]+|" . 
                          "%(?:[1-9a-fA-F][0-9a-fA-F]|0[0-8a-fA-F]))*)";
  
  my $gopherplus_string = $pchars;
  my $search            = $pchars;
  my $search_notab      = $pchars_notab;
  my $selector          = $pchars;
  my $selector_notab    = $pchars_notab;
  my $gopher_type       = "(?:[0-9+IgT])";
  
  my $scheme     = "gopher";
  my $uri        = "(?k:(?k:$scheme)://(?k:$host)(?::(?k:$port))?" .
                   "/(?k:(?k:$gopher_type)(?k:$selector)))";
  my $uri_notab  = "(?k:(?k:$scheme)://(?k:$host)(?::(?k:$port))?"              .
                   "/(?k:(?k:$gopher_type)(?k:$selector_notab)"                 .
                   "(?:%09(?k:$search_notab)(?:%09(?k:$gopherplus_string))?)?))";
  
  register_uri $scheme => $uri;
  
  pattern name    => [qw (URI gopher -notab=)],
          create  => sub { exists $_ [1] {-notab} &&
                         !defined $_ [1] {-notab} ? $uri_notab : $uri},
          ;
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Regexp::Common::URI::gopher -- Returns a pattern for gopher URIs.
  
  =head1 SYNOPSIS
  
      use Regexp::Common qw /URI/;
  
      while (<>) {
          /$RE{URI}{gopher}/       and  print "Contains a gopher URI.\n";
      }
  
  =head1 DESCRIPTION
  
  =head2 $RE{URI}{gopher}{-notab}
  
  Gopher URIs are poorly defined. Originally, RFC 1738 defined gopher URIs,
  but they were later redefined in an internet draft. One that was expired
  in June 1997.
  
  The internet draft for gopher URIs defines them as follows:
  
      "gopher:" "//" host [ ":" port ] "/" gopher-type selector
                          [ "%09" search [ "%09" gopherplus_string ]]
  
  Unfortunally, a I<selector> is defined in such a way that characters
  may be escaped using the URI escape mechanism. This includes tabs,
  which escaped are C<%09>. Hence, the syntax cannot distinguish between
  a URI that has both a I<selector> and a I<search> part, and an URI
  where the I<selector> includes an escaped tab. (The text of the draft
  forbids tabs to be present in the I<selector> though).
  
  C<$RE{URI}{gopher}> follows the defined syntax. To disallow escaped
  tabs in the I<selector> and I<search> parts, use C<$RE{URI}{gopher}{-notab}>.
  
  There are other differences between the text and the given syntax.
  According to the text, selector strings cannot have tabs, linefeeds
  or carriage returns in them. The text also allows the entire I<gopher-path>,
  (the part after the slash following the hostport) to be empty; if this
  is empty the slash may be omitted as well. However, this isn't reflected
  in the syntax.
  
  Under C<{-keep}>, the following are returned:
  
  =over 4
  
  =item $1
  
  The entire URI.
  
  =item $2
  
  The scheme.
  
  =item $3
  
  The host (name or address).
  
  =item $4
  
  The port (if any).
  
  =item $5
  
  The "gopher-path", the part after the / following the host and port.
  
  =item $6
  
  The gopher-type.
  
  =item $7
  
  The selector. (When no C<{-notab}> is used, this includes the search
  and gopherplus_string, including the separating escaped tabs).
  
  =item $8
  
  The search, if given. (Only when C<{-notab}> is given).
  
  =item $9
  
  The gopherplus_string, if given. (Only when C<{-notab}> is given).
  
  =back
  
  head1 REFERENCES
  
  =over 4
  
  =item B<[RFC 1738]>
  
  Berners-Lee, Tim, Masinter, L., McCahill, M.: I<Uniform Resource
  Locators (URL)>. December 1994.
  
  =item B<[RFC 1808]>
  
  Fielding, R.: I<Relative Uniform Resource Locators (URL)>. June 1995.
  
  =item B<[GOPHER URL]>
  
  Krishnan, Murali R., Casey, James: "A Gopher URL Format". Expired
  Internet draft I<draft-murali-url-gopher>. December 1996.
  
  =back
  
  =head1 SEE ALSO
  
  L<Regexp::Common::URI> for other supported URIs.
  
  =head1 AUTHOR
  
  Damian Conway (damian@conway.org)
  
  =head1 MAINTENANCE
  
  This package is maintained by Abigail S<(I<regexp-common@abigail.be>)>.
  
  =head1 BUGS AND IRRITATIONS
  
  Bound to be plenty.
  
  =head1 LICENSE and COPYRIGHT
  
  This software is Copyright (c) 2001 - 2017, Damian Conway and Abigail.
  
  This module is free software, and maybe used under any of the following
  licenses:
  
   1) The Perl Artistic License.     See the file COPYRIGHT.AL.
   2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2.
   3) The BSD License.               See the file COPYRIGHT.BSD.
   4) The MIT License.               See the file COPYRIGHT.MIT.
  
  =cut
REGEXP_COMMON_URI_GOPHER

$fatpacked{"Regexp/Common/URI/http.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'REGEXP_COMMON_URI_HTTP';
  package Regexp::Common::URI::http;
  
  use Regexp::Common               qw /pattern clean no_defaults/;
  use Regexp::Common::URI          qw /register_uri/;
  use Regexp::Common::URI::RFC2396 qw /$host $port $path_segments $query/;
  
  use strict;
  use warnings;
  
  use vars qw /$VERSION/;
  $VERSION = '2017060201';
  
  
  my $http_uri = "(?k:(?k:http)://(?k:$host)(?::(?k:$port))?"           .
                 "(?k:/(?k:(?k:$path_segments)(?:[?](?k:$query))?))?)";
  
  my $https_uri = $http_uri; $https_uri =~ s/http/https?/;
  
  register_uri HTTP => $https_uri;
  
  pattern name    => [qw (URI HTTP), "-scheme=http"],
          create  => sub {
              my $scheme =  $_ [1] -> {-scheme};
              my $uri    =  $http_uri;
                 $uri    =~ s/http/$scheme/;
              $uri;
          }
          ;
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Regexp::Common::URI::http -- Returns a pattern for HTTP URIs.
  
  =head1 SYNOPSIS
  
      use Regexp::Common qw /URI/;
  
      while (<>) {
          /$RE{URI}{HTTP}/       and  print "Contains an HTTP URI.\n";
      }
  
  =head1 DESCRIPTION
  
  =head2 $RE{URI}{HTTP}{-scheme}
  
  Provides a regex for an HTTP URI as defined by RFC 2396 (generic syntax)
  and RFC 2616 (HTTP).
  
  If C<< -scheme => I<P> >> is specified the pattern I<P> is used as the scheme.
  By default I<P> is C<qr/http/>. C<https> and C<https?> are reasonable
  alternatives.
  
  The syntax for an HTTP URI is:
  
      "http:" "//" host [ ":" port ] [ "/" path [ "?" query ]]
  
  Under C<{-keep}>, the following are returned:
  
  =over 4
  
  =item $1
  
  The entire URI.
  
  =item $2
  
  The scheme.
  
  =item $3
  
  The host (name or address).
  
  =item $4
  
  The port (if any).
  
  =item $5
  
  The absolute path, including the query and leading slash.
  
  =item $6
  
  The absolute path, including the query, without the leading slash.
  
  =item $7
  
  The absolute path, without the query or leading slash.
  
  =item $8
  
  The query, without the question mark.
  
  =back
  
  =head1 REFERENCES
  
  =over 4
  
  =item B<[RFC 2396]>
  
  Berners-Lee, Tim, Fielding, R., and Masinter, L.: I<Uniform Resource
  Identifiers (URI): Generic Syntax>. August 1998.
  
  =item B<[RFC 2616]>
  
  Fielding, R., Gettys, J., Mogul, J., Frystyk, H., Masinter, L., 
  Leach, P. and Berners-Lee, Tim: I<Hypertext Transfer Protocol -- HTTP/1.1>.
  June 1999.
  
  =back
  
  =head1 SEE ALSO
  
  L<Regexp::Common::URI> for other supported URIs.
  
  =head1 AUTHOR
  
  Damian Conway (damian@conway.org)
  
  =head1 MAINTENANCE
  
  This package is maintained by Abigail S<(I<regexp-common@abigail.be>)>.
  
  =head1 BUGS AND IRRITATIONS
  
  Bound to be plenty.
  
  =head1 LICENSE and COPYRIGHT
  
  This software is Copyright (c) 2001 - 2017, Damian Conway and Abigail.
  
  This module is free software, and maybe used under any of the following
  licenses:
  
   1) The Perl Artistic License.     See the file COPYRIGHT.AL.
   2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2.
   3) The BSD License.               See the file COPYRIGHT.BSD.
   4) The MIT License.               See the file COPYRIGHT.MIT.
  
  =cut
REGEXP_COMMON_URI_HTTP

$fatpacked{"Regexp/Common/URI/news.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'REGEXP_COMMON_URI_NEWS';
  package Regexp::Common::URI::news;
  
  use Regexp::Common               qw /pattern clean no_defaults/;
  use Regexp::Common::URI          qw /register_uri/;
  use Regexp::Common::URI::RFC1738 qw /$grouppart $group $article
                                       $host $port $digits/;
  
  use strict;
  use warnings;
  
  use vars qw /$VERSION/;
  $VERSION = '2017060201';
  
  
  my $news_scheme = 'news';
  my $news_uri    = "(?k:(?k:$news_scheme):(?k:$grouppart))";
  
  my $nntp_scheme = 'nntp';
  my $nntp_uri    = "(?k:(?k:$nntp_scheme)://(?k:(?k:(?k:$host)(?::(?k:$port))?)" 
                  . "/(?k:$group)(?:/(?k:$digits))?))";
  
  register_uri $news_scheme => $news_uri;
  register_uri $nntp_scheme => $nntp_uri;
  
  pattern name    => [qw (URI news)],
          create  => $news_uri,
          ;
  
  pattern name    => [qw (URI NNTP)],
          create  => $nntp_uri,
          ;
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Regexp::Common::URI::news -- Returns a pattern for file URIs.
  
  =head1 SYNOPSIS
  
      use Regexp::Common qw /URI/;
  
      while (<>) {
          /$RE{URI}{news}/       and  print "Contains a news URI.\n";
      }
  
  =head1 DESCRIPTION
  
  =head2 $RE{URI}{news}
  
  Returns a pattern that matches I<news> URIs, as defined by RFC 1738.
  News URIs have the form:
  
      "news:" ( "*" | group | article "@" host )
  
  Under C<{-keep}>, the following are returned:
  
  =over 4
  
  =item $1
  
  The complete URI.
  
  =item $2
  
  The scheme.
  
  =item $3
  
  The part of the URI following "news://".
  
  =back
  
  =head2 $RE{URI}{NNTP}
  
  Returns a pattern that matches I<NNTP> URIs, as defined by RFC 1738.
  NNTP URIs have the form:
  
      "nntp://" host [ ":" port ] "/" group [ "/" digits ]
  
  Under C<{-keep}>, the following are returned:
  
  =over 4
  
  =item $1
  
  The complete URI.
  
  =item $2
  
  The scheme.
  
  =item $3
  
  The part of the URI following "nntp://".
  
  =item $4
  
  The host and port, separated by a colon. If no port was given, just
  the host.
  
  =item $5
  
  The host.
  
  =item $6
  
  The port, if given.
  
  =item $7
  
  The group.
  
  =item $8
  
  The digits, if given.
  
  =back
  
  =head1 REFERENCES
  
  =over 4
  
  =item B<[RFC 1738]>
  
  Berners-Lee, Tim, Masinter, L., McCahill, M.: I<Uniform Resource
  Locators (URL)>. December 1994.
  
  =back
  
  =head1 SEE ALSO
  
  L<Regexp::Common::URI> for other supported URIs.
  
  =head1 AUTHOR
  
  Damian Conway (damian@conway.org)
  
  =head1 MAINTENANCE
  
  This package is maintained by Abigail S<(I<regexp-common@abigail.be>)>.
  
  =head1 BUGS AND IRRITATIONS
  
  Bound to be plenty.
  
  =head1 LICENSE and COPYRIGHT
  
  This software is Copyright (c) 2001 - 2017, Damian Conway and Abigail.
  
  This module is free software, and maybe used under any of the following
  licenses:
  
   1) The Perl Artistic License.     See the file COPYRIGHT.AL.
   2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2.
   3) The BSD License.               See the file COPYRIGHT.BSD.
   4) The MIT License.               See the file COPYRIGHT.MIT.
  
  =cut
REGEXP_COMMON_URI_NEWS

$fatpacked{"Regexp/Common/URI/pop.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'REGEXP_COMMON_URI_POP';
  package Regexp::Common::URI::pop;
  
  use Regexp::Common               qw /pattern clean no_defaults/;
  use Regexp::Common::URI          qw /register_uri/;
  use Regexp::Common::URI::RFC1738 qw /$host $port/;
  use Regexp::Common::URI::RFC2384 qw /$enc_user $enc_auth_type/;
  
  use strict;
  use warnings;
  
  use vars qw /$VERSION/;
  $VERSION = '2017060201';
  
  
  my $scheme = "pop";
  my $uri    = "(?k:(?k:$scheme)://(?:(?k:$enc_user)"     .  
               "(?:;AUTH=(?k:[*]|$enc_auth_type))?\@)?"   .
               "(?k:$host)(?::(?k:$port))?)";
  
  register_uri $scheme => $uri;
  
  pattern name    => [qw (URI POP)],
          create  => $uri,
          ;
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Regexp::Common::URI::pop -- Returns a pattern for POP URIs.
  
  =head1 SYNOPSIS
  
      use Regexp::Common qw /URI/;
  
      while (<>) {
          /$RE{URI}{POP}/       and  print "Contains a POP URI.\n";
      }
  
  =head1 DESCRIPTION
  
  =head2 $RE{URI}{POP}
  
  Returns a pattern that matches I<POP> URIs, as defined by RFC 2384.
  POP URIs have the form:
  
      "pop:" "//" [ user [ ";AUTH" ( "*" | auth_type ) ] "@" ]
                    host [ ":" port ]
  
  Under C<{-keep}>, the following are returned:
  
  =over 4
  
  =item $1
  
  The complete URI.
  
  =item $2
  
  The I<scheme>.
  
  =item $3
  
  The I<user>, if given.
  
  =item $4
  
  The I<authentication type>, if given (could be a I<*>).
  
  =item $5
  
  The I<host>.
  
  =item $6
  
  The I<port>, if given.
  
  =back
  
  =head1 REFERENCES
  
  =over 4
  
  =item B<[RFC 2384]>
  
  Gellens, R.: I<POP URL Scheme>. August 1998.
  
  =back
  
  =head1 SEE ALSO
  
  L<Regexp::Common::URI> for other supported URIs.
  
  =head1 AUTHOR
  
  Abigail. (I<regexp-common@abigail.be>).
  
  =head1 BUGS AND IRRITATIONS
  
  Bound to be plenty.
  
  =head1 LICENSE and COPYRIGHT
  
  This software is Copyright (c) 2001 - 2017, Damian Conway and Abigail.
  
  This module is free software, and maybe used under any of the following
  licenses:
  
   1) The Perl Artistic License.     See the file COPYRIGHT.AL.
   2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2.
   3) The BSD License.               See the file COPYRIGHT.BSD.
   4) The MIT License.               See the file COPYRIGHT.MIT.
  
  =cut
REGEXP_COMMON_URI_POP

$fatpacked{"Regexp/Common/URI/prospero.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'REGEXP_COMMON_URI_PROSPERO';
  package Regexp::Common::URI::prospero;
  
  use Regexp::Common               qw /pattern clean no_defaults/;
  use Regexp::Common::URI          qw /register_uri/;
  use Regexp::Common::URI::RFC1738 qw /$host $port $ppath $fieldname $fieldvalue
                                       $fieldspec/;
  
  use strict;
  use warnings;
  
  use vars qw /$VERSION/;
  $VERSION = '2017060201';
  
  
  my $scheme = 'prospero';
  my $uri    = "(?k:(?k:$scheme)://(?k:$host)(?::(?k:$port))?" .
               "/(?k:$ppath)(?k:$fieldspec*))";
  
  register_uri $scheme => $uri;
  
  pattern name    => [qw (URI prospero)],
          create  => $uri,
          ;
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Regexp::Common::URI::prospero -- Returns a pattern for prospero URIs.
  
  =head1 SYNOPSIS
  
      use Regexp::Common qw /URI/;
  
      while (<>) {
          /$RE{URI}{prospero}/ and print "Contains a prospero URI.\n";
      }
  
  =head1 DESCRIPTION
  
  =head2 $RE{URI}{prospero}
  
  Returns a pattern that matches I<prospero> URIs, as defined by RFC 1738.
  prospero URIs have the form:
  
      "prospero:" "//" host [ ":" port ] "/" path [ fieldspec ] *
  
  Under C<{-keep}>, the following are returned:
  
  =over 4
  
  =item $1
  
  The complete URI.
  
  =item $2
  
  The I<scheme>.
  
  =item $3
  
  The I<hostname>.
  
  =item $4
  
  The I<port>, if given.
  
  =item $5
  
  The propero path.
  
  =item $6
  
  The field specifications, if given. There can be more field specifications;
  they will all be returned in C<$6>.
  
  =back
  
  =head1 REFERENCES
  
  =over 4
  
  =item B<[RFC 1738]>
  
  Berners-Lee, Tim, Masinter, L., McCahill, M.: I<Uniform Resource
  Locators (URL)>. December 1994.
  
  =back
  
  =head1 SEE ALSO
  
  L<Regexp::Common::URI> for other supported URIs.
  
  =head1 AUTHOR
  
  Abigail. (I<regexp-common@abigail.be>).
  
  =head1 BUGS AND IRRITATIONS
  
  Bound to be plenty.
  
  =head1 LICENSE and COPYRIGHT
  
  This software is Copyright (c) 2001 - 2017, Damian Conway and Abigail.
  
  This module is free software, and maybe used under any of the following
  licenses:
  
   1) The Perl Artistic License.     See the file COPYRIGHT.AL.
   2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2.
   3) The BSD License.               See the file COPYRIGHT.BSD.
   4) The MIT License.               See the file COPYRIGHT.MIT.
  
  =cut
REGEXP_COMMON_URI_PROSPERO

$fatpacked{"Regexp/Common/URI/tel.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'REGEXP_COMMON_URI_TEL';
  package Regexp::Common::URI::tel;
  
  use Regexp::Common               qw /pattern clean no_defaults/;
  use Regexp::Common::URI          qw /register_uri/;
  use Regexp::Common::URI::RFC2806 qw /$telephone_subscriber 
                                       $telephone_subscriber_no_future/;
  
  use strict;
  use warnings;
  
  use vars qw /$VERSION/;
  $VERSION = '2017060201';
  
  
  my $tel_scheme  = 'tel';
  my $tel_uri     = "(?k:(?k:$tel_scheme):(?k:$telephone_subscriber))";
  my $tel_uri_nf  = "(?k:(?k:$tel_scheme):(?k:$telephone_subscriber_no_future))";
  
  register_uri $tel_scheme => $tel_uri;
  
  pattern name    => [qw (URI tel)],
          create  => $tel_uri
          ;
  
  pattern name    => [qw (URI tel nofuture)],
          create  => $tel_uri_nf
          ;
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Regexp::Common::URI::tel -- Returns a pattern for telephone URIs.
  
  =head1 SYNOPSIS
  
      use Regexp::Common qw /URI/;
  
      while (<>) {
          /$RE{URI}{tel}/       and  print "Contains a telephone URI.\n";
      }
  
  =head1 DESCRIPTION
  
  =head2 $RE{URI}{tel}
  
  Returns a pattern that matches I<tel> URIs, as defined by RFC 2806.
  Under C<{-keep}>, the following are returned:
  
  =over 4
  
  =item $1
  
  The complete URI.
  
  =item $2
  
  The scheme.
  
  =item $3
  
  The phone number, including any possible add-ons like ISDN subaddress,
  a post dial part, area specifier, service provider, etc.
  
  =back
  
  =head2 C<$RE{URI}{tel}{nofuture}>
  
  As above (including what's returned by C<{-keep}>), with the exception
  that I<future extensions> are not allowed. Without allowing 
  those I<future extensions>, it becomes much easier to check a URI if
  the correct syntax for post dial, service provider, phone context,
  etc has been used - otherwise the regex could always classify them
  as a I<future extension>.
  
  =head1 REFERENCES
  
  =over 4
  
  =item B<[RFC 1035]>
  
  Mockapetris, P.: I<DOMAIN NAMES - IMPLEMENTATION AND SPECIFICATION>.
  November 1987.
  
  =item B<[RFC 2396]>
  
  Berners-Lee, Tim, Fielding, R., and Masinter, L.: I<Uniform Resource
  Identifiers (URI): Generic Syntax>. August 1998.
  
  =item B<[RFC 2806]>
  
  Vaha-Sipila, A.: I<URLs for Telephone Calls>. April 2000.
  
  =back
  
  =head1 SEE ALSO
  
  L<Regexp::Common::URI> for other supported URIs.
  
  =head1 AUTHOR
  
  Damian Conway (damian@conway.org)
  
  =head1 MAINTENANCE
  
  This package is maintained by Abigail S<(I<regexp-common@abigail.be>)>.
  
  =head1 BUGS AND IRRITATIONS
  
  Bound to be plenty.
  
  =head1 LICENSE and COPYRIGHT
  
  This software is Copyright (c) 2001 - 2017, Damian Conway and Abigail.
  
  This module is free software, and maybe used under any of the following
  licenses:
  
   1) The Perl Artistic License.     See the file COPYRIGHT.AL.
   2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2.
   3) The BSD License.               See the file COPYRIGHT.BSD.
   4) The MIT License.               See the file COPYRIGHT.MIT.
  
  =cut
REGEXP_COMMON_URI_TEL

$fatpacked{"Regexp/Common/URI/telnet.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'REGEXP_COMMON_URI_TELNET';
  package Regexp::Common::URI::telnet;
  
  use Regexp::Common               qw /pattern clean no_defaults/;
  use Regexp::Common::URI          qw /register_uri/;
  use Regexp::Common::URI::RFC1738 qw /$user $password $host $port/;
  
  use strict;
  use warnings;
  
  use vars qw /$VERSION/;
  $VERSION = '2017060201';
  
  
  my $telnet_uri = "(?k:(?k:telnet)://(?:(?k:(?k:$user)(?::(?k:$password))?)\@)?" 
                 . "(?k:(?k:$host)(?::(?k:$port))?)(?k:/)?)";
  
  register_uri telnet => $telnet_uri;
  
  pattern name    => [qw (URI telnet)],
          create  => $telnet_uri,
          ;
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Regexp::Common::URI::telnet -- Returns a pattern for telnet URIs.
  
  =head1 SYNOPSIS
  
      use Regexp::Common qw /URI/;
  
      while (<>) {
          /$RE{URI}{telnet}/       and  print "Contains a telnet URI.\n";
      }
  
  =head1 DESCRIPTION
  
  =head2 $RE{URI}{telnet}
  
  Returns a pattern that matches I<telnet> URIs, as defined by RFC 1738.
  Telnet URIs have the form:
  
      "telnet:" "//" [ user [ ":" password ] "@" ] host [ ":" port ] [ "/" ]
  
  Under C<{-keep}>, the following are returned:
  
  =over 4
  
  =item $1
  
  The complete URI.
  
  =item $2
  
  The scheme.
  
  =item $3
  
  The username:password combo, or just the username if there is no password.
  
  =item $4
  
  The username, if given.
  
  =item $5
  
  The password, if given.
  
  =item $6
  
  The host:port combo, or just the host if there's no port.
  
  =item $7
  
  The host.
  
  =item $8
  
  The port, if given.
  
  =item $9
  
  The trailing slash, if any.
  
  =back
  
  =head1 REFERENCES
  
  =over 4
  
  =item B<[RFC 1738]>
  
  Berners-Lee, Tim, Masinter, L., McCahill, M.: I<Uniform Resource
  Locators (URL)>. December 1994.
  
  =back
  
  =head1 SEE ALSO
  
  L<Regexp::Common::URI> for other supported URIs.
  
  =head1 AUTHOR
  
  Damian Conway (damian@conway.org)
  
  =head1 MAINTENANCE
  
  This package is maintained by Abigail S<(I<regexp-common@abigail.be>)>.
  
  =head1 BUGS AND IRRITATIONS
  
  Bound to be plenty.
  
  =head1 LICENSE and COPYRIGHT
  
  This software is Copyright (c) 2001 - 2017, Damian Conway and Abigail.
  
  This module is free software, and maybe used under any of the following
  licenses:
  
   1) The Perl Artistic License.     See the file COPYRIGHT.AL.
   2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2.
   3) The BSD License.               See the file COPYRIGHT.BSD.
   4) The MIT License.               See the file COPYRIGHT.MIT.
  
  =cut
REGEXP_COMMON_URI_TELNET

$fatpacked{"Regexp/Common/URI/tv.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'REGEXP_COMMON_URI_TV';
  # TV URLs. 
  # Internet draft: draft-zigmond-tv-url-03.txt
  
  package Regexp::Common::URI::tv;
  
  use Regexp::Common               qw /pattern clean no_defaults/;
  use Regexp::Common::URI          qw /register_uri/;
  use Regexp::Common::URI::RFC2396 qw /$hostname/;
  
  use strict;
  use warnings;
  
  use vars qw /$VERSION/;
  $VERSION = '2017060201';
  
  
  my $tv_scheme = 'tv';
  my $tv_url    = "(?k:(?k:$tv_scheme):(?k:$hostname)?)";
  
  register_uri $tv_scheme => $tv_url;
  
  pattern name    => [qw (URI tv)],
          create  => $tv_url,
          ;
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Regexp::Common::URI::tv -- Returns a pattern for tv URIs.
  
  =head1 SYNOPSIS
  
      use Regexp::Common qw /URI/;
  
      while (<>) {
          /$RE{URI}{tv}/       and  print "Contains a tv URI.\n";
      }
  
  =head1 DESCRIPTION
  
  =head2 C<$RE{URI}{tv}>
  
  Returns a pattern that recognizes TV uris as per an Internet draft
  [DRAFT-URI-TV].
  
  Under C<{-keep}>, the following are returned:
  
  =over 4
  
  =item $1
  
  The entire URI.
  
  =item $2
  
  The scheme.
  
  =item $3
  
  The host.
  
  =back
  
  =head1 REFERENCES
  
  =over 4
  
  =item B<[DRAFT-URI-TV]>
  
  Zigmond, D. and Vickers, M: I<Uniform Resource Identifiers for
  Television Broadcasts>. December 2000.
  
  =item B<[RFC 2396]>
  
  Berners-Lee, Tim, Fielding, R., and Masinter, L.: I<Uniform Resource
  Identifiers (URI): Generic Syntax>. August 1998.
  
  =back
  
  =head1 SEE ALSO
  
  L<Regexp::Common::URI> for other supported URIs.
  
  =head1 AUTHOR
  
  Damian Conway (damian@conway.org)
  
  =head1 MAINTENANCE
  
  This package is maintained by Abigail S<(I<regexp-common@abigail.be>)>.
  
  =head1 BUGS AND IRRITATIONS
  
  Bound to be plenty.
  
  =head1 LICENSE and COPYRIGHT
  
  This software is Copyright (c) 2001 - 2017, Damian Conway and Abigail.
  
  This module is free software, and maybe used under any of the following
  licenses:
  
   1) The Perl Artistic License.     See the file COPYRIGHT.AL.
   2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2.
   3) The BSD License.               See the file COPYRIGHT.BSD.
   4) The MIT License.               See the file COPYRIGHT.MIT.
  
  =cut
REGEXP_COMMON_URI_TV

$fatpacked{"Regexp/Common/URI/wais.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'REGEXP_COMMON_URI_WAIS';
  package Regexp::Common::URI::wais;
  
  use Regexp::Common               qw /pattern clean no_defaults/;
  use Regexp::Common::URI          qw /register_uri/;
  use Regexp::Common::URI::RFC1738 qw /$host $port
                                       $search $database $wtype $wpath/;
  
  use strict;
  use warnings;
  
  use vars qw /$VERSION/;
  $VERSION = '2017060201';
  
  
  my $scheme = 'wais';
  my $uri    = "(?k:(?k:$scheme)://(?k:$host)(?::(?k:$port))?/(?k:(?k:$database)" 
             . "(?k:[?](?k:$search)|/(?k:$wtype)/(?k:$wpath))?))";
  
  register_uri $scheme => $uri;
  
  pattern name    => [qw (URI WAIS)],
          create  => $uri,
          ;
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Regexp::Common::URI::wais -- Returns a pattern for WAIS URIs.
  
  =head1 SYNOPSIS
  
      use Regexp::Common qw /URI/;
  
      while (<>) {
          /$RE{URI}{WAIS}/       and  print "Contains a WAIS URI.\n";
      }
  
  =head1 DESCRIPTION
  
  =head2 $RE{URI}{WAIS}
  
  Returns a pattern that matches I<WAIS> URIs, as defined by RFC 1738.
  WAIS URIs have the form:
  
      "wais:" "//" host [ ":" port ] "/" database
                        [ ( "?" search ) | ( "/" wtype "/" wpath ) ]
  
  Under C<{-keep}>, the following are returned:
  
  =over 4
  
  =item $1
  
  The complete URI.
  
  =item $2
  
  The I<scheme>.
  
  =item $3
  
  The I<hostname>.
  
  =item $4
  
  The I<port>, if given.
  
  =item $5
  
  The I<database>, followed by I<search> or I<wtype/wpath>, if given.
  
  =item $6
  
  The I<database>.
  
  =item $7
  
  The part following the I<database> if given, including the question mark 
  or slash.
  
  =item $8
  
  The I<search> part, if given.
  
  =item $9
  
  The I<wtype>, if given.
  
  =item $10
  
  The I<wpath>, if given.
  
  =back
  
  =head1 REFERENCES
  
  =over 4
  
  =item B<[RFC 1738]>
  
  Berners-Lee, Tim, Masinter, L., McCahill, M.: I<Uniform Resource
  Locators (URL)>. December 1994.
  
  =back
  
  =head1 SEE ALSO
  
  L<Regexp::Common::URI> for other supported URIs.
  
  =head1 AUTHOR
  
  Damian Conway (damian@conway.org)
  
  =head1 MAINTENANCE
  
  This package is maintained by Abigail S<(I<regexp-common@abigail.be>)>.
  
  =head1 BUGS AND IRRITATIONS
  
  Bound to be plenty.
  
  =head1 LICENSE and COPYRIGHT
  
  This software is Copyright (c) 2001 - 2017, Damian Conway and Abigail.
  
  This module is free software, and maybe used under any of the following
  licenses:
  
   1) The Perl Artistic License.     See the file COPYRIGHT.AL.
   2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2.
   3) The BSD License.               See the file COPYRIGHT.BSD.
   4) The MIT License.               See the file COPYRIGHT.MIT.
  
  =cut
REGEXP_COMMON_URI_WAIS

$fatpacked{"Regexp/Common/_support.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'REGEXP_COMMON__SUPPORT';
  package Regexp::Common::_support;
  
  use 5.10.0;
  
  use strict;
  use warnings;
  no  warnings 'syntax';
  
  our $VERSION = '2017060201';
  
  #
  # Returns true/false, depending whether the given the argument
  # satisfies the LUHN checksum.
  # See http://www.webopedia.com/TERM/L/Luhn_formula.html.
  #
  # Note that this function is intended to be called from regular
  # expression, so it should NOT use a regular expression in any way.
  #
  sub luhn {
      my $arg  = shift;
      my $even = 0;
      my $sum  = 0;
      while (length $arg) {
          my $num = chop $arg;
          return if $num lt '0' || $num gt '9';
          if ($even && (($num *= 2) > 9)) {$num = 1 + ($num % 10)}
          $even = 1 - $even;
          $sum += $num;
      }
      !($sum % 10)
  }
  
  sub import {
      my $pack   = shift;
      my $caller = caller;
      no strict 'refs';
      *{$caller . "::" . $_} = \&{$pack . "::" . $_} for @_;
  }
  
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Regexp::Common::support -- Support functions for Regexp::Common.
  
  =head1 SYNOPSIS
  
      use Regexp::Common::_support qw /luhn/;
  
      luhn ($number)    # Returns true/false.
  
  
  =head1 DESCRIPTION
  
  This module contains some subroutines to be used by other C<Regexp::Common>
  modules. It's not intended to be used directly. Subroutines from the 
  module may disappear without any notice, or their meaning or interface
  may change without notice.
  
  =over 4
  
  =item luhn
  
  This subroutine returns true if its argument passes the luhn checksum test.
  
  =back
  
  =head1 SEE ALSO
  
  L<http://www.webopedia.com/TERM/L/Luhn_formula.html>.
  
  =head1 AUTHOR
  
  Abigail S<(I<regexp-common@abigail.be>)>.
  
  =head1 BUGS AND IRRITATIONS
  
  Bound to be plenty.
  
  =head1 LICENSE and COPYRIGHT
  
  This software is Copyright (c) 2001 - 2017, Damian Conway and Abigail.
  
  This module is free software, and maybe used under any of the following
  licenses:
  
   1) The Perl Artistic License.     See the file COPYRIGHT.AL.
   2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2.
   3) The BSD License.               See the file COPYRIGHT.BSD.
   4) The MIT License.               See the file COPYRIGHT.MIT.
  
  =cut
REGEXP_COMMON__SUPPORT

$fatpacked{"Regexp/Common/balanced.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'REGEXP_COMMON_BALANCED';
  package Regexp::Common::balanced; {
  
  use 5.10.0;
  
  use strict;
  use warnings;
  no  warnings 'syntax';
  
  use Regexp::Common qw /pattern clean no_defaults/;
  
  our $VERSION = '2017060201';
  
  my %closer = ( '{'=>'}', '('=>')', '['=>']', '<'=>'>' );
  my %cache;
  
  sub nested {
      my ($start, $finish) = @_;
  
      return $cache {$start} {$finish} if exists $cache {$start} {$finish};
  
      my @starts   = map {s/\\(.)/$1/g; $_} grep {length}
                          $start  =~ /([^|\\]+|\\.)+/gs;
      my @finishes = map {s/\\(.)/$1/g; $_} grep {length}
                          $finish =~ /([^|\\]+|\\.)+/gs;
  
      push @finishes => ($finishes [-1]) x (@starts - @finishes);
  
      my @re;
      local $" = "|";
      foreach my $begin (@starts) {
          my $end = shift @finishes;
  
          my $qb  = quotemeta $begin;
          my $qe  = quotemeta $end;
          my $fb  = quotemeta substr $begin => 0, 1;
          my $fe  = quotemeta substr $end   => 0, 1;
  
          my $tb  = quotemeta substr $begin => 1;
          my $te  = quotemeta substr $end   => 1;
  
          my $add;
          if ($fb eq $fe) {
              push @re =>
                     qq /(?:$qb(?:(?>[^$fb]+)|$fb(?!$tb)(?!$te)|(?-1))*$qe)/;
          }
          else {
              my   @clauses =  "(?>[^$fb$fe]+)";
              push @clauses => "$fb(?!$tb)" if length $tb;
              push @clauses => "$fe(?!$te)" if length $te;
              push @clauses => "(?-1)";
              push @re      =>  qq /(?:$qb(?:@clauses)*$qe)/;
          }
      }
  
      $cache {$start} {$finish} = qr /(@re)/;
  }
  
  
  pattern name    => [qw /balanced -parens=() -begin= -end=/],
          create  => sub {
              my $flag = $_[1];
              unless (defined $flag -> {-begin} && length $flag -> {-begin} &&
                      defined $flag -> {-end}   && length $flag -> {-end}) {
                  my @open  = grep {index ($flag->{-parens}, $_) >= 0}
                               ('[','(','{','<');
                  my @close = map {$closer {$_}} @open;
                  $flag -> {-begin} = join "|" => @open;
                  $flag -> {-end}   = join "|" => @close;
              }
              return nested @$flag {qw /-begin -end/};
          },
          ;
  
  }
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Regexp::Common::balanced -- provide regexes for strings with balanced
  parenthesized delimiters or arbitrary delimiters.
  
  =head1 SYNOPSIS
  
      use Regexp::Common qw /balanced/;
  
      while (<>) {
          /$RE{balanced}{-parens=>'()'}/
                                     and print q{balanced parentheses\n};
      }
  
  
  =head1 DESCRIPTION
  
  Please consult the manual of L<Regexp::Common> for a general description
  of the works of this interface.
  
  Do not use this module directly, but load it via I<Regexp::Common>.
  
  =head2 C<$RE{balanced}{-parens}>
  
  Returns a pattern that matches a string that starts with the nominated
  opening parenthesis or bracket, contains characters and properly nested
  parenthesized subsequences, and ends in the matching parenthesis.
  
  More than one type of parenthesis can be specified:
  
          $RE{balanced}{-parens=>'(){}'}
  
  in which case all specified parenthesis types must be correctly balanced within
  the string.
  
  Since version 2013030901, C<< $1 >> will always be set (to the entire
  matched substring), regardless whether C<< {-keep} >> is used or not.
  
  =head2 C<< $RE{balanced}{-begin => "begin"}{-end => "end"} >>
  
  Returns a pattern that matches a string that is properly balanced
  using the I<begin> and I<end> strings as start and end delimiters.
  Multiple sets of begin and end strings can be given by separating
  them by C<|>s (which can be escaped with a backslash).
  
      qr/$RE{balanced}{-begin => "do|if|case"}{-end => "done|fi|esac"}/
  
  will match properly balanced strings that either start with I<do> and
  end with I<done>, start with I<if> and end with I<fi>, or start with
  I<case> and end with I<esac>.
  
  If I<-end> contains less cases than I<-begin>, the last case of I<-end>
  is repeated. If it contains more cases than I<-begin>, the extra cases
  are ignored. If either of I<-begin> or I<-end> isn't given, or is empty,
  I<< -begin => '(' >> and I<< -end => ')' >> are assumed.
  
  Since version 2013030901, C<< $1 >> will always be set (to the entire
  matched substring), regardless whether C<< {-keep} >> is used or not.
  
  =head2 Note
  
  Since version 2013030901 the pattern will make of the recursive construct
  C<< (?-1) >>, instead of using the problematic C<< (??{ }) >> construct.
  This fixes an problem that was introduced in the 5.17 development track.
  
  =head1 SEE ALSO
  
  L<Regexp::Common> for a general description of how to use this interface.
  
  =head1 AUTHOR
  
  Damian Conway (damian@conway.org)
  
  =head1 MAINTENANCE
  
  This package is maintained by Abigail S<(I<regexp-common@abigail.be>)>.
  
  =head1 BUGS AND IRRITATIONS
  
  Bound to be plenty.
  
  For a start, there are many common regexes missing.
  Send them in to I<regexp-common@abigail.be>.
  
  =head1 LICENSE and COPYRIGHT
  
  This software is Copyright (c) 2001 - 2017, Damian Conway and Abigail.
  
  This module is free software, and maybe used under any of the following
  licenses:
  
   1) The Perl Artistic License.     See the file COPYRIGHT.AL.
   2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2.
   3) The BSD License.               See the file COPYRIGHT.BSD.
   4) The MIT License.               See the file COPYRIGHT.MIT.
  
  =cut
REGEXP_COMMON_BALANCED

$fatpacked{"Regexp/Common/comment.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'REGEXP_COMMON_COMMENT';
  package Regexp::Common::comment;
  
  use 5.10.0;
  
  use strict;
  use warnings;
  no  warnings 'syntax';
  
  use Regexp::Common qw /pattern clean no_defaults/;
  
  our $VERSION = '2017060201';
  
  my @generic = (
      {languages => [qw /ABC Forth/],
       to_eol    => ['\\\\']},   # This is for just a *single* backslash.
  
      {languages => [qw /Ada Alan Eiffel lua/],
       to_eol    => ['--']},
  
      {languages => [qw /Advisor/],
       to_eol    => ['#|//']},
  
      {languages => [qw /Advsys CQL Lisp LOGO M MUMPS REBOL Scheme
                         SMITH zonefile/],
       to_eol    => [';']},
  
      {languages => ['Algol 60'],
       from_to   => [[qw /comment ;/]]},
  
      {languages => [qw {ALPACA B C C-- LPC PL/I}],
       from_to   => [[qw {/* */}]]},
  
      {languages => [qw /awk fvwm2 Icon m4 mutt Perl Python QML
                         R Ruby shell Tcl/],
       to_eol    => ['#']},
  
      {languages => [[BASIC => 'mvEnterprise']],
       to_eol    => ['[*!]|REM']},
  
      {languages => [qw /Befunge-98 Funge-98 Shelta/],
       id        => [';']},
  
      {languages => ['beta-Juliet', 'Crystal Report', 'Portia', 'Ubercode'],
       to_eol    => ['//']},
  
      {languages => ['BML'],
       from_to   => [['<?_c', '_c?>']],
      },
  
      {languages => [qw /C++/, 'C#', qw /Cg ECMAScript FPL Java JavaScript/],
       to_eol    => ['//'],
       from_to   => [[qw {/* */}]]},
  
      {languages => [qw /CLU LaTeX slrn TeX/],
       to_eol    => ['%']},
  
      {languages => [qw /False/],
       from_to   => [[qw !{ }!]]},
  
      {languages => [qw /Fortran/],
       to_eol    => ['!']},
  
      {languages => [qw /Haifu/],
       id        => [',']},
  
      {languages => [qw /ILLGOL/],
       to_eol    => ['NB']},
  
      {languages => [qw /INTERCAL/],
       to_eol    => [q{(?:(?:PLEASE(?:\s+DO)?|DO)\s+)?(?:NOT|N'T)}]},
  
      {languages => [qw /J/],
       to_eol    => ['NB[.]']},
  
      {languages => [qw /JavaDoc/],
       from_to   => [[qw {/** */}]]},
  
      {languages => [qw /Nickle/],
       to_eol    => ['#'],
       from_to   => [[qw {/* */}]]},
  
      {languages => [qw /Oberon/],
       from_to   => [[qw /(* *)/]]},
       
      {languages => [[qw /Pascal Delphi/], [qw /Pascal Free/], [qw /Pascal GPC/]],
       to_eol    => ['//'],
       from_to   => [[qw !{ }!], [qw !(* *)!]]},
  
      {languages => [[qw /Pascal Workshop/]],
       id        => [qw /"/],
       from_to   => [[qw !{ }!], [qw !(* *)!], [qw !/* */!]]},
  
      {languages => [qw /PEARL/],
       to_eol    => ['!'],
       from_to   => [[qw {/* */}]]},
  
      {languages => [qw /PHP/],
       to_eol    => ['#', '//'],
       from_to   => [[qw {/* */}]]},
  
      {languages => [qw !PL/B!],
       to_eol    => ['[.;]']},
  
      {languages => [qw !PL/SQL!],
       to_eol    => ['--'],
       from_to   => [[qw {/* */}]]},
  
      {languages => [qw /Q-BAL/],
       to_eol    => ['`']},
  
      {languages => [qw /Smalltalk/],
       id        => ['"']},
  
      {languages => [qw /SQL/],
       to_eol    => ['-{2,}']},
  
      {languages => [qw /troff/],
       to_eol    => ['\\\"']},
  
      {languages => [qw /vi/],
       to_eol    => ['"']},
  
      {languages => [qw /*W/],
       from_to   => [[qw {|| !!}]]},
  
      {languages => [qw /ZZT-OOP/],
       to_eol    => ["'"]},
  );
  
  my @plain_or_nested = (
     [Caml         =>  undef,       "(*"  => "*)"],
     [Dylan        =>  "//",        "/*"  => "*/"],
     [Haskell      =>  "-{2,}",     "{-"  => "-}"],
     [Hugo         =>  "!(?!\\\\)", "!\\" => "\\!"],
     [SLIDE        =>  "#",         "(*"  => "*)"],
    ['Modula-2'    =>  undef,       "(*"  => "*)"],
    ['Modula-3'    =>  undef,       "(*"  => "*)"],
  );
  
  #
  # Helper subs.
  #
  
  sub combine      {
      local $_ = join "|", @_;
      if (@_ > 1) {
          s/\(\?k:/(?:/g;
          $_ = "(?k:$_)";
      }
      $_
  }
  
  sub to_eol  ($)  {"(?k:(?k:$_[0])(?k:[^\\n]*)(?k:\\n))"}
  sub id      ($)  {"(?k:(?k:$_[0])(?k:[^$_[0]]*)(?k:$_[0]))"}  # One char only!
  sub from_to      {
      my ($begin, $end) = @_;
  
      my $qb  = quotemeta $begin;
      my $qe  = quotemeta $end;
      my $fe  = quotemeta substr $end   => 0, 1;
      my $te  = quotemeta substr $end   => 1;
  
      "(?k:(?k:$qb)(?k:(?:[^$fe]+|$fe(?!$te))*)(?k:$qe))";
  }
  
  
  my $count = 0;
  sub nested {
      my ($begin, $end) = @_;
  
      $count ++;
      my $r = '(??{$Regexp::Common::comment ['. $count . ']})';
  
      my $qb  = quotemeta $begin;
      my $qe  = quotemeta $end;
      my $fb  = quotemeta substr $begin => 0, 1;
      my $fe  = quotemeta substr $end   => 0, 1;
  
      my $tb  = quotemeta substr $begin => 1;
      my $te  = quotemeta substr $end   => 1;
  
      use re 'eval';
  
      my $re;
      if ($fb eq $fe) {
          $re = qr /(?:$qb(?:(?>[^$fb]+)|$fb(?!$tb)(?!$te)|$r)*$qe)/;
      }
      else {
          local $"      =  "|";
          my   @clauses =  "(?>[^$fb$fe]+)";
          push @clauses => "$fb(?!$tb)" if length $tb;
          push @clauses => "$fe(?!$te)" if length $te;
          push @clauses =>  $r;
          $re           =   qr /(?:$qb(?:@clauses)*$qe)/;
      }
  
      $Regexp::Common::comment [$count] = qr/$re/;
  }
  
  #
  # Process data.
  #
  
  foreach my $info (@plain_or_nested) {
      my ($language, $mark, $begin, $end) = @$info;
      pattern name    => [comment => $language],
              create  =>
                  sub {my $re     = nested $begin => $end;
                       my $prefix = defined $mark ? $mark . "[^\n]*\n|" : "";
                       exists $_ [1] -> {-keep} ? qr /($prefix$re)/
                                                : qr  /$prefix$re/
                  },
              ;
  }
  
  
  foreach my $group (@generic) {
      my $pattern = combine +(map {to_eol   $_} @{$group -> {to_eol}}),
                             (map {from_to @$_} @{$group -> {from_to}}),
                             (map {id       $_} @{$group -> {id}}),
                    ;
      foreach my $language  (@{$group -> {languages}}) {
          pattern name    => [comment => ref $language ? @$language : $language],
                  create  => $pattern,
                  ;
      }
  }
                  
  
      
  #
  # Other languages.
  #
  
  # http://www.pascal-central.com/docs/iso10206.txt
  pattern name    => [qw /comment Pascal/],
          create  => '(?k:' . '(?k:[{]|[(][*])'
                            . '(?k:[^}*]*(?:[*](?![)])[^}*]*)*)'
                            . '(?k:[}]|[*][)])'
                            . ')'
          ;
  
  # http://www.templetons.com/brad/alice/language/
  pattern name    =>  [qw /comment Pascal Alice/],
          create  =>  '(?k:(?k:[{])(?k:[^}\n]*)(?k:[}]))'
          ;
  
  
  # http://westein.arb-phys.uni-dortmund.de/~wb/a68s.txt
  pattern name    => [qw (comment), 'Algol 68'],
          create  => q {(?k:(?:#[^#]*#)|}                           .
                     q {(?:\bco\b(?:[^c]+|\Bc|\bc(?!o\b))*\bco\b)|} .
                     q {(?:\bcomment\b(?:[^c]+|\Bc|\bc(?!omment\b))*\bcomment\b))}
          ;
  
  
  # See rules 91 and 92 of ISO 8879 (SGML).
  # Charles F. Goldfarb: "The SGML Handbook".
  # Oxford: Oxford University Press. 1990. ISBN 0-19-853737-9.
  # Ch. 10.3, pp 390.
  pattern name    => [qw (comment HTML)],
          create  => q {(?k:(?k:<!)(?k:(?:--(?k:[^-]*(?:-[^-]+)*)--\s*)*)(?k:>))},
          ;
  
  
  pattern name    => [qw /comment SQL MySQL/],
          create  => q {(?k:(?:#|-- )[^\n]*\n|} .
                     q {/\*(?:(?>[^*;"']+)|"[^"]*"|'[^']*'|\*(?!/))*(?:;|\*/))},
          ;
  
  # Anything that isn't <>[]+-.,
  # http://home.wxs.nl/~faase009/Ha_BF.html
  pattern name    => [qw /comment Brainfuck/],
          create  => '(?k:[^<>\[\]+\-.,]+)'
          ;
  
  # Squeak is a variant of Smalltalk-80.
  # http://www.squeak.
  # http://mucow.com/squeak-qref.html
  pattern name    => [qw /comment Squeak/],
          create  => '(?k:(?k:")(?k:[^"]*(?:""[^"]*)*)(?k:"))'
          ;
  
  #
  # Scores of less than 5 or above 17....
  # http://www.cliff.biffle.org/esoterica/beatnik.html
  @Regexp::Common::comment::scores = (1,  3,  3,  2,  1,  4,  2,  4,  1,  8,
                                      5,  1,  3,  1,  1,  3, 10,  1,  1,  1,
                                      1,  4,  4,  8,  4, 10);
  {
  my ($s, $x);
  pattern name    =>  [qw /comment Beatnik/],
          create  =>  sub {
              use re 'eval';
              my $re = qr {\b([A-Za-z]+)\b
                           (?(?{($s, $x) = (0, lc $^N);
                                $s += $Regexp::Common::comment::scores
                                      [ord (chop $x) - ord ('a')] while length $x;
                                $s  >= 5 && $s < 18})XXX|)}x;
              $re;
          },
          ;
  }
  
  
  # http://www.cray.com/craydoc/manuals/007-3692-005/html-007-3692-005/
  #  (Goto table of contents/3.3 Source Form)
  # Fortran, in fixed format. Comments start with a C, c or * in the first
  # column, or a ! anywhere, but the sixth column. Then end with a newline.
  pattern name    =>  [qw /comment Fortran fixed/],
          create  =>  '(?k:(?k:(?:^[Cc*]|(?<!^.....)!))(?k:[^\n]*)(?k:\n))'
          ;
  
  
  # http://www.csis.ul.ie/cobol/Course/COBOLIntro.htm
  # Traditionally, comments in COBOL were indicated with an asteriks in
  # the seventh column. Modern compilers may be more lenient.
  pattern name    =>  [qw /comment COBOL/],
          create  =>  '(?<=^......)(?k:(?k:[*])(?k:[^\n]*)(?k:\n))',
          ;
  
  1;
  
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Regexp::Common::comment -- provide regexes for comments.
  
  =head1 SYNOPSIS
  
      use Regexp::Common qw /comment/;
  
      while (<>) {
          /$RE{comment}{C}/       and  print "Contains a C comment\n";
          /$RE{comment}{C++}/     and  print "Contains a C++ comment\n";
          /$RE{comment}{PHP}/     and  print "Contains a PHP comment\n";
          /$RE{comment}{Java}/    and  print "Contains a Java comment\n";
          /$RE{comment}{Perl}/    and  print "Contains a Perl comment\n";
          /$RE{comment}{awk}/     and  print "Contains an awk comment\n";
          /$RE{comment}{HTML}/    and  print "Contains an HTML comment\n";
      }
  
      use Regexp::Common qw /comment RE_comment_HTML/;
  
      while (<>) {
          $_ =~ RE_comment_HTML() and  print "Contains an HTML comment\n";
      }
  
  =head1 DESCRIPTION
  
  Please consult the manual of L<Regexp::Common> for a general description
  of the works of this interface.
  
  Do not use this module directly, but load it via I<Regexp::Common>.
  
  This modules gives you regular expressions for comments in various
  languages.
  
  =head2 THE LANGUAGES
  
  Below, the comments of each of the languages are described.
  The patterns are available as C<$RE{comment}{I<LANG>}>, foreach
  language I<LANG>. Some languages have variants; it's described
  at the individual languages how to get the patterns for the variants.
  Unless mentioned otherwise,
  C<{-keep}> sets C<$1>, C<$2>, C<$3> and C<$4> to the entire comment,
  the opening marker, the content of the comment, and the closing marker
  (for many languages, the latter is a newline) respectively.
  
  =over 4
  
  =item ABC
  
  Comments in I<ABC> start with a backslash (C<\>), and last till
  the end of the line.
  See L<http://homepages.cwi.nl/%7Esteven/abc/>.
  
  =item Ada
  
  Comments in I<Ada> start with C<-->, and last till the end of the line.
  
  =item Advisor
  
  I<Advisor> is a language used by the HP product I<glance>. Comments for
  this language start with either C<#> or C<//>, and last till the
  end of the line.
  
  =item Advsys
  
  Comments for the I<Advsys> language start with C<;> and last till
  the end of the line. See also L<http://www.wurb.com/if/devsys/12>.
  
  =item Alan
  
  I<Alan> comments start with C<-->, and last till the end of the line.
  See also L<http://w1.132.telia.com/~u13207378/alan/manual/alanTOC.html>.
  
  =item Algol 60
  
  Comments in the I<Algol 60> language start with the keyword C<comment>,
  and end with a C<;>. See L<http://www.masswerk.at/algol60/report.htm>.
  
  =item Algol 68
  
  In I<Algol 68>, comments are either delimited by C<#>, or by one of the
  keywords C<co> or C<comment>. The keywords should not be part of another
  word. See L<http://westein.arb-phys.uni-dortmund.de/~wb/a68s.txt>.
  With C<{-keep}>, only C<$1> will be set, returning the entire comment.
  
  =item ALPACA
  
  The I<ALPACA> language has comments starting with C</*> and ending with C<*/>.
  
  =item awk
  
  The I<awk> programming language uses comments that start with C<#>
  and end at the end of the line.
  
  =item B
  
  The I<B> language has comments starting with C</*> and ending with C<*/>.
  
  =item BASIC
  
  There are various forms of BASIC around. Currently, we only support the
  variant supported by I<mvEnterprise>, whose pattern is available as
  C<$RE{comment}{BASIC}{mvEnterprise}>. Comments in this language start with a
  C<!>, a C<*> or the keyword C<REM>, and end till the end of the line. See
  L<http://www.rainingdata.com/products/beta/docs/mve/50/ReferenceManual/Basic.pdf>.
  
  =item Beatnik
  
  The esotoric language I<Beatnik> only uses words consisting of letters.
  Words are scored according to the rules of Scrabble. Words scoring less
  than 5 points, or 18 points or more are considered comments (although
  the compiler might mock at you if you score less than 5 points).
  Regardless whether C<{-keep}>, C<$1> will be set, and set to the
  entire comment. This pattern requires I<perl 5.8.0> or newer.
  
  =item beta-Juliet
  
  The I<beta-Juliet> programming language has comments that start with
  C<//> and that continue till the end of the line. See also
  L<http://www.catseye.mb.ca/esoteric/b-juliet/index.html>.
  
  =item Befunge-98
  
  The esotoric language I<Befunge-98> uses comments that start and end
  with a C<;>. See L<http://www.catseye.mb.ca/esoteric/befunge/98/spec98.html>.
  
  =item BML                 
  
  I<BML>, or I<Better Markup Language> is an HTML templating language that
  uses comments starting with C<< <?c_ >>, and ending with C<< c_?> >>.
  See L<http://www.livejournal.com/doc/server/bml.index.html>.               
  
  =item Brainfuck
  
  The minimal language I<Brainfuck> uses only eight characters, 
  C<E<lt>>, C<E<gt>>, C<[>, C<]>, C<+>, C<->, C<.> and C<,>.
  Any other characters are considered comments. With C<{-keep}>,
  C<$1> is set to the entire comment.
  
  =item C
  
  The I<C> language has comments starting with C</*> and ending with C<*/>.
  
  =item C--
  
  The I<C--> language has comments starting with C</*> and ending with C<*/>.
  See L<http://cs.uas.arizona.edu/classes/453/programs/C--Spec.html>.
  
  =item C++
  
  The I<C++> language has two forms of comments. Comments that start with
  C<//> and last till the end of the line, and comments that start with
  C</*>, and end with C<*/>. If C<{-keep}> is used, only C<$1> will be
  set, and set to the entire comment.
  
  =item C#
  
  The I<C#> language has two forms of comments. Comments that start with
  C<//> and last till the end of the line, and comments that start with
  C</*>, and end with C<*/>. If C<{-keep}> is used, only C<$1> will be
  set, and set to the entire comment.
  See L<http://msdn.microsoft.com/library/default.asp?url=/library/en-us/csspec/html/vclrfcsharpspec_C.asp>.
  
  =item Caml
  
  Comments in I<Caml> start with C<(*>, end with C<*)>, and can be nested.
  See L<http://www.cs.caltech.edu/courses/cs134/cs134b/book.pdf> and
  L<http://pauillac.inria.fr/caml/index-eng.html>.
  
  =item Cg
  
  The I<Cg> language has two forms of comments. Comments that start with
  C<//> and last till the end of the line, and comments that start with
  C</*>, and end with C<*/>. If C<{-keep}> is used, only C<$1> will be
  set, and set to the entire comment.
  See L<http://developer.nvidia.com/attach/3722>.
  
  =item CLU
  
  In C<CLU>, a comment starts with a procent sign (C<%>), and ends with the
  next newline. See L<ftp://ftp.lcs.mit.edu:/pub/pclu/CLU-syntax.ps> and
  L<http://www.pmg.lcs.mit.edu/CLU.html>.
  
  =item COBOL
  
  Traditionally, comments in I<COBOL> are indicated by an asteriks in the
  seventh column. This is what the pattern matches. Modern compiler may
  more lenient though. See L<http://www.csis.ul.ie/cobol/Course/COBOLIntro.htm>,
  and L<http://www.csis.ul.ie/cobol/default.htm>.
  
  =item CQL
  
  Comments in the chess query language (I<CQL>) start with a semi colon
  (C<;>) and last till the end of the line. See L<http://www.rbnn.com/cql/>.
  
  =item Crystal Report
  
  The formula editor in I<Crystal Reports> uses comments that start
  with C<//>, and end with the end of the line.
  
  =item Dylan
  
  There are two types of comments in I<Dylan>. They either start with
  C<//>, or are nested comments, delimited with C</*> and C<*/>.
  Under C<{-keep}>, only C<$1> will be set, returning the entire comment.
  This pattern requires I<perl 5.6.0> or newer.
  
  =item ECMAScript
  
  The I<ECMAScript> language has two forms of comments. Comments that start with
  C<//> and last till the end of the line, and comments that start with
  C</*>, and end with C<*/>. If C<{-keep}> is used, only C<$1> will be
  set, and set to the entire comment. I<JavaScript> is Netscapes implementation
  of I<ECMAScript>. See
  L<http://www.ecma-international.org/publications/files/ecma-st/Ecma-262.pdf>,
  and L<http://www.ecma-international.org/publications/standards/Ecma-262.htm>.
  
  =item Eiffel
  
  I<Eiffel> comments start with C<-->, and last till the end of the line.
  
  =item False
  
  In I<False>, comments start with C<{> and end with C<}>.
  See L<http://wouter.fov120.com/false/false.txt>
  
  =item FPL
  
  The I<FPL> language has two forms of comments. Comments that start with
  C<//> and last till the end of the line, and comments that start with
  C</*>, and end with C<*/>. If C<{-keep}> is used, only C<$1> will be
  set, and set to the entire comment.
  
  =item Forth
  
  Comments in Forth start with C<\>, and end with the end of the line.
  See also L<http://docs.sun.com/sb/doc/806-1377-10>.
  
  =item Fortran
  
  There are two forms of I<Fortran>. There's free form I<Fortran>, which
  has comments that start with C<!>, and end at the end of the line.
  The pattern for this is given by C<$RE{Fortran}>. Fixed form I<Fortran>,
  which has been obsoleted, has comments that start with C<C>, C<c> or
  C<*> in the first column, or with C<!> anywhere, but the sixth column.
  The pattern for this are given by C<$RE{Fortran}{fixed}>.
  
  See also L<http://www.cray.com/craydoc/manuals/007-3692-005/html-007-3692-005/>.
  
  =item Funge-98
  
  The esotoric language I<Funge-98> uses comments that start and end with
  a C<;>.
  
  =item fvwm2
  
  Configuration files for I<fvwm2> have comments starting with a
  C<#> and lasting the rest of the line.
  
  =item Haifu
  
  I<Haifu>, an esotoric language using haikus, has comments starting and
  ending with a C<,>.
  See L<http://www.dangermouse.net/esoteric/haifu.html>.
  
  =item Haskell
  
  There are two types of comments in I<Haskell>. They either start with
  at least two dashes, or are nested comments, delimited with C<{-> and C<-}>.
  Under C<{-keep}>, only C<$1> will be set, returning the entire comment.
  This pattern requires I<perl 5.6.0> or newer.
  
  =item HTML
  
  In I<HTML>, comments only appear inside a I<comment declaration>.
  A comment declaration starts with a C<E<lt>!>, and ends with a
  C<E<gt>>. Inside this declaration, we have zero or more comments.
  Comments starts with C<--> and end with C<-->, and are optionally
  followed by whitespace. The pattern C<$RE{comment}{HTML}> recognizes
  those comment declarations (and hence more than a comment).
  Note that this is not the same as something that starts with
  C<E<lt>!--> and ends with C<--E<gt>>, because the following will
  be matched completely:
  
      <!--  First  Comment   --
        --> Second Comment <!--
        --  Third  Comment   -->
  
  Do not be fooled by what your favourite browser thinks is an HTML
  comment.
  
  If C<{-keep}> is used, the following are returned:
  
  =over 4
  
  =item $1
  
  captures the entire comment declaration.
  
  =item $2
  
  captures the MDO (markup declaration open), C<E<lt>!>.
  
  =item $3
  
  captures the content between the MDO and the MDC.
  
  =item $4
  
  captures the (last) comment, without the surrounding dashes.
  
  =item $5
  
  captures the MDC (markup declaration close), C<E<gt>>.
  
  =back
  
  =item Hugo
  
  There are two types of comments in I<Hugo>. They either start with
  C<!> (which cannot be followed by a C<\>), or are nested comments,
  delimited with C<!\> and C<\!>.
  Under C<{-keep}>, only C<$1> will be set, returning the entire comment.
  This pattern requires I<perl 5.6.0> or newer.
  
  =item Icon
  
  I<Icon> has comments that start with C<#> and end at the next new line.
  See L<http://www.toolsofcomputing.com/IconHandbook/IconHandbook.pdf>,
  L<http://www.cs.arizona.edu/icon/index.htm>, and
  L<http://burks.bton.ac.uk/burks/language/icon/index.htm>.
  
  =item ILLGOL
  
  The esotoric language I<ILLGOL> uses comments starting with I<NB> and lasting
  till the end of the line.
  See L<http://www.catseye.mb.ca/esoteric/illgol/index.html>.
  
  =item INTERCAL
  
  Comments in INTERCAL are single line comments. They start with one of
  the keywords C<NOT> or C<N'T>, and can optionally be preceded by the
  keywords C<DO> and C<PLEASE>. If both keywords are used, C<PLEASE>
  precedes C<DO>. Keywords are separated by whitespace.
  
  =item J
  
  The language I<J> uses comments that start with C<NB.>, and that last till
  the end of the line. See
  L<http://www.jsoftware.com/books/help/primer/contents.htm>, and
  L<http://www.jsoftware.com/>.
  
  =item Java
  
  The I<Java> language has two forms of comments. Comments that start with
  C<//> and last till the end of the line, and comments that start with
  C</*>, and end with C<*/>. If C<{-keep}> is used, only C<$1> will be
  set, and set to the entire comment.
  
  =item JavaDoc
  
  The I<Javadoc> documentation syntax is demarked with a subset of
  ordinary Java comments to separate it from code.  Comments start with
  C</**> end with C<*/>.  If C<{-keep}> is used, only C<$1> will be set,
  and set to the entire comment. See
  L<http://www.oracle.com/technetwork/java/javase/documentation/index-137868.html#format>.
  
  =item JavaScript
  
  The I<JavaScript> language has two forms of comments. Comments that start with
  C<//> and last till the end of the line, and comments that start with
  C</*>, and end with C<*/>. If C<{-keep}> is used, only C<$1> will be
  set, and set to the entire comment. I<JavaScript> is Netscapes implementation
  of I<ECMAScript>.
  See L<http://www.mozilla.org/js/language/E262-3.pdf>,
  and L<http://www.mozilla.org/js/language/>.
  
  =item LaTeX
  
  The documentation language I<LaTeX> uses comments starting with C<%>
  and ending at the end of the line.
  
  =item Lisp
  
  Comments in I<Lisp> start with a semi-colon (C<;>) and last till the
  end of the line.
  
  =item LPC
  
  The I<LPC> language has comments starting with C</*> and ending with C<*/>.
  
  =item LOGO
  
  Comments for the language I<LOGO> start with C<;>, and last till the end
  of the line.
  
  =item lua
  
  Comments for the I<lua> language start with C<-->, and last till the end
  of the line. See also L<http://www.lua.org/manual/manual.html>.
  
  =item M, MUMPS
  
  In C<M> (aka C<MUMPS>), comments start with a semi-colon, and last
  till the end of a line. The language specification requires the 
  semi-colon to be preceded by one or more I<linestart character>s.
  Those characters default to a space, but that's configurable. This
  requirement, of preceding the comment with linestart characters is
  B<not> tested for. See
  L<ftp://ftp.intersys.com/pub/openm/ism/ism64docs.zip>,
  L<http://mtechnology.intersys.com/mproducts/openm/index.html>, and
  L<http://mcenter.com/mtrc/index.html>.
  
  =item m4
  
  By default, the preprocessor language I<m4> uses single line comments,
  that start with a C<#> and continue to the end of the line, including
  the newline. The pattern C<$RE {comment} {m4}> matches such comments.
  In I<m4>, it is possible to change the starting token though.
  See L<http://wolfram.schneider.org/bsd/7thEdManVol2/m4/m4.pdf>,
  L<http://www.cs.stir.ac.uk/~kjt/research/pdf/expl-m4.pdf>, and
  L<http://www.gnu.org/software/m4/manual/>.
  
  =item Modula-2
  
  In C<Modula-2>, comments start with C<(*>, and end with C<*)>. Comments
  may be nested. See L<http://www.modula2.org/>.
  
  =item Modula-3
  
  In C<Modula-3>, comments start with C<(*>, and end with C<*)>. Comments
  may be nested. See L<http://www.m3.org/>.
  
  =item mutt
  
  Configuration files for I<mutt> have comments starting with a
  C<#> and lasting the rest of the line.
  
  =item Nickle
  
  The I<Nickle> language has one line comments starting with C<#>
  (like Perl), or multiline comments delimited by C</*> and C<*/>
  (like C). Under C<-keep>, only C<$1> will be set. See also
  L<http://www.nickle.org>.
  
  =item Oberon
  
  Comments in I<Oberon> start with C<(*> and end with C<*)>.
  See L<http://www.oberon.ethz.ch/oreport.html>.
  
  =item Pascal
  
  There are many implementations of Pascal. This modules provides
  pattern for comments of several implementations.
  
  =over 4
  
  =item C<$RE{comment}{Pascal}>
  
  This is the pattern that recognizes comments according to the Pascal ISO 
  standard. This standard says that comments start with either C<{>, or
  C<(*>, and end with C<}> or C<*)>. This means that C<{*)> and C<(*}>
  are considered to be comments. Many Pascal applications don't allow this.
  See L<http://www.pascal-central.com/docs/iso10206.txt>
  
  =item C<$RE{comment}{Pascal}{Alice}>
  
  The I<Alice Pascal> compiler accepts comments that start with C<{>
  and end with C<}>. Comments are not allowed to contain newlines.
  See L<http://www.templetons.com/brad/alice/language/>.
  
  =item C<$RE{comment}{Pascal}{Delphi}>, C<$RE{comment}{Pascal}{Free}>
  and C<$RE{comment}{Pascal}{GPC}>
  
  The I<Delphi Pascal>, I<Free Pascal> and the I<Gnu Pascal Compiler>
  implementations of Pascal all have comments that either start with
  C<//> and last till the end of the line, are delimited with C<{>
  and C<}> or are delimited with C<(*> and C<*)>. Patterns for those
  comments are given by C<$RE{comment}{Pascal}{Delphi}>, 
  C<$RE{comment}{Pascal}{Free}> and C<$RE{comment}{Pascal}{GPC}>
  respectively. These patterns only set C<$1> when C<{-keep}> is used,
  which will then include the entire comment.
  
  See L<http://info.borland.com/techpubs/delphi5/oplg/>, 
  L<http://www.freepascal.org/docs-html/ref/ref.html> and
  L<http://www.gnu-pascal.de/gpc/>.
  
  =item C<$RE{comment}{Pascal}{Workshop}>
  
  The I<Workshop Pascal> compiler, from SUN Microsystems, allows comments
  that are delimited with either C<{> and C<}>, delimited with
  C<(*)> and C<*>), delimited with C</*>, and C<*/>, or starting
  and ending with a double quote (C<">). When C<{-keep}> is used,
  only C<$1> is set, and returns the entire comment.
  
  See L<http://docs.sun.com/db/doc/802-5762>.
  
  =back
  
  =item PEARL
  
  Comments in I<PEARL> start with a C<!> and last till the end of the
  line, or start with C</*> and end with C<*/>. With C<{-keep}>, 
  C<$1> will be set to the entire comment.
  
  =item PHP
  
  Comments in I<PHP> start with either C<#> or C<//> and last till the
  end of the line, or are delimited by C</*> and C<*/>. With C<{-keep}>,
  C<$1> will be set to the entire comment.
  
  =item PL/B
  
  In I<PL/B>, comments start with either C<.> or C<;>, and end with the 
  next newline. See L<http://www.mmcctech.com/pl-b/plb-0010.htm>.
  
  =item PL/I
  
  The I<PL/I> language has comments starting with C</*> and ending with C<*/>.
  
  =item PL/SQL
  
  In I<PL/SQL>, comments either start with C<--> and run till the end
  of the line, or start with C</*> and end with C<*/>.
  
  =item Perl
  
  I<Perl> uses comments that start with a C<#>, and continue till the end
  of the line.
  
  =item Portia
  
  The I<Portia> programming language has comments that start with C<//>,
  and last till the end of the line.
  
  =item Python
  
  I<Python> uses comments that start with a C<#>, and continue till the end
  of the line.
  
  =item Q-BAL
  
  Comments in the I<Q-BAL> language start with C<`> (a backtick), and
  contine till the end of the line.
  
  =item QML
  
  In C<QML>, comments start with C<#> and last till the end of the line.
  See L<http://www.questionmark.com/uk/qml/overview.doc>.
  
  =item R
  
  The statistical language I<R> uses comments that start with a C<#> and
  end with the following new line. See L<http://www.r-project.org/>.
  
  =item REBOL
  
  Comments for the I<REBOL> language start with C<;> and last till the
  end of the line.
  
  =item Ruby
  
  Comments in I<Ruby> start with C<#> and last till the end of the time.
  
  =item Scheme
  
  I<Scheme> comments start with C<;>, and last till the end of the line.
  See L<http://schemers.org/>.
  
  =item shell
  
  Comments in various I<shell>s start with a C<#> and end at the end of
  the line.
  
  =item Shelta
  
  The esotoric language I<Shelta> uses comments that start and end with
  a C<;>. See L<http://www.catseye.mb.ca/esoteric/shelta/index.html>.
  
  =item SLIDE
  
  The I<SLIDE> language has two froms of comments. First there is the
  line comment, which starts with a C<#> and includes the rest of the
  line (just like Perl). Second, there is the multiline, nested comment,
  which are delimited by C<(*> and C<*)>. Under C{-keep}>, only 
  C<$1> is set, and is set to the entire comment. See
  L<http://www.cs.berkeley.edu/~ug/slide/docs/slide/spec/spec_frame_intro.shtml>.
  
  =item slrn
  
  Configuration files for I<slrn> have comments starting with a
  C<%> and lasting the rest of the line.
  
  =item Smalltalk
  
  I<Smalltalk> uses comments that start and end with a double quote, C<">.
  
  =item SMITH
  
  Comments in the I<SMITH> language start with C<;>, and last till the
  end of the line.
  
  =item Squeak
  
  In the Smalltalk variant I<Squeak>, comments start and end with
  C<">. Double quotes can appear inside comments by doubling them.
  
  =item SQL
  
  Standard I<SQL> uses comments starting with two or more dashes, and
  ending at the end of the line. 
  
  I<MySQL> does not follow the standard. Instead, it allows comments
  that start with a C<#> or C<-- > (that's two dashes and a space)
  ending with the following newline, and comments starting with 
  C</*>, and ending with the next C<;> or C<*/> that isn't inside
  single or double quotes. A pattern for this is returned by
  C<$RE{comment}{SQL}{MySQL}>. With C<{-keep}>, only C<$1> will
  be set, and it returns the entire comment.
  
  =item Tcl
  
  In I<Tcl>, comments start with C<#> and continue till the end of the line.
  
  =item TeX
  
  The documentation language I<TeX> uses comments starting with C<%>
  and ending at the end of the line.
  
  =item troff
  
  The document formatting language I<troff> uses comments starting
  with C<\">, and continuing till the end of the line.
  
  =item Ubercode
  
  The Windows programming language I<Ubercode> uses comments that start with
  C<//> and continue to the end of the line. See L<http://www.ubercode.com>.
  
  =item vi
  
  In configuration files for the editor I<vi>, one can use comments
  starting with C<">, and ending at the end of the line.
  
  =item *W
  
  In the language I<*W>, comments start with C<||>, and end with C<!!>.
  
  =item zonefile
  
  Comments in DNS I<zonefile>s start with C<;>, and continue till the
  end of the line.
  
  =item ZZT-OOP
  
  The in-game language I<ZZT-OOP> uses comments that start with a C<'> 
  character, and end at the following newline. See
  L<http://dave2.rocketjump.org/rad/zzthelp/lang.html>.
  
  =back
  
  =head1 REFERENCES
  
  =over 4
  
  =item B<[Go 90]>
  
  Charles F. Goldfarb: I<The SGML Handbook>. Oxford: Oxford University
  Press. B<1990>. ISBN 0-19-853737-9. Ch. 10.3, pp 390-391.
  
  =back
  
  =head1 SEE ALSO
  
  L<Regexp::Common> for a general description of how to use this interface.
  
  =head1 AUTHOR
  
  Damian Conway (damian@conway.org)
  
  =head1 MAINTENANCE
  
  This package is maintained by Abigail S<(I<regexp-common@abigail.be>)>.
  
  =head1 BUGS AND IRRITATIONS
  
  Bound to be plenty.
  
  For a start, there are many common regexes missing.
  Send them in to I<regexp-common@abigail.be>.
  
  =head1 LICENSE and COPYRIGHT
  
  This software is Copyright (c) 2001 - 2017, Damian Conway and Abigail.
  
  This module is free software, and maybe used under any of the following
  licenses:
  
   1) The Perl Artistic License.     See the file COPYRIGHT.AL.
   2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2.
   3) The BSD License.               See the file COPYRIGHT.BSD.
   4) The MIT License.               See the file COPYRIGHT.MIT.
  
  =cut
REGEXP_COMMON_COMMENT

$fatpacked{"Regexp/Common/delimited.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'REGEXP_COMMON_DELIMITED';
  package Regexp::Common::delimited;
  
  use 5.10.0;
  
  use strict;
  use warnings;
  no  warnings 'syntax';
  
  use Regexp::Common qw /pattern clean no_defaults/;
  
  use charnames ':full';
  
  our $VERSION = '2017060201';
  
  sub gen_delimited {
  
      my ($dels, $escs, $cdels) = @_;
      # return '(?:\S*)' unless $dels =~ /\S/;
      if (defined $escs && length $escs) {
          $escs  .= substr  ($escs, -1) x (length ($dels) - length  ($escs));
      }
      if (defined $cdels && length $cdels) {
          $cdels .= substr ($cdels, -1) x (length ($dels) - length ($cdels));
      }
      else {
          $cdels = $dels;
      }
  
      my @pat = ();
      for (my $i = 0; $i < length $dels; $i ++) {
          my $del  = quotemeta substr  ($dels, $i, 1);
          my $cdel = quotemeta substr ($cdels, $i, 1);
          my $esc  = defined $escs && length ($escs)
                             ? quotemeta substr ($escs, $i, 1) : "";
          if ($cdel eq $esc) {
              push @pat =>
                  "(?k:$del)(?k:[^$cdel]*(?:(?:$cdel$cdel)[^$cdel]*)*)(?k:$cdel)";
          }
          elsif (length $esc) {
              push @pat =>
                  "(?k:$del)(?k:[^$esc$cdel]*(?:$esc.[^$esc$cdel]*)*)(?k:$cdel)";
          }
          else {
              push @pat => "(?k:$del)(?k:[^$cdel]*)(?k:$cdel)";
          }
      }
      my $pat = join '|', @pat;
      return "(?k:(?|$pat))";
  }
  
  sub _croak {
      require Carp;
      goto &Carp::croak;
  }
  
  pattern name    => [qw( delimited -delim= -esc=\\ -cdelim= )],
          create  => sub {my $flags = $_[1];
                          _croak 'Must specify delimiter in $RE{delimited}'
                                unless length $flags->{-delim};
                          return gen_delimited (@{$flags}{-delim, -esc, -cdelim});
                     },
          ;
  
  pattern name    => [qw( quoted -esc=\\ )],
          create  => sub {my $flags = $_[1];
                          return gen_delimited (q{"'`}, $flags -> {-esc});
                     },
          ;
  
  
  my @bracket_pairs;
  if ($] >= 5.014) {
      #
      # List from http://xahlee.info/comp/unicode_matching_brackets.html
      #
      @bracket_pairs =
          map {ref $_ ? $_ :
                  /!/ ? [(do {my $x = $_; $x =~ s/!/TOP/;    $x},
                          do {my $x = $_; $x =~ s/!/BOTTOM/; $x})]
                      : [(do {my $x = $_; $x =~ s/\?/LEFT/;  $x},
                          do {my $x = $_; $x =~ s/\?/RIGHT/; $x})]}
              "? PARENTHESIS",
              "? SQUARE BRACKET",
              "? CURLY BRACKET",
              "? DOUBLE QUOTATION MARK",
              "? SINGLE QUOTATION MARK",
              "SINGLE ?-POINTING ANGLE QUOTATION MARK",
              "?-POINTING DOUBLE ANGLE QUOTATION MARK",
              "FULLWIDTH ? PARENTHESIS",
              "FULLWIDTH ? SQUARE BRACKET",
              "FULLWIDTH ? CURLY BRACKET",
              "FULLWIDTH ? WHITE PARENTHESIS",
              "? WHITE PARENTHESIS",
              "? WHITE SQUARE BRACKET",
              "? WHITE CURLY BRACKET",
              "? CORNER BRACKET",
              "? ANGLE BRACKET",
              "? DOUBLE ANGLE BRACKET",
              "? BLACK LENTICULAR BRACKET",
              "? TORTOISE SHELL BRACKET",
              "? BLACK TORTOISE SHELL BRACKET",
              "? WHITE CORNER BRACKET",
              "? WHITE LENTICULAR BRACKET",
              "? WHITE TORTOISE SHELL BRACKET",
              "HALFWIDTH ? CORNER BRACKET",
              "MATHEMATICAL ? WHITE SQUARE BRACKET",
              "MATHEMATICAL ? ANGLE BRACKET",
              "MATHEMATICAL ? DOUBLE ANGLE BRACKET",
              "MATHEMATICAL ? FLATTENED PARENTHESIS",
              "MATHEMATICAL ? WHITE TORTOISE SHELL BRACKET",
              "? CEILING",
              "? FLOOR",
              "Z NOTATION ? IMAGE BRACKET",
              "Z NOTATION ? BINDING BRACKET",
              [   "HEAVY SINGLE TURNED COMMA QUOTATION MARK ORNAMENT",
                  "HEAVY SINGLE " .   "COMMA QUOTATION MARK ORNAMENT", ],
              [   "HEAVY DOUBLE TURNED COMMA QUOTATION MARK ORNAMENT",
                  "HEAVY DOUBLE " .   "COMMA QUOTATION MARK ORNAMENT", ],
              "MEDIUM ? PARENTHESIS ORNAMENT",
              "MEDIUM FLATTENED ? PARENTHESIS ORNAMENT",
              "MEDIUM ? CURLY BRACKET ORNAMENT",
              "MEDIUM ?-POINTING ANGLE BRACKET ORNAMENT",
              "HEAVY ?-POINTING ANGLE QUOTATION MARK ORNAMENT",
              "HEAVY ?-POINTING ANGLE BRACKET ORNAMENT",
              "LIGHT ? TORTOISE SHELL BRACKET ORNAMENT",
              "ORNATE ? PARENTHESIS",
              "! PARENTHESIS",
              "! SQUARE BRACKET",
              "! CURLY BRACKET",
              "! TORTOISE SHELL BRACKET",
              "PRESENTATION FORM FOR VERTICAL ? CORNER BRACKET",
              "PRESENTATION FORM FOR VERTICAL ? WHITE CORNER BRACKET",
              "PRESENTATION FORM FOR VERTICAL ? TORTOISE SHELL BRACKET",
              "PRESENTATION FORM FOR VERTICAL ? BLACK LENTICULAR BRACKET",
              "PRESENTATION FORM FOR VERTICAL ? WHITE LENTICULAR BRACKET",
              "PRESENTATION FORM FOR VERTICAL ? ANGLE BRACKET",
              "PRESENTATION FORM FOR VERTICAL ? DOUBLE ANGLE BRACKET",
              "PRESENTATION FORM FOR VERTICAL ? SQUARE BRACKET",
              "PRESENTATION FORM FOR VERTICAL ? CURLY BRACKET",
              "?-POINTING ANGLE BRACKET",
              "? ANGLE BRACKET WITH DOT",
              "?-POINTING CURVED ANGLE BRACKET",
              "SMALL ? PARENTHESIS",
              "SMALL ? CURLY BRACKET",
              "SMALL ? TORTOISE SHELL BRACKET",
              "SUPERSCRIPT ? PARENTHESIS",
              "SUBSCRIPT ? PARENTHESIS",
              "? SQUARE BRACKET WITH UNDERBAR",
              [    "LEFT SQUARE BRACKET WITH TICK IN TOP CORNER",
                  "RIGHT SQUARE BRACKET WITH TICK IN BOTTOM CORNER", ],
              [    "LEFT SQUARE BRACKET WITH TICK IN BOTTOM CORNER",
                  "RIGHT SQUARE BRACKET WITH TICK IN TOP CORNER", ],
              "? SQUARE BRACKET WITH QUILL",
              "TOP ? HALF BRACKET",
              "BOTTOM ? HALF BRACKET",
              "? S-SHAPED BAG DELIMITER",
              [    "LEFT ARC LESS-THAN BRACKET",
                  "RIGHT ARC GREATER-THAN BRACKET",  ],
              [    "DOUBLE LEFT ARC GREATER-THAN BRACKET",
                  "DOUBLE RIGHT ARC LESS-THAN BRACKET",  ],
              "? SIDEWAYS U BRACKET",
              "? DOUBLE PARENTHESIS",
              "? WIGGLY FENCE",
              "? DOUBLE WIGGLY FENCE",
              "? LOW PARAPHRASE BRACKET",
              "? RAISED OMISSION BRACKET",
              "? SUBSTITUTION BRACKET",
              "? DOTTED SUBSTITUTION BRACKET",
              "? TRANSPOSITION BRACKET",
              [   "OGHAM FEATHER MARK",
                  "OGHAM REVERSED FEATHER MARK",  ],
              [   "TIBETAN MARK GUG RTAGS GYON",
                  "TIBETAN MARK GUG RTAGS GYAS",  ],
              [   "TIBETAN MARK ANG KHANG GYON",
                  "TIBETAN MARK ANG KHANG GYAS",  ],
      ;
  
      #
      # Filter out unknown characters; this may run on an older version
      # of Perl with an old version of Unicode.
      #
      @bracket_pairs = grep {defined charnames::string_vianame ($$_ [0]) &&
                             defined charnames::string_vianame ($$_ [1])}
                       @bracket_pairs;
  
      if (@bracket_pairs) {
          my  $delims = join "" => map {charnames::string_vianame ($$_ [0])}
                                       @bracket_pairs;
          my $cdelims = join "" => map {charnames::string_vianame ($$_ [1])}
                                       @bracket_pairs;
  
          pattern name   => [qw (bquoted -esc=\\)],
                  create => sub {my $flags = $_ [1];
                                 return gen_delimited ($delims, $flags -> {-esc},
                                                      $cdelims);
                            },
                  version => 5.014,
                  ;
      }
  }
  
  
  #
  # Return the Unicode names of the pairs of matching delimiters.
  #
  sub bracket_pairs {@bracket_pairs}
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Regexp::Common::delimited -- provides a regex for delimited strings
  
  =head1 SYNOPSIS
  
      use Regexp::Common qw /delimited/;
  
      while (<>) {
          /$RE{delimited}{-delim=>'"'}/  and print 'a \" delimited string';
          /$RE{delimited}{-delim=>'/'}/  and print 'a \/ delimited string';
      }
  
  
  =head1 DESCRIPTION
  
  Please consult the manual of L<Regexp::Common> for a general description
  of the works of this interface.
  
  Do not use this module directly, but load it via I<Regexp::Common>.
  
  =head2 C<$RE{delimited}{-delim}{-cdelim}{-esc}>
  
  Returns a pattern that matches a single-character-delimited substring,
  with optional internal escaping of the delimiter.
  
  When C<-delim => I<S>> is specified, each character in the sequence I<S> is
  a possible delimiter. There is no default delimiter, so this flag must always
  be specified.
  
  By default, the closing delimiter is the same character as the opening
  delimiter. If this is not wanted, for instance, if you want to match
  a string with symmetric delimiters, you can specify the closing delimiter(s)
  with C<-cdelim => I<S>>. Each character in I<S> is matched with the
  corresponding character supplied with the C<-delim> option. If the C<-cdelim>
  option has less characters than the C<-delim> option, the last character
  is repeated as often as necessary. If the C<-cdelim> option has more 
  characters than the C<-delim> option, the extra characters are ignored.
  
  If C<-esc => I<S>> is specified, each character in the sequence I<S> is
  the delimiter for the corresponding character in the C<-delim=I<S>> list.
  The default escape is backslash.
  
  For example:
  
     $RE{delimited}{-delim=>'"'}               # match "a \" delimited string"
     $RE{delimited}{-delim=>'"'}{-esc=>'"'}    # match "a "" delimited string"
     $RE{delimited}{-delim=>'/'}               # match /a \/ delimited string/
     $RE{delimited}{-delim=>q{'"}}             # match "string" or 'string'
     $RE{delimited}{-delim=>"("}{-cdelim=>")"} # match (string)
  
  Under C<-keep> (See L<Regexp::Common>):
  
  =over 4
  
  =item $1
  
  captures the entire match
  
  =item $2
  
  captures the opening delimiter
  
  =item $3
  
  captures delimited portion of the string
  
  =item $4
  
  captures the closing delimiter
  
  =back
  
  =head2 $RE{quoted}{-esc}
  
  A synonym for C<< $RE {delimited} {-delim => q {'"`}} {...} >>.
  
  =head2 $RE {bquoted} {-esc}
  
  This is a pattern which matches delimited strings, where the delimiters
  are a set of matching brackets. Currently, this comes 85 pairs. This
  includes the 60 pairs of bidirection paired brackets, as listed
  in L<< http://www.unicode.org/Public/UNIDATA/BidiBrackets.txt >>.
  
  The other 25 pairs are the quotation marks, the double quotation
  marks, the single and double pointing quoation marks, the heavy
  single and double commas, 4 pairs of top-bottom parenthesis and
  brackets, 9 pairs of presentation form for vertical brackets,
  and the low paraphrase, raised omission, substitution, double
  substitution, and transposition brackets.
  
  In a future update, pairs may be added (or deleted).
  
  This pattern requires perl 5.14.0 or higher.
  
  For a full list of bracket pairs, inspect the output of 
  C<< Regexp::Common::delimited::bracket_pair () >>, which returns
  a list of two element arrays, each holding the Unicode names of
  matching pair of delimiters.
  
  The C<< {-esc => I<S> } >> works as in the C<< $RE {delimited} >> pattern.
  
  If C<< {-keep} >> is given, the following things will be captured:
  
  =over 4
  
  =item $1
  
  captures the entire match
  
  =item $2
  
  captures the opening delimiter
  
  =item $3
  
  captures delimited portion of the string
  
  =item $4
  
  captures the closing delimiter
  
  =back
  
  =head1 SEE ALSO
  
  L<Regexp::Common> for a general description of how to use this interface.
  
  =head1 AUTHOR
  
  Damian Conway (damian@conway.org)
  
  =head1 MAINTENANCE
  
  This package is maintained by Abigail S<(I<regexp-common@abigail.be>)>.
  
  =head1 BUGS AND IRRITATIONS
  
  Bound to be plenty.
  
  For a start, there are many common regexes missing.
  Send them in to I<regexp-common@abigail.be>.
  
  =head1 LICENSE and COPYRIGHT
  
  This software is Copyright (c) 2001 - 2017, Damian Conway and Abigail.
  
  This module is free software, and maybe used under any of the following
  licenses:
  
   1) The Perl Artistic License.     See the file COPYRIGHT.AL.
   2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2.
   3) The BSD License.               See the file COPYRIGHT.BSD.
   4) The MIT License.               See the file COPYRIGHT.MIT.
  
  =cut
REGEXP_COMMON_DELIMITED

$fatpacked{"Regexp/Common/lingua.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'REGEXP_COMMON_LINGUA';
  package Regexp::Common::lingua;
  
  use 5.10.0;
  
  use strict;
  use warnings;
  no  warnings 'syntax';
  
  use Regexp::Common qw /pattern clean no_defaults/;
  
  our $VERSION = '2017060201';
  
  
  pattern name    => [qw /lingua palindrome -chars=[A-Za-z]/],
          create  => sub {
              use re 'eval';
              my $keep = exists $_ [1] -> {-keep};
              my $ch   = $_ [1] -> {-chars};
              my $idx  = $keep ? "1:$ch" : "0:$ch";
              my $r    = "(??{\$Regexp::Common::lingua::pd{'" . $idx . "'}})";
              $Regexp::Common::lingua::pd {$idx} = 
                      $keep ? qr /($ch|($ch)($r)?\2)/ : qr  /$ch|($ch)($r)?\1/;
          #   print "[$ch]: ", $Regexp::Common::lingua::pd {$idx}, "\n";
          #   $Regexp::Common::lingua::pd {$idx};
          },
          ;
  
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Regexp::Common::lingua -- provide regexes for language related stuff.
  
  =head1 SYNOPSIS
  
      use Regexp::Common qw /lingua/;
  
      while (<>) {
          /^$RE{lingua}{palindrome}$/    and  print "is a palindrome\n";
      }
  
  
  =head1 DESCRIPTION
  
  Please consult the manual of L<Regexp::Common> for a general description
  of the works of this interface.
  
  Do not use this module directly, but load it via I<Regexp::Common>.
  
  =head2 C<$RE{lingua}{palindrome}>
  
  Returns a pattern that recognizes a palindrome, a string that is the
  same if you reverse it. By default, it only matches strings consisting
  of letters, but this can be changed using the C<{-chars}> option.
  This option takes a character class (default is C<[A-Za-z]>) as
  argument.
  
  If C<{-keep}> is used, only C<$1> will be set, and set to the entire
  match. 
  
  This pattern requires at least perl 5.6.0.
  
  =head1 SEE ALSO
  
  L<Regexp::Common> for a general description of how to use this interface.
  
  =head1 AUTHOR
  
  Damian Conway (damian@conway.org)
  
  =head1 MAINTENANCE
  
  This package is maintained by Abigail S<(I<regexp-common@abigail.be>)>.
  
  =head1 BUGS AND IRRITATIONS
  
  Many regexes are missing.
  Send them in to I<regexp-common@abigail.be>.
  
  =head1 LICENSE and COPYRIGHT
  
  This software is Copyright (c) 2001 - 2017, Damian Conway and Abigail.
  
  This module is free software, and maybe used under any of the following
  licenses:
  
   1) The Perl Artistic License.     See the file COPYRIGHT.AL.
   2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2.
   3) The BSD License.               See the file COPYRIGHT.BSD.
   4) The MIT License.               See the file COPYRIGHT.MIT.
  
  =cut
REGEXP_COMMON_LINGUA

$fatpacked{"Regexp/Common/list.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'REGEXP_COMMON_LIST';
  package Regexp::Common::list;
  
  use 5.10.0;
  
  use strict;
  use warnings;
  no  warnings 'syntax';
  
  use Regexp::Common qw /pattern clean no_defaults/;
  
  our $VERSION = '2017060201';
  
  sub gen_list_pattern {
      my ($pat, $sep, $lsep) = @_;
      $lsep = $sep unless defined $lsep;
      return "(?k:(?:(?:$pat)(?:$sep))*(?:$pat)(?k:$lsep)(?:$pat))";
  }
  
  my $defpat = '.*?\S';
  my $defsep = '\s*,\s*';
  
  pattern name   => ['list', "-pat=$defpat", "-sep=$defsep", '-lastsep'],
          create => sub {gen_list_pattern (@{$_[1]}{-pat, -sep, -lastsep})},
          ;
  
  pattern name   => ['list', 'conj', '-word=(?:and|or)'],
          create => sub {gen_list_pattern($defpat, $defsep,
                                          '\s*,?\s*'.$_[1]->{-word}.'\s*');
                    },
          ;
  
  pattern name   => ['list', 'and'],
          create => sub {gen_list_pattern ($defpat, $defsep, '\s*,?\s*and\s*')},
          ;
  
  pattern name   => ['list', 'or'],
          create => sub {gen_list_pattern ($defpat, $defsep, '\s*,?\s*or\s*')},
          ;
  
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Regexp::Common::list -- provide regexes for lists
  
  =head1 SYNOPSIS
  
      use Regexp::Common qw /list/;
  
      while (<>) {
          /$RE{list}{-pat => '\w+'}/          and print "List of words";
          /$RE{list}{-pat => $RE{num}{real}}/ and print "List of numbers";
      }
  
  
  =head1 DESCRIPTION
  
  Please consult the manual of L<Regexp::Common> for a general description
  of the works of this interface.
  
  Do not use this module directly, but load it via I<Regexp::Common>.
  
  =head2 C<$RE{list}{-pat}{-sep}{-lastsep}>
  
  Returns a pattern matching a list of (at least two) substrings.
  
  If C<-pat=I<P>> is specified, it defines the pattern for each substring
  in the list. By default, I<P> is C<qr/.*?\S/>. In Regexp::Common 0.02
  or earlier, the default pattern was C<qr/.*?/>. But that will match
  a single space, causing unintended parsing of C<a, b, and c> as a
  list of four elements instead of 3 (with C<-word> being C<(?:and)>).
  One consequence is that a list of the form "a,,b" will no longer be
  parsed. Use the pattern C<qr /.*?/> to be able to parse this, but see
  the previous remark.
  
  If C<-sep=I<P>> is specified, it defines the pattern I<P> to be used as
  a separator between each pair of substrings in the list, except the final two.
  By default I<P> is C<qr/\s*,\s*/>.
  
  If C<-lastsep=I<P>> is specified, it defines the pattern I<P> to be used as
  a separator between the final two substrings in the list.
  By default I<P> is the same as the pattern specified by the C<-sep> flag.
  
  For example:
  
        $RE{list}{-pat=>'\w+'}                # match a list of word chars
        $RE{list}{-pat=>$RE{num}{real}}       # match a list of numbers
        $RE{list}{-sep=>"\t"}                 # match a tab-separated list
        $RE{list}{-lastsep=>',\s+and\s+'}     # match a proper English list
  
  Under C<-keep>:
  
  =over 4
  
  =item $1
  
  captures the entire list
  
  =item $2
  
  captures the last separator
  
  =back
  
  =head2 C<$RE{list}{conj}{-word=I<PATTERN>}>
  
  An alias for C<< $RE{list}{-lastsep=>'\s*,?\s*I<PATTERN>\s*'} >>
  
  If C<-word> is not specified, the default pattern is C<qr/and|or/>.
  
  For example:
  
        $RE{list}{conj}{-word=>'et'}        # match Jean, Paul, et Satre
        $RE{list}{conj}{-word=>'oder'}      # match Bonn, Koln oder Hamburg
  
  =head2 C<$RE{list}{and}>
  
  An alias for C<< $RE{list}{conj}{-word=>'and'} >>
  
  =head2 C<$RE{list}{or}>
  
  An alias for C<< $RE{list}{conj}{-word=>'or'} >>
  
  =head1 SEE ALSO
  
  L<Regexp::Common> for a general description of how to use this interface.
  
  =head1 AUTHOR
  
  Damian Conway (damian@conway.org)
  
  =head1 MAINTENANCE
  
  This package is maintained by Abigail S<(I<regexp-common@abigail.be>)>.
  
  =head1 BUGS AND IRRITATIONS
  
  Bound to be plenty.
  
  For a start, there are many common regexes missing.
  Send them in to I<regexp-common@abigail.be>.
  
  =head1 LICENSE and COPYRIGHT
  
  This software is Copyright (c) 2001 - 2017, Damian Conway and Abigail.
  
  This module is free software, and maybe used under any of the following
  licenses:
  
   1) The Perl Artistic License.     See the file COPYRIGHT.AL.
   2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2.
   3) The BSD License.               See the file COPYRIGHT.BSD.
   4) The MIT License.               See the file COPYRIGHT.MIT.
  
  =cut
REGEXP_COMMON_LIST

$fatpacked{"Regexp/Common/net.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'REGEXP_COMMON_NET';
  package Regexp::Common::net;
  
  use 5.10.0;
  
  use strict;
  use warnings;
  no  warnings 'syntax';
  
  use Regexp::Common qw /pattern clean no_defaults/;
  
  our $VERSION = '2017060201';
  
  
  my %IPunit = (
      dec    => q{(?k:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})},
      oct    => q{(?k:[0-3]?[0-7]{1,2})},
      hex    => q{(?k:[0-9a-fA-F]{1,2})},
      bin    => q{(?k:[0-1]{1,8})},
      strict => q{(?k:2(?:5[0-5]?|[0-4][0-9]?|[6-9]?)|1[0-9]{0,2}|[3-9][0-9]?|0)},
  );
  my %MACunit = (
      %IPunit,
      hex => q{(?k:[0-9a-fA-F]{1,2})},
  );
  
  my %IPv6unit = (
      hex => q {(?k:[0-9a-f]{1,4})},
      HEX => q {(?k:[0-9A-F]{1,4})},
      HeX => q {(?k:[0-9a-fA-F]{1,4})},
  );
  
  sub dec {$_};
  sub bin {oct "0b$_"}
  
  my $IPdefsep   = '[.]';
  my $MACdefsep  =  ':';
  my $IPv6defsep =  ':';
  
  pattern name   => [qw (net IPv4)],
          create => "(?k:$IPunit{dec}$IPdefsep$IPunit{dec}$IPdefsep" .
                        "$IPunit{dec}$IPdefsep$IPunit{dec})",
          ;
  
  pattern name   => [qw (net MAC)],
          create => "(?k:" . join ($MACdefsep => ($MACunit{hex}) x 6) . ")",
          subs   => sub {
              $_ [1] = join ":" => map {sprintf "%02x" => hex}
                                   split /$MACdefsep/ => $_ [1]
                       if $_ [1] =~ /$_[0]/
          },
          ;
  
  foreach my $type (qw /dec oct hex bin strict/) {
      pattern name   => [qw (net IPv4), $type, "-sep=$IPdefsep"],
              create => sub {my $sep = $_ [1] -> {-sep};
                             "(?k:$IPunit{$type}$sep$IPunit{$type}$sep" .
                                 "$IPunit{$type}$sep$IPunit{$type})"
                        },
              ;
  
      pattern name   => [qw (net MAC), $type, "-sep=$MACdefsep"],
              create => sub {my $sep = $_ [1] -> {-sep};
                             "(?k:" . join ($sep => ($MACunit{$type}) x 6) . ")",
                        },
              subs   => sub {
                  return if $] < 5.006 and $type eq 'bin';
                  $_ [1] = join ":" => map {sprintf "%02x" => eval $type}
                                       $2, $3, $4, $5, $6, $7
                           if $_ [1] =~ $RE {net} {MAC} {$type}
                                            {-sep => $_ [0] -> {flags} {-sep}}
                                            {-keep};
              },
              ;
  
  }
  
  
  my %cache6;
  pattern name   => [qw (net IPv6), "-sep=$IPv6defsep", "-style=HeX"],
          create => sub {
              my $style = $_ [1] {-style};
              my $sep   = $_ [1] {-sep};
  
              return $cache6 {$style, $sep} if $cache6 {$style, $sep};
  
              my @re;
  
              die "Impossible style '$style'\n" unless exists $IPv6unit {$style};
  
              #
              # Nothing missing
              #
              push @re => join $sep => ($IPv6unit {$style}) x 8;
  
              #
              # For "double colon" representations, at least 2 units must
              # be omitted, leaving us with at most 6 units. 0 units is also
              # possible. Note we can have at most one double colon.
              #
              for (my $l = 0; $l <= 6; $l ++) {
                  #
                  # We prefer to do longest match, so larger $r gets priority
                  #
                  for (my $r = 6 - $l; $r >= 0; $r --) {
                      #
                      # $l is the number of blocks left of the double colon,
                      # $r is the number of blocks left of the double colon,
                      # $m is the number of omitted blocks
                      #
                      my $m    = 8 - $l - $r;
                      my $patl = $l ? ($IPv6unit {$style} . $sep) x $l : $sep;
                      my $patr = $r ? ($sep . $IPv6unit {$style}) x $r : $sep;
                      my $patm = "(?k:)" x $m;
                      my $pat  = $patl . $patm . $patr;
                      push @re => "(?:$pat)";
                  }
              }
              local $" = "|";
              $cache6 {$style, $sep} = qq /(?k:(?|@re))/;
          },
  ;
  
  
  my $letter      =  "[A-Za-z]";
  my $let_dig     =  "[A-Za-z0-9]";
  my $let_dig_hyp = "[-A-Za-z0-9]";
  
  # Domain names, from RFC 1035.
  pattern name   => [qw (net domain -nospace= -rfc1101=)],
          create => sub {
              my $rfc1101 = exists $_ [1] {-rfc1101} &&
                          !defined $_ [1] {-rfc1101};
  
              my $lead = $rfc1101 ? "(?!$RE{net}{IPv4}(?:[.]|\$))$let_dig"
                                  : $letter;
  
              if (exists $_ [1] {-nospace} && !defined $_ [1] {-nospace}) {
                  return "(?k:$lead(?:(?:$let_dig_hyp){0,61}$let_dig)?" .
                         "(?:\\.$lead(?:(?:$let_dig_hyp){0,61}$let_dig)?)*)"
              }
              else {
                  return "(?k: |(?:$lead(?:(?:$let_dig_hyp){0,61}$let_dig)?" .
                         "(?:\\.$lead(?:(?:$let_dig_hyp){0,61}$let_dig)?)*))"
              }
          },
          ;
  
  
  
  1;
  
  __END__
  
  =head1 NAME
  
  Regexp::Common::net -- provide regexes for IPv4, IPv6, and MAC addresses.
  
  =head1 SYNOPSIS
  
      use Regexp::Common qw /net/;
  
      while (<>) {
          /$RE{net}{IPv4}/       and print "Dotted decimal IP address";
          /$RE{net}{IPv4}{hex}/  and print "Dotted hexadecimal IP address";
          /$RE{net}{IPv4}{oct}{-sep => ':'}/ and
                                 print "Colon separated octal IP address";
          /$RE{net}{IPv4}{bin}/  and print "Dotted binary IP address";
          /$RE{net}{MAC}/        and print "MAC address";
          /$RE{net}{MAC}{oct}{-sep => " "}/ and
                                 print "Space separated octal MAC address";
      }
  
  =head1 DESCRIPTION
  
  Please consult the manual of L<Regexp::Common> for a general description
  of the works of this interface.
  
  Do not use this module directly, but load it via I<Regexp::Common>.
  
  This modules gives you regular expressions for various style IPv4, IPv6,
  and MAC (or ethernet) addresses.
  
  =head2 C<$RE{net}{IPv4}>
  
  Returns a pattern that matches a valid IP address in "dotted decimal".
  Note that while C<318.99.183.11> is not a valid IP address, it does
  match C</$RE{net}{IPv4}/>, but this is because C<318.99.183.11> contains
  a valid IP address, namely C<18.99.183.11>. To prevent the unwanted
  matching, one needs to anchor the regexp: C</^$RE{net}{IPv4}$/>.
  
  For this pattern and the next four, under C<-keep> (See L<Regexp::Common>):
  
  =over 4
  
  =item $1
  
  captures the entire match
  
  =item $2
  
  captures the first component of the address
  
  =item $3
  
  captures the second component of the address
  
  =item $4
  
  captures the third component of the address
  
  =item $5
  
  captures the final component of the address
  
  =back
  
  =head2 C<$RE{net}{IPv4}{dec}{-sep}>
  
  Returns a pattern that matches a valid IP address in "dotted decimal".
  Leading 0s are allowed, as long as each component does not exceed 3
  digits.
  
  If C<< -sep=I<P> >> is specified the pattern I<P> is used as the separator.
  By default I<P> is C<qr/[.]/>. 
  
  =head2 C<$RE{net}{IPv4}{strict}{-sep}>
  
  Returns a pattern that matches a valid IP address in "dotted decimal",
  but disallow any leading 0s.
  
  If C<< -sep=I<P> >> is specified the pattern I<P> is used as the separator.
  By default I<P> is C<qr/[.]/>. 
  
  
  =head2 C<$RE{net}{IPv4}{hex}{-sep}>
  
  Returns a pattern that matches a valid IP address in "dotted hexadecimal",
  with the letters C<A> to C<F> capitalized.
  
  If C<< -sep=I<P> >> is specified the pattern I<P> is used as the separator.
  By default I<P> is C<qr/[.]/>. C<< -sep="" >> and
  C<< -sep=" " >> are useful alternatives.
  
  =head2 C<$RE{net}{IPv4}{oct}{-sep}>
  
  Returns a pattern that matches a valid IP address in "dotted octal"
  
  If C<< -sep=I<P> >> is specified the pattern I<P> is used as the separator.
  By default I<P> is C<qr/[.]/>.
  
  =head2 C<$RE{net}{IPv4}{bin}{-sep}>
  
  Returns a pattern that matches a valid IP address in "dotted binary"
  
  If C<< -sep=I<P> >> is specified the pattern I<P> is used as the separator.
  By default I<P> is C<qr/[.]/>.
  
  =head2 C<$RE{net}{MAC}>
  
  Returns a pattern that matches a valid MAC or ethernet address as
  colon separated hexadecimals.
  
  For this pattern, and the next four, under C<-keep> (See L<Regexp::Common>):
  
  =over 4
  
  =item $1
  
  captures the entire match
  
  =item $2
  
  captures the first component of the address
  
  =item $3
  
  captures the second component of the address
  
  =item $4
  
  captures the third component of the address
  
  =item $5
  
  captures the fourth component of the address
  
  =item $6
  
  captures the fifth component of the address
  
  =item $7
  
  captures the sixth and final component of the address
  
  =back
  
  This pattern, and the next four, have a C<subs> method as well, which
  will transform a matching MAC address into so called canonical format.
  Canonical format means that every component of the address will be
  exactly two hexadecimals (with a leading zero if necessary), and the
  components will be separated by a colon.
  
  =head2 C<$RE{net}{MAC}{dec}{-sep}>
  
  Returns a pattern that matches a valid MAC address as colon separated
  decimals.
  
  If C<< -sep=I<P> >> is specified the pattern I<P> is used as the separator.
  By default I<P> is C<qr/:/>. 
  
  =head2 C<$RE{net}{MAC}{hex}{-sep}>
  
  Returns a pattern that matches a valid MAC address as colon separated
  hexadecimals, with the letters C<a> to C<f> in lower case.
  
  If C<< -sep=I<P> >> is specified the pattern I<P> is used as the separator.
  By default I<P> is C<qr/:/>.
  
  =head2 C<$RE{net}{MAC}{oct}{-sep}>
  
  Returns a pattern that matches a valid MAC address as colon separated
  octals.
  
  If C<< -sep=I<P> >> is specified the pattern I<P> is used as the separator.
  By default I<P> is C<qr/:/>.
  
  =head2 C<$RE{net}{MAC}{bin}{-sep}>
  
  Returns a pattern that matches a valid MAC address as colon separated
  binary numbers.
  
  If C<< -sep=I<P> >> is specified the pattern I<P> is used as the separator.
  By default I<P> is C<qr/:/>.
  
  =head2 C<< $RE{net}{IPv6}{-sep => ':'}{-style => 'HeX'} >>
  
  Returns a pattern matching IPv6 numbers. An IPv6 address consists of
  eight groups of four hexadecimal digits, separated by colons. In each
  group, leading zeros may be omitted. Two or more consecutive groups
  consisting of only zeros may be omitted (including any colons separating
  them), resulting into two sets of groups, separated by a double colon.
  (Each of the groups may be empty; C<< :: >> is a valid address, equal to
  C<< 0000:0000:0000:0000:0000:0000:0000:0000 >>). The hex numbers may be
  in either case.
  
  If the C<< -sep >> option is used, its argument is a pattern that matches
  the separator that separates groups. This defaults to C<< : >>. The 
  C<< -style >> option is used to denote which case the hex numbers may be.
  The default style, C<< 'HeX' >> indicates both lower case letters C<< 'a' >>
  to C<< 'f' >> and upper case letters C<< 'A' >> to C<< 'F' >> will be 
  matched. The style C<< 'HEX' >> restricts matching to upper case letters,
  and C<< 'hex' >> only matches lower case letters.
  
  If C<< {-keep} >> is used, C<< $1 >> to C<< $9 >> will be set. C<< $1 >>
  will be set to the matched address, while C<< $2 >> to C<< $9 >> will be
  set to each matched group. If a group is omitted because it contains all
  zeros, its matching variable will be the empty string.
  
  Example:
  
    "2001:db8:85a3::8a2e:370:7334" =~ /$RE{net}{IPv6}{-keep}/;
    print $2;    # '2001'
    print $4;    # '85a3'
    print $6;    # Empty string
    print $8;    # '370'
  
  Perl 5.10 (or later) is required for this pattern.
  
  =head2 C<$RE{net}{domain}>
  
  Returns a pattern to match domains (and hosts) as defined in RFC 1035.
  Under I{-keep} only the entire domain name is returned.
  
  RFC 1035 says that a single space can be a domainname too. So, the
  pattern returned by C<$RE{net}{domain}> recognizes a single space
  as well. This is not always what people want. If you want to recognize
  domainnames, but not a space, you can do one of two things, either use
  
      /(?! )$RE{net}{domain}/
  
  or use the C<{-nospace}> option (without an argument).
  
  RFC 1035 does B<not> allow host or domain names to start with a digits;
  however, this restriction is relaxed in RFC 1101; this RFC allows host
  and domain names to start with a digit, as long as the first part of
  a domain does not look like an IP address. If the C<< {-rfc1101} >> option
  is given (as in C<< $RE {net} {domain} {-rfc1101} >>), we will match using
  the relaxed rules.
  
  =head1 REFERENCES
  
  =over 4
  
  =item B<RFC 1035>
  
  Mockapetris, P.: I<DOMAIN NAMES - IMPLEMENTATION AND SPECIFICATION>.
  November 1987.
  
  =item B<RFC 1101>
  
  Mockapetris, P.: I<DNS Encoding of Network Names and Other Types>.
  April 1987.
  
  =back
  
  =head1 SEE ALSO
  
  L<Regexp::Common> for a general description of how to use this interface.
  
  =head1 AUTHOR
  
  Damian Conway I<damian@conway.org>.
  
  =head1 MAINTENANCE
  
  This package is maintained by Abigail S<(I<regexp-common@abigail.be>)>.
  
  =head1 BUGS AND IRRITATIONS
  
  Bound to be plenty.
  
  For a start, there are many common regexes missing.
  Send them in to I<regexp-common@abigail.be>.
  
  =head1 LICENSE and COPYRIGHT
  
  This software is Copyright (c) 2001 - 2017, Damian Conway and Abigail.
  
  This module is free software, and maybe used under any of the following
  licenses:
  
   1) The Perl Artistic License.     See the file COPYRIGHT.AL.
   2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2.
   3) The BSD License.               See the file COPYRIGHT.BSD.
   4) The MIT License.               See the file COPYRIGHT.MIT.
  
  =cut
REGEXP_COMMON_NET

$fatpacked{"Regexp/Common/number.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'REGEXP_COMMON_NUMBER';
  package Regexp::Common::number;
  
  use 5.10.0;
  
  use strict;
  use warnings;
  no  warnings 'syntax';
  
  use Config;
  use Regexp::Common qw /pattern clean no_defaults/;
  
  our $VERSION = '2017060201';
  
  
  sub _croak {
      require Carp;
      goto &Carp::croak;
  }
  
  my $digits = join ("", 0 .. 9, "A" .. "Z");
  
  sub int_creator {
      my $flags = $_ [1];
      my ($sep, $group, $base, $places, $sign) =
              @{$flags} {qw /-sep -group -base -places -sign/};
  
      # Deal with the bases.
      _croak "Base must be between 1 and 36" unless $base >=  1 &&
                                                    $base <= 36;
      my $chars = substr $digits, 0, $base;
  
      $sep = ',' if exists $flags -> {-sep} && !defined $flags -> {-sep};
  
      my $max = $group;
         $max = $2 if $group =~ /^\s*(\d+)\s*,\s*(\d+)\s*$/;
  
      my $quant = $places ? "{$places}" : "+";
  
      return $sep ? qq {(?k:(?k:$sign)(?k:[$chars]{1,$max}} .
                    qq {(?:$sep} . qq {[$chars]{$group})*))}
                  : qq {(?k:(?k:$sign)(?k:[$chars]$quant))}
  }
  
  sub real_creator { 
      my ($base, $places, $radix, $sep, $group, $expon, $sign) =
              @{$_[1]}{-base, -places, -radix, -sep, -group, -expon, -sign};
      _croak "Base must be between 1 and 36"
             unless $base >= 1 && $base <= 36;
      $sep = ',' if exists $_[1]->{-sep}
                 && !defined $_[1]->{-sep};
      if ($base > 14 && $expon =~ /^[Ee]$/) {$expon = 'G'}
      foreach ($radix, $sep, $expon) {$_ = "[$_]" if 1 == length}
      my $chars = substr $digits, 0, $base;
      return $sep
             ? qq {(?k:(?i)(?k:$sign)(?k:(?=$radix?[$chars])}              .
               qq {(?k:[$chars]{1,$group}(?:(?:$sep)[$chars]{$group})*)}   .
               qq {(?:(?k:$radix)(?k:[$chars]{$places}))?)}                .
               qq {(?:(?k:$expon)(?k:(?k:$sign)(?k:[$chars]+))|))}
             : qq {(?k:(?i)(?k:$sign)(?k:(?=$radix?[$chars])}              .
               qq {(?k:[$chars]*)(?:(?k:$radix)(?k:[$chars]{$places}))?)}  .
               qq {(?:(?k:$expon)(?k:(?k:$sign)(?k:[$chars]+))|))};
  }
  sub decimal_creator { 
      my ($base, $places, $radix, $sep, $group, $sign) =
              @{$_[1]}{-base, -places, -radix, -sep, -group, -sign};
      _croak "Base must be between 1 and 36"
             unless $base >= 1 && $base <= 36;
      $sep = ',' if exists $_[1]->{-sep}
                 && !defined $_[1]->{-sep};
      foreach ($radix, $sep) {$_ = "[$_]" if 1 == length}
      my $chars = substr $digits, 0, $base;
      return $sep
             ? qq {(?k:(?i)(?k:$sign)(?k:(?=$radix?[$chars])}               .
               qq {(?k:[$chars]{1,$group}(?:(?:$sep)[$chars]{$group})*)}    .
               qq {(?:(?k:$radix)(?k:[$chars]{$places}))?))}
             : qq {(?k:(?i)(?k:$sign)(?k:(?=$radix?[$chars])}               .
               qq {(?k:[$chars]*)(?:(?k:$radix)(?k:[$chars]{$places}))?))}
  }
  
  
  pattern name   => [qw (num int -sep= -base=10 -group=3 -sign=[-+]?)],
          create => \&int_creator,
          ;
  
  pattern name   => [qw (num real -base=10), '-places=0,',
                     qw (-radix=[.] -sep= -group=3 -expon=E -sign=[-+]?)],
          create => \&real_creator,
          ;
  
  pattern name   => [qw (num decimal -base=10), '-places=0,',
                     qw (-radix=[.] -sep= -group=3 -sign=[-+]?)],
          create => \&decimal_creator,
          ;
  
  sub real_synonym {
      my ($name, $base) = @_;
      pattern name   => ['num', $name, '-places=0,', '-radix=[.]',
                         '-sep=', '-group=3', '-expon=E', '-sign=[-+]?'],
              create => sub {my %flags = (%{$_[1]}, -base => $base);
                             real_creator (undef, \%flags);
                        }
              ;
  }
  
  
  real_synonym (hex => 16);
  real_synonym (dec => 10);
  real_synonym (oct =>  8);
  real_synonym (bin =>  2);
  
  
  #          2147483647  == 2^31 - 1
  # 9223372036854775807  == 2^63 - 1
  pattern name    => [qw (num square)],
          create  => sub {
              use re 'eval';
              my $sixty_four_bits = $Config {use64bitint};
              #
              # CPAN testers claim it fails on 5.8.8 and darwin 9.0.
              #
              my $num = $sixty_four_bits
                      ? '0*(?:(?:9(?:[0-1][0-9]{17}'  .
                               '|2(?:[0-1][0-9]{16}'  .
                               '|2(?:[0-2][0-9]{15}'  .
                               '|3(?:[0-2][0-9]{14}'  .
                               '|3(?:[0-6][0-9]{13}'  .
                               '|7(?:[0-1][0-9]{12}'  .
                               '|20(?:[0-2][0-9]{10}' .
                               '|3(?:[0-5][0-9]{9}'   .
                               '|6(?:[0-7][0-9]{8}'   .
                               '|8(?:[0-4][0-9]{7}'   .
                               '|5(?:[0-3][0-9]{6}'   .
                               '|4(?:[0-6][0-9]{5}'   .
                               '|7(?:[0-6][0-9]{4}'   .
                               '|7(?:[0-4][0-9]{3}'   .
                               '|5(?:[0-7][0-9]{2}'   .
                               '|80(?:[0-6])))))))))))))))))|[1-8]?[0-9]{0,18})'
                       : '0*(?:2(?:[0-0][0-9]{8}'  .
                             '|1(?:[0-3][0-9]{7}'  .
                             '|4(?:[0-6][0-9]{6}'  .
                             '|7(?:[0-3][0-9]{5}'  .
                             '|4(?:[0-7][0-9]{4}'  .
                             '|8(?:[0-2][0-9]{3}'  .
                             '|3(?:[0-5][0-9]{2}'  .
                             '|6(?:[0-3][0-9]{1}'  .
                             '|4[0-7])))))))))|1?[0-9]{1,9}';
              qr {($num)(?(?{length $^N && sqrt ($^N) == int sqrt ($^N)})|(?!))}
          },
          ;
  
  pattern name    => [qw (num roman)],
          create  => '(?xi)(?=[MDCLXVI])
                           (?k:M{0,4}
                              (?:C[DM]|D?C{0,4})?
                              (?:X[LC]|L?X{0,4})?
                              (?:I[VX]|V?I{0,4})?)'
          ;
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Regexp::Common::number -- provide regexes for numbers
  
  =head1 SYNOPSIS
  
      use Regexp::Common qw /number/;
  
      while (<>) {
          /^$RE{num}{int}$/                and  print "Integer\n";
          /^$RE{num}{real}$/               and  print "Real\n";
          /^$RE{num}{real}{-base => 16}$/  and  print "Hexadecimal real\n";
      }
  
  
  =head1 DESCRIPTION
  
  Please consult the manual of L<Regexp::Common> for a general description
  of the works of this interface.
  
  Do not use this module directly, but load it via I<Regexp::Common>.
  
  =head2 C<$RE{num}{int}{-base}{-sep}{-group}{-places}{-sign}>
  
  Returns a pattern that matches an integer.
  
  If C<< -base => I<B> >> is specified, the integer is in base I<B>, with
  C<< 2 <= I<B> <= 36 >>. For bases larger than 10, upper case letters
  are used. The default base is 10.
  
  If C<< -sep => I<P> >> is specified, the pattern I<P> is required as a
  grouping marker within the number. If this option is not given, no
  grouping marker is used.
  
  If C<< -group => I<N> >> is specified, digits between grouping markers
  must be grouped in sequences of exactly I<N> digits. The default value
  of I<N> is 3.  If C<< -group => I<N,M> >> is specified, digits between
  grouping markers must be grouped in sequences of at least I<N> digits,
  and at most I<M> digits. This option is ignored unless the C<< -sep >>
  option is used.
  
  If C<< -places => I<N> >> is specified, the integer recognized must be
  exactly I<N> digits wide. If C<< -places => I<N,M> >> is specified, the
  integer must be at least I<N> wide, and at most I<M> characters. There
  is no default, which means that integers are unlimited in size. This
  option is ignored if the C<< -sep >> option is used.
  
  If C<< -sign => I<P> >> is used, it's a pattern the leading sign has to
  match. This defaults to C<< [-+]? >>, which means the number is optionally
  preceded by a minus or a plus. If you want to match unsigned integers,
  use C<< $RE{num}{int}{-sign => ''} >>.
  
  For example:
  
   $RE{num}{int}                          # match 1234567
   $RE{num}{int}{-sep=>','}               # match 1,234,567
   $RE{num}{int}{-sep=>',?'}              # match 1234567 or 1,234,567
   $RE{num}{int}{-sep=>'.'}{-group=>4}    # match 1.2345.6789
  
  Under C<-keep> (see L<Regexp::Common>):
  
  =over 4
  
  =item $1
  
  captures the entire number
  
  =item $2
  
  captures the optional sign of the number
  
  =item $3
  
  captures the complete set of digits
  
  =back
  
  =head2 C<$RE{num}{real}{-base}{-radix}{-places}{-sep}{-group}{-expon}>
  
  Returns a pattern that matches a floating-point number.
  
  If C<-base=I<N>> is specified, the number is assumed to be in that base
  (with A..Z representing the digits for 11..36). By default, the base is 10.
  
  If C<-radix=I<P>> is specified, the pattern I<P> is used as the radix point for
  the number (i.e. the "decimal point" in base 10). The default is C<qr/[.]/>.
  
  If C<-places=I<N>> is specified, the number is assumed to have exactly
  I<N> places after the radix point.
  If C<-places=I<M,N>> is specified, the number is assumed to have between
  I<M> and I<N> places after the radix point.
  By default, the number of places is unrestricted.
  
  If C<-sep=I<P>> specified, the pattern I<P> is required as a grouping marker
  within the pre-radix section of the number. By default, no separator is
  allowed.
  
  If C<-group=I<N>> is specified, digits between grouping separators
  must be grouped in sequences of exactly I<N> characters. The default value of
  I<N> is 3.
  
  If C<-expon=I<P>> is specified, the pattern I<P> is used as the exponential
  marker.  The default value of I<P> is C<qr/[Ee]/>.
  
  If C<-sign=I<P>> is specified, the pattern I<P> is used to match the 
  leading sign (and the sign of the exponent). This defaults to C<< [-+]? >>,
  means means that an optional plus or minus sign can be used.
  
  For example:
  
   $RE{num}{real}                  # matches 123.456 or -0.1234567
   $RE{num}{real}{-places=>2}      # matches 123.45 or -0.12
   $RE{num}{real}{-places=>'0,3'}  # matches 123.456 or 0 or 9.8
   $RE{num}{real}{-sep=>'[,.]?'}   # matches 123,456 or 123.456
   $RE{num}{real}{-base=>3'}       # matches 121.102
  
  Under C<-keep>:
  
  =over 4
  
  =item $1
  
  captures the entire match
  
  =item $2
  
  captures the optional sign of the number
  
  =item $3
  
  captures the complete mantissa
  
  =item $4
  
  captures the whole number portion of the mantissa
  
  =item $5
  
  captures the radix point
  
  =item $6
  
  captures the fractional portion of the mantissa
  
  =item $7
  
  captures the optional exponent marker
  
  =item $8
  
  captures the entire exponent value
  
  =item $9
  
  captures the optional sign of the exponent
  
  =item $10
  
  captures the digits of the exponent
  
  =back
  
  =head2 C<$RE{num}{dec}{-radix}{-places}{-sep}{-group}{-expon}>
  
  A synonym for C<< $RE{num}{real}{-base=>10}{...} >>
  
  =head2 C<$RE{num}{oct}{-radix}{-places}{-sep}{-group}{-expon}>
  
  A synonym for C<< $RE{num}{real}{-base=>8}{...} >>
  
  =head2 C<$RE{num}{bin}{-radix}{-places}{-sep}{-group}{-expon}>
  
  A synonym for C<< $RE{num}{real}{-base=>2}{...} >>
  
  =head2 C<$RE{num}{hex}{-radix}{-places}{-sep}{-group}{-expon}>
  
  A synonym for C<< $RE{num}{real}{-base=>16}{...} >>
  
  =head2 C<$RE{num}{decimal}{-base}{-radix}{-places}{-sep}{-group}>
  
  The same as C<$RE{num}{real}>, except that an exponent isn't allowed.
  Hence, this returns a pattern matching I<decimal> numbers.
  
  If C<-base=I<N>> is specified, the number is assumed to be in that base
  (with A..Z representing the digits for 11..36). By default, the base is 10.
  
  If C<-radix=I<P>> is specified, the pattern I<P> is used as the radix point for
  the number (i.e. the "decimal point" in base 10). The default is C<qr/[.]/>.
  
  If C<-places=I<N>> is specified, the number is assumed to have exactly
  I<N> places after the radix point.
  If C<-places=I<M,N>> is specified, the number is assumed to have between
  I<M> and I<N> places after the radix point.
  By default, the number of places is unrestricted.
  
  If C<-sep=I<P>> specified, the pattern I<P> is required as a grouping marker
  within the pre-radix section of the number. By default, no separator is
  allowed.
  
  If C<-group=I<N>> is specified, digits between grouping separators
  must be grouped in sequences of exactly I<N> characters. The default value of
  I<N> is 3.
  
  For example:
  
   $RE{num}{decimal}                  # matches 123.456 or -0.1234567
   $RE{num}{decimal}{-places=>2}      # matches 123.45 or -0.12
   $RE{num}{decimal}{-places=>'0,3'}  # matches 123.456 or 0 or 9.8
   $RE{num}{decimal}{-sep=>'[,.]?'}   # matches 123,456 or 123.456
   $RE{num}{decimal}{-base=>3'}       # matches 121.102
  
  Under C<-keep>:
  
  =over 4
  
  =item $1
  
  captures the entire match
  
  =item $2
  
  captures the optional sign of the number
  
  =item $3
  
  captures the complete mantissa
  
  =item $4
  
  captures the whole number portion of the mantissa
  
  =item $5
  
  captures the radix point
  
  =item $6
  
  captures the fractional portion of the mantissa
  
  =back
  
  =head2 C<$RE{num}{square}>
  
  Returns a pattern that matches a (decimal) square. Because Perl's
  arithmetic is lossy when using integers over about 53 bits, this pattern
  only recognizes numbers less than 9000000000000000, if one uses a
  Perl that is configured to use 64 bit integers. Otherwise, the limit
  is 2147483647. These restrictions were introduced in versions 2.116
  and 2.117 of Regexp::Common. Regardless whether C<-keep> was set,
  the matched number will be returned in C<$1>.
  
  =head2 C<$RE{num}{roman}>
  
  Returns a pattern that matches an integer written in Roman numbers.
  Case doesn't matter. There is no unique way of writing Roman numerals,
  but we will not match anything. We require the Roman numerals to 
  list the symbols in order (largest first). The symbols for thousand
  (C<< M >>), hundred (C<< C >>), ten (C<< X >>), and one (C<< I >>)
  can not be repeated more than four times. The symbols for five hundred
  (C<< D >>), fifty (C<< L >>), and five (C<< V >>) may not appear more
  than once. A sequence of four repeated characters may also be written
  as a subtraction: by using the repeated character just once, and have
  it followed by the symbol which is 5 or 10 as large. So, four can be
  written as C<< IIII >>, or as C<< IV >>, and nine may be written as
  C<< VIIII >> or C<< IX >>. This corresponds to most modern uses of 
  Roman numerals.
  
  The largest number which will be matched is 4999, or 
  C<< MMMMDCCCCLXXXXVIIII >>, or C<< MMMMCMXCIX >>.
  
  Under C<-keep>, the number will be captured in $1.
  
  =head1 SEE ALSO
  
  L<Regexp::Common> for a general description of how to use this interface.
  
  =head1 AUTHOR
  
  Damian Conway (damian@conway.org)
  
  =head1 MAINTENANCE
  
  This package is maintained by Abigail S<(I<regexp-common@abigail.be>)>.
  
  =head1 BUGS AND IRRITATIONS
  
  Bound to be plenty.
  
  For a start, there are many common regexes missing.
  Send them in to I<regexp-common@abigail.be>.
  
  =head1 LICENSE and COPYRIGHT
  
  This software is Copyright (c) 2001 - 2017, Damian Conway and Abigail.
  
  This module is free software, and maybe used under any of the following
  licenses:
  
   1) The Perl Artistic License.     See the file COPYRIGHT.AL.
   2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2.
   3) The BSD License.               See the file COPYRIGHT.BSD.
   4) The MIT License.               See the file COPYRIGHT.MIT.
  
  =cut
REGEXP_COMMON_NUMBER

$fatpacked{"Regexp/Common/profanity.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'REGEXP_COMMON_PROFANITY';
  package Regexp::Common::profanity;
  
  use 5.10.0;
  
  use strict;
  use warnings;
  no  warnings 'syntax';
  
  use Regexp::Common qw /pattern clean no_defaults/;
  
  our $VERSION = '2017060201';
  
  my $profanity = '(?:cvff(?:\\ gnxr|\\-gnxr|gnxr|r(?:ef|[feq])|vat|l)?|dhvzf?|fuvg(?:g(?:r(?:ef|[qe])|vat|l)|r(?:ef|[fqel])|vat|[fr])?|g(?:heqf?|jngf?)|jnax(?:r(?:ef|[eq])|vat|f)?|n(?:ef(?:r(?:\\ ubyr|\\-ubyr|ubyr|[fq])|vat|r)|ff(?:\\ ubyrf?|\\-ubyrf?|rq|ubyrf?|vat))|o(?:hyy(?:\\ fuvg(?:g(?:r(?:ef|[qe])|vat)|f)?|\\-fuvg(?:g(?:r(?:ef|[qe])|vat)|f)?|fuvg(?:g(?:r(?:ef|[qe])|vat)|f)?)|ybj(?:\\ wbof?|\\-wbof?|wbof?))|p(?:bpx(?:\\ fhpx(?:ref?|vat)|\\-fhpx(?:ref?|vat)|fhpx(?:ref?|vat))|enc(?:c(?:r(?:ef|[eq])|vat|l)|f)?|h(?:agf?|z(?:vat|zvat|f)))|qvpx(?:\\ urnq|\\-urnq|rq|urnq|vat|yrff|f)|s(?:hpx(?:rq|vat|f)?|neg(?:r[eq]|vat|[fl])?|rygpu(?:r(?:ef|[efq])|vat)?)|un(?:eq[\\-\\ ]?ba|ys(?:\\ n[fe]|\\-n[fe]|n[fe])frq)|z(?:bgure(?:\\ shpx(?:ref?|vat)|\\-shpx(?:ref?|vat)|shpx(?:ref?|vat))|hgu(?:n(?:\\ shpx(?:ref?|vat|[nnn])|\\-shpx(?:ref?|vat|[nnn])|shpx(?:ref?|vat|[nnn]))|re(?:\\ shpx(?:ref?|vat)|\\-shpx(?:ref?|vat)|shpx(?:ref?|vat)))|reqr?))';
  
  my $contextual = '(?:c(?:bex|e(?:bax|vpxf?)|hff(?:vrf|l)|vff(?:\\ gnxr|\\-gnxr|gnxr|r(?:ef|[feq])|vat|l)?)|dhvzf?|ebbg(?:r(?:ef|[eq])|vat|f)?|f(?:bq(?:q(?:rq|vat)|f)?|chax|perj(?:rq|vat|f)?|u(?:nt(?:t(?:r(?:ef|[qe])|vat)|f)?|vg(?:g(?:r(?:ef|[qe])|vat|l)|r(?:ef|[fqel])|vat|[fr])?))|g(?:heqf?|jngf?|vgf?)|jnax(?:r(?:ef|[eq])|vat|f)?|n(?:ef(?:r(?:\\ ubyr|\\-ubyr|ubyr|[fq])|vat|r)|ff(?:\\ ubyrf?|\\-ubyrf?|rq|ubyrf?|vat))|o(?:ba(?:r(?:ef|[fe])|vat|r)|h(?:ttre|yy(?:\\ fuvg(?:g(?:r(?:ef|[qe])|vat)|f)?|\\-fuvg(?:g(?:r(?:ef|[qe])|vat)|f)?|fuvg(?:g(?:r(?:ef|[qe])|vat)|f)?))|n(?:fgneq|yy(?:r(?:ef|[qe])|vat|f)?)|yb(?:bql|j(?:\\ wbof?|\\-wbof?|wbof?)))|p(?:bpx(?:\\ fhpx(?:ref?|vat)|\\-fhpx(?:ref?|vat)|fhpx(?:ref?|vat)|f)?|enc(?:c(?:r(?:ef|[eq])|vat|l)|f)?|h(?:agf?|z(?:vat|zvat|f)))|q(?:batf?|vpx(?:\\ urnq|\\-urnq|rq|urnq|vat|yrff|f)?)|s(?:hpx(?:rq|vat|f)?|neg(?:r[eq]|vat|[fl])?|rygpu(?:r(?:ef|[efq])|vat)?)|u(?:hzc(?:r(?:ef|[eq])|vat|f)?|n(?:eq[\\-\\ ]?ba|ys(?:\\ n[fe]|\\-n[fe]|n[fe])frq))|z(?:bgure(?:\\ shpx(?:ref?|vat)|\\-shpx(?:ref?|vat)|shpx(?:ref?|vat))|hgu(?:n(?:\\ shpx(?:ref?|vat|[nnn])|\\-shpx(?:ref?|vat|[nnn])|shpx(?:ref?|vat|[nnn]))|re(?:\\ shpx(?:ref?|vat)|\\-shpx(?:ref?|vat)|shpx(?:ref?|vat)))|reqr?))';
  
  tr/A-Za-z/N-ZA-Mn-za-m/ foreach $profanity, $contextual;
  
  pattern name   => [qw (profanity)],
          create => '(?:\b(?k:' . $profanity . ')\b)',
          ;
  
  pattern name   => [qw (profanity contextual)],
          create => '(?:\b(?k:' . $contextual . ')\b)',
          ;
  
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Regexp::Common::profanity -- provide regexes for profanity
  
  =head1 SYNOPSIS
  
      use Regexp::Common qw /profanity/;
  
      while (<>) {
          /$RE{profanity}/               and  print "Contains profanity\n";
      }
  
  
  =head1 DESCRIPTION
  
  Please consult the manual of L<Regexp::Common> for a general description
  of the works of this interface.
  
  Do not use this module directly, but load it via I<Regexp::Common>.
  
  =head2 $RE{profanity}
  
  Returns a pattern matching words -- such as Carlin's "big seven" -- that
  are most likely to give offense. Note that correct anatomical terms are
  deliberately I<not> included in the list.
  
  Under C<-keep> (see L<Regexp::Common>):
  
  =over 4
  
  =item $1
  
  captures the entire word
  
  =back
  
  =head2 C<$RE{profanity}{contextual}>
  
  Returns a pattern matching words that are likely to give offense when
  used in specific contexts, but which also have genuinely
  non-offensive meanings.
  
  Under C<-keep> (see L<Regexp::Common>):
  
  =over 4
  
  =item $1
  
  captures the entire word
  
  =back
  
  =head1 SEE ALSO
  
  L<Regexp::Common> for a general description of how to use this interface.
  
  =head1 AUTHOR
  
  Damian Conway (damian@conway.org)
  
  =head1 MAINTENANCE
  
  This package is maintained by Abigail S<(I<regexp-common@abigail.be>)>.
  
  =head1 BUGS AND IRRITATIONS
  
  Bound to be plenty.
  
  For a start, there are many common regexes missing.
  Send them in to I<regexp-common@abigail.be>.
  
  =head1 LICENSE and COPYRIGHT
  
  This software is Copyright (c) 2001 - 2017, Damian Conway and Abigail.
  
  This module is free software, and maybe used under any of the following
  licenses:
  
   1) The Perl Artistic License.     See the file COPYRIGHT.AL.
   2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2.
   3) The BSD License.               See the file COPYRIGHT.BSD.
   4) The MIT License.               See the file COPYRIGHT.MIT.
  
  =cut
REGEXP_COMMON_PROFANITY

$fatpacked{"Regexp/Common/whitespace.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'REGEXP_COMMON_WHITESPACE';
  package Regexp::Common::whitespace;
  
  use 5.10.0;
  
  use strict;
  use warnings;
  no  warnings 'syntax';
  
  use Regexp::Common qw /pattern clean no_defaults/;
  
  our $VERSION = '2017060201';
  
  pattern name   => [qw (ws crop)],
          create => '(?:^\s+|\s+$)',
          subs   => sub {$_[1] =~ s/^\s+//; $_[1] =~ s/\s+$//;}
          ;
  
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Regexp::Common::whitespace -- provides a regex for leading or
  trailing whitescape
  
  =head1 SYNOPSIS
  
      use Regexp::Common qw /whitespace/;
  
      while (<>) {
          s/$RE{ws}{crop}//g;           # Delete surrounding whitespace
      }
  
  
  =head1 DESCRIPTION
  
  Please consult the manual of L<Regexp::Common> for a general description
  of the works of this interface.
  
  Do not use this module directly, but load it via I<Regexp::Common>.
  
  
  =head2 C<$RE{ws}{crop}>
  
  Returns a pattern that identifies leading or trailing whitespace.
  
  For example:
  
          $str =~ s/$RE{ws}{crop}//g;     # Delete surrounding whitespace
  
  The call:
  
          $RE{ws}{crop}->subs($str);
  
  is optimized (but probably still slower than doing the s///g explicitly).
  
  This pattern does not capture under C<-keep>.
  
  =head1 SEE ALSO
  
  L<Regexp::Common> for a general description of how to use this interface.
  
  =head1 AUTHOR
  
  Damian Conway (damian@conway.org)
  
  =head1 MAINTENANCE
  
  This package is maintained by Abigail S<(I<regexp-common@abigail.be>)>.
  
  =head1 BUGS AND IRRITATIONS
  
  Bound to be plenty.
  
  For a start, there are many common regexes missing.
  Send them in to I<regexp-common@abigail.be>.
  
  =head1 LICENSE and COPYRIGHT
  
  This software is Copyright (c) 2001 - 2017, Damian Conway and Abigail.
  
  This module is free software, and maybe used under any of the following
  licenses:
  
   1) The Perl Artistic License.     See the file COPYRIGHT.AL.
   2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2.
   3) The BSD License.               See the file COPYRIGHT.BSD.
   4) The MIT License.               See the file COPYRIGHT.MIT.
  
  =cut
REGEXP_COMMON_WHITESPACE

$fatpacked{"Regexp/Common/zip.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'REGEXP_COMMON_ZIP';
  package Regexp::Common::zip;
  
  use 5.10.0;
  
  use strict;
  use warnings;
  no  warnings 'syntax';
  
  use Regexp::Common qw /pattern clean no_defaults/;
  
  our $VERSION = '2017060201';
  
  
  #
  # Prefer '[0-9]' over \d, because the latter may include more
  # in Unicode string.
  #
  
  #
  # ISO and Cept codes. ISO code is the second column, Cept code is
  # the third. First column matches either.
  #
  # http://cept.org/ecc/topics/numbering-networks/numbering-related-
  #        cooperation/the-cept-countries-joining-year-to-cept,
  #        -cept-and-iso-country-codes,-e164-and-e212-country-codes
  # (http://bit.ly/1Ue268b)
  #
  my %code = (
      Australia         =>  [qw /AUS? AU AUS/],
      Austria           =>  [qw /AU?T AT AUT/],
      Belgium           =>  [qw /BE?  BE B/],
      Denmark           =>  [qw /DK   DK DK/],
      France            =>  [qw /FR?  FR F/],
      Germany           =>  [qw /DE?  DE D/],
      Greenland         =>  [qw /GL   GL GL/],
      Italy             =>  [qw /IT?  IT I/],
      Liechtenstein     =>  [qw /LIE? LI LIE/],
      Luxembourg        =>  [qw /LU?  LU L/],
      Monaco            =>  [qw /MC   MC MC/],
      Netherlands       =>  [qw /NL   NL NL/],
      Norway            =>  [qw /NO?  NO N/],
     'San Marino'       =>  [qw /SM   SM SM/],
      Spain             =>  [qw /ES?  ES E/],
      Switzerland       =>  [qw /CH   CH CH/],
      USA               =>  [qw /USA? US USA/],
     'Vatican City'     =>  [qw /VA   VA VA/],
  );
  
  # Returns the empty string if the argument is undefined, the argument otherwise.
  sub __ {defined $_ [0] ? $_ [0] : ""}
  
  # Used for allowable options. If the value starts with 'y', the option is
  # required ("{1,1}" is returned, if the value starts with 'n', the option
  # is disallowed ("{0,0}" is returned), otherwise, the option is allowed,
  # but not required ("{0,1}" is returned).
  sub _t {
      if (defined $_ [0]) {
          if ($_ [0] =~ /^y/i) {return "{1,1}"}
          if ($_ [0] =~ /^n/i) {return "{0,0}"}
      }
      "{0,1}"
  }
  
  # Returns the (sub)pattern for the country named '$name', and the 
  # -country option '$country'.
  sub _c {
      my ($name, $country) = @_;
      if (defined $country && $country ne "") {
          if ($country eq 'iso')  {return $code {$name} [1]}
          if ($country eq 'cept') {return $code {$name} [2]}
          return $country;
      }
      $code {$name} [0]
  }
  
  
  my %zip = (
      #
      # Postal codes are four digits, but not all combinations are used.
      #
      # Valid codes from:
      #       https://en.wikipedia.org/wiki/List_of_postal_codes_in_Austria
      # 
      Austria =>
        "(?k:1(?:[0-8][0-9][0-9]|90[01])"                                      .
           "|2(?:[0-3][0-9][0-9]|"                                             .
                "4(?:0[0-9]|1[0-3]|2[1-5]|3[1-9]|[4-6][0-9]|7[0-5]|"           .
                    "8[1-9]|9[0-9])|"                                          .
                "[5-7][0-9][0-9]|"                                             .
                "8(?:[0-7][0-9]|8[01]))"                                       .
           "|3(?:0(?:0[1-9]|[1-9][0-9])|"                                      .
                "[12][0-9][0-9]|"                                              .
                "3(?:[0-2][0-9]|3[0-5]|[4-9][0-9])|"                           .
                "[4-8][0-9][0-9]|"                                             .
                "9(?:[0-6][0-9]|7[0-3]))"                                      .
           "|4(?:[01][0-9][0-9]|"                                              .
                "2(?:[0-8][0-9]|9[0-4])|"                                      .
                "3(?:0[0-3]|[1-8][0-9]|9[0-2])|"                               .
                "4(?:[0-1][0-9]|2[01]|3[1-9]|[4-9][0-9])|"                     .
                "[5-8][0-9][0-9]|"                                             .
                "9(?:[0-7][0-9]|8[0-5]))"                                      .
           "|5(?:0[0-9][0-9]|"                                                 .
                "1(?:0[0-9]|1[0-4]|[23][0-9]|4[0-5]|5[1-9]|[6-9][0-9])|"       .
                "2(?:0[0-5]|1[1-9]|[2-7][0-9]|8[0-3])|"                        .
                "3(?:0[0-3]|1[01]|2[1-9]|[34][0-9]|5[01]|60)|"                 .
                "[4-6][0-9][0-9]|"                                             .
                "7(?:[0-6][0-9]|7[01]))"                                       .
           "|6(?:[0-5][0-9][0-9]|"                                             .
                "6(?:[0-8][0-9]|9[01])|"                                       .
                "[78][0-9][0-9]|"                                              .
                "9(?:[0-8][0-9]|9[0-3]))"                                      .
           "|7(?:[0-3][0-9][0-9]|"                                             .
                "4(?:0[0-9]|1[0-3]|2[1-9]|[3-9][0-9])|"                        .
                "5(?:[0-6][0-9]|7[0-3]))"                                      .
           "|8(?:[0-2][0-9][0-9]|"                                             .
                "3(?:[0-5][0-9]|6[0-3]|8[0-5])|"                               .
                "4(?:0[1-9]|[1-9][0-9])|"                                      .
                "[5-8][0-9][0-9]|"                                             .
                "9(?:[0-8][0-9]|9[0-3]))"                                      .
           "|9(?:[0-6][0-9][0-9]|"                                             .
                "7(?:[0-7][0-9]|8[0-2])|"                                      .
                "8(?:[0-6][0-9]|7[0-3])|"                                      .
                "9(?:[0-8][0-9]|9[0-2]))"                                      .
      ")",
      #
      # Postal codes of the form: 'DDDD', with the first digit representing
      # the province; the others distribution sectors. Postal codes do not
      # start with a zero. Not all combinations are in use.
      #
      # Data from http://download.geonames.org/export/zip/BE.zip
      #
      Belgium  =>
        "(?k:1(?:0(?:0[05-9]|1[0-2]|20|3[01]|4[013-57-9]|50|60|70|8[0-3]|90)|" .
                "1(?:0[05]|10|20|30|40|50|60|70|80|90)|"                       .
                "2(?:0[01]|1[02])|"                                            .
                "3(?:0[01]|1[05]|2[05]|3[0-2]|4[0-28]|5[07]|6[07]|70|80|90)|"  .
                "4(?:0[0-24]|1[04]|2[018]|3[05]|40|5[07]|6[01]|"               .
                    "7[0-46]|80|9[05])|"                                       .
                "5(?:0[0-2]|4[017]|60|70)|"                                    .
                "6(?:0[0-2]|20|30|40|5[0-4]|7[0134])|"                         .
                "7(?:0[0-3]|3[01]|4[0-25]|5[05]|6[01]|70|8[05]|90)|"           .
                "8(?:0[04]|18|20|3[01]|40|5[0-3]|6[01]|80)|"                   .
                "9(?:10|3[0-4]|50|70|8[0-2]))"                                 .
  
           "|2(?:0(?:00|18|20|30|40|50|60|70)|"                                .
                "1(?:00|10|40|50|60|70|80)|"                                   .
                "2(?:00|2[0-3]|3[05]|4[023]|50|60|7[05]|8[08]|90)|"            .
                "3(?:00|10|2[0-38]|30|40|50|60|70|8[0-27]|90)|"                .
                "4(?:00|3[01]|40|50|60|70|80|9[01])|"                          .
                "5(?:00|20|3[01]|4[07]|50|60|70|80|90)|"                       .
                "6(?:00|10|2[07]|30|40|50|60)|"                                .
                "8(?:0[01]|1[12]|20|30|4[05]|50|6[01]|70|80|90)|"              .
                "9(?:00|10|20|30|40|50|60|70|80|90))"                          .
  
           "|3(?:0(?:0[01]|1[028]|20|40|5[0-4]|6[01]|7[018]|80|90)|"           .
                "1(?:1[018]|2[08]|30|40|50|9[01])|"                            .
                "2(?:0[0-2]|1[0-2]|2[01]|7[0-2]|9[034])|"                      .
                "3(?:00|2[01]|50|60|70|8[014]|9[01])|"                         .
                "4(?:0[014]|40|5[04]|6[01]|7[0-3])|"                           .
                "5(?:0[01]|1[0-2]|20|30|4[05]|50|60|70|8[0-3]|90)|"            .
                "6(?:00|2[01]|3[01]|40|50|6[058]|70|80|90)|"                   .
                "7(?:00|17|2[0-4]|3[02]|4[026]|70|9[0-38])|"                   .
                "8(?:0[036]|3[0-2]|40|50|70|9[01])|"                           .
                "9(?:00|10|20|30|4[015]|50|60|7[01]|80|90))"                   .
  
           "|4(?:0(?:00|20|3[0-2]|4[0-2]|5[0-3]|90)|"                          .
                "1(?:0[0-2]|2[0-2]|30|4[01]|51|6[0-3]|7[01]|8[01]|90)|"        .
                "2(?:1[07-9]|5[02-47]|6[013]|8[07])|"                          .
                "3(?:00|17|4[027]|5[017]|6[07])|"                              .
                "4(?:00|20|3[0-2]|5[0-38]|60|70|80)|"                          .
                "5(?:00|20|3[07]|40|5[07]|60|7[07]|90)|"                       .
                "6(?:0[0-26-8]|10|2[0134]|3[0-3]|5[0-4]|7[0-2]|8[0-4]|90)|"    .
                "7(?:0[01]|1[01]|2[018]|3[01]|50|6[01]|7[01]|8[02-4]|9[01])|"  .
                "8(?:0[0-2]|2[01]|3[0147]|4[015]|5[0-2]|6[01]|7[07]|80|90)|"   .
                "9(?:00|10|20|50|60|70|8[037]|90))" .
  
           "|5(?:0(?:0[0-4]|2[0-24]|3[0-2]|60|70|8[01])|"                      .
                "1(?:0[01]|40|50|70|90)|"                                      .
                "3(?:00|10|3[02-46]|40|5[0-4]|6[0-4]|7[02467]|80)|"            .
                "5(?:0[0-4]|2[0-4]|3[07]|4[0-4]|5[05]|6[0-4]|7[0-6]|80|90)|"   .
                "6(?:00|2[01]|30|4[0146]|5[01]|60|70|80))"                     .
  
           "|6(?:0(?:0[01]|10|20|3[0-2]|4[0-4]|6[01])|"                        .
                "1(?:1[01]|20|4[0-2]|50|8[0-3])|"                              .
                "2(?:00|1[01]|2[0-4]|3[08]|40|50|80)|"                         .
                "4(?:4[01]|6[0-4]|70)|"                                        .
                "5(?:00|11|3[0-46]|4[023]|6[07]|9[0-46])|"                     .
                "6(?:00|3[07]|4[02]|6[0-36]|7[0-4]|8[016-8]|9[028])|"          .
                "7(?:0[046]|17|2[0134]|30|4[0-37]|50|6[0-279]|8[0-2]|9[0-2])|" .
                "8(?:00|1[0-3]|2[0134]|3[0-468]|40|5[0-36]|60|70|8[07]|90)|"   .
                "9(?:00|2[0-2479]|4[01]|5[0-3]|60|7[0-2]|8[02-467]|9[07]))"    .
  
           "|7(?:0(?:00|1[0-2]|2[0-24]|3[0-4]|4[01]|50|6[0-3]|70|80|90)|"      .
                "1(?:00|10|20|3[0134]|4[01]|60|70|8[01]|9[01])|"               .
                "3(?:0[01]|2[0-2]|3[0-4]|40|50|70|8[027]|90)|"                 .
                "5(?:0[0-46]|2[0-2]|3[0-468]|4[0238])|"                        .
                "6(?:0[0-48]|1[018]|2[0-4]|4[0-3])|"                           .
                "7(?:00|1[12]|30|4[023]|50|60|8[0-4])|"                        .
                "8(?:0[0-4]|1[0-2]|2[23]|30|50|6[0-46]|70|80|90)|"             .
                "9(?:0[01346]|1[0-2]|4[0-3]|5[01]|7[0-3]))"                    .
  
           "|8(?:0(?:00|20)|"                                                  .
                "2(?:00|1[01])|"                                               .
                "3(?:0[01]|10|40|7[07]|80)|"                                   .
                "4(?:00|2[01]|3[0-4]|50|60|70|80|90)|"                         .
                "5(?:0[01]|1[01]|20|3[01]|40|5[0-4]|60|7[023]|8[0-37])|"       .
                "6(?:00|10|20|30|4[07]|50|60|70|80|9[01])|"                    .
                "7(?:00|10|20|30|40|5[05]|60|70|80|9[0-3])|"                   .
                "8(?:00|10|20|30|40|5[01]|60|70|80|90)|"                       .
                "9(?:0[02468]|20|30|40|5[0-46-8]|7[028]|80))"                  .
  
           "|9(?:0(?:00|3[0-2]|4[0-2]|5[0-2]|60|70|80|90)|"                    .
                "1(?:00|1[12]|20|30|40|50|60|70|8[05]|90)|"                    .
                "2(?:00|20|30|40|5[05]|60|70|80|90)|"                          .
                "3(?:0[08]|10|20|40)|"                                         .
                "4(?:0[0-46]|20|5[01]|7[023])|"                                .
                "5(?:0[06]|2[01]|5[0-2]|7[0-2])|"                              .
                "6(?:00|20|3[06]|6[017]|8[018]|90)|"                           .
                "7(?:00|50|7[0-2]|90)|"                                        .
                "8(?:00|10|20|3[01]|40|50|60|70|8[01]|90)|"                    .
                "9(?:00|10|2[01]|3[0-2]|40|50|6[018]|7[01]|8[0-28]|9[0-2]))"   .
      ")",
  
      #
      # Postal codes of the form: 'DDDD', with the first digit representing
      # the distribution region, the second digit the distribution district.
      # Postal codes do not start with a zero. Postal codes starting with '39'
      # are in Greenland, and not included in the pattern.
      #
      Denmark =>
        "(?k:0(?:800|"                                                         .
                "9(?:00|17|60|99))"                                            .
  
           "|1(?:0(?:00|5[0-9]|6[0-9]|7[0-4]|9[2358])|"                        .
                "1(?:0[0-7]|1[0-9]|2[0-9]|3[01]|4[078]|5[0-9]|6[0-24-9]|"      .
                    "7[0-5])|"                                                 .
                "2(?:0[0-9]|1[013-9]|2[01]|40|5[013-79]|6[013-8]|7[01]|91)|"   .
                "3(?:0[0-46-9]|1[0-9]|2[0-9]|5[02-9]|6[0-9]|7[01])|"           .
                "4(?:0[0-36-9]|1[0-9]|2[0-9]|3[0-9]|4[018]|5[0-9]|"            .
                    "6[02-46-8]|7[0-2])|"                                      .
                "5(?:00|13|3[23]|5[0-9]|6[0-46-9]|7[0-7]|9[29])|"              .
                "6(?:0[0-46-9]|1[0-9]|2[0-4]|3[0-5]|5[0-9]|6[0-9]|7[0-7]|99)|" .
                "7(?:0[0-9]|1[0-24-9]|2[0-9]|3[0-9]|49|5[0-9]|6[0-6]|"         .
                    "7[0-57]|8[05-7]|9[09])|"                                  .
                "8(?:0[0-9]|1[0-9]|2[02-9]|5[0-7]|6[0-8]|7[0-9])|"             .
                "9(?:0[0-689]|1[0-7]|2[0-8]|5[0-9]|6[0-7]|7[0-4]))"            .
  
           "|2(?:000|"                                                         .
                "1(?:00|50)|"                                                  .
                "200|"                                                         .
                "300|"                                                         .
                "4(?:00|50)|"                                                  .
                "500|"                                                         .
                "6(?:0[05]|10|2[05]|3[05]|40|50|6[05]|70|80|90)|"              .
                "7(?:00|20|30|40|50|6[05]|70|91)|"                             .
                "8(?:00|20|30|40|50|60|70|80)|"                                .
                "9(?:00|20|30|42|50|60|70|80|90))"                             .
  
           "|3(?:0(?:00|50|60|70|80)|"                                         .
                "1(?:00|20|40|50)|"                                            .
                "2(?:00|10|20|30|50)|"                                         .
                "3(?:00|10|20|30|60|70|90)|"                                   .
                "4(?:00|50|60|80|90)|"                                         .
                "5(?:00|20|40|50)|"                                            .
                "6(?:00|30|50|60|70)|"                                         .
                "7(?:00|20|30|40|51|60|70|82|90))"                             .
  
           "|4(?:0(?:00|30|40|50|60|70)|"                                      .
                "1(?:00|30|40|60|7[134]|80|90)|"                               .
                "2(?:00|20|30|4[1-3]|50|6[12]|70|81|9[1356])|"                 .
                "3(?:00|20|30|40|50|60|70|90)|"                                .
                "4(?:00|20|40|50|60|70|80|90)|"                                .
                "5(?:00|20|3[24]|40|50|60|7[1-3]|8[13]|9[1-3])|"               .
                "6(?:00|2[1-3]|32|40|5[2-4]|60|7[1-3]|8[1-4]|90)|"             .
                "7(?:00|20|3[356]|50|60|7[1-3]|80|9[1-3])|"                    .
                "8(?:00|40|50|6[23]|7[1-4]|80|9[1245])|"                       .
                "9(?:00|1[23]|20|30|4[134]|5[1-3]|60|70|83|90))"               .
  
           "|5(?:000|"                                                         .
                "2(?:00|10|20|30|40|50|60|70|90)|"                             .
                "3(?:00|20|30|50|70|80|90)|"                                   .
                "4(?:00|50|6[2-46]|7[14]|85|9[12])|"                           .
                "5(?:00|40|50|60|80|9[12])|"                                   .
                "6(?:00|10|20|31|42|72|83|90)|"                                .
                "7(?:00|50|62|7[12]|92)|"                                      .
                "8(?:00|5[346]|63|7[14]|8[1-4]|92)|"                           .
                "9(?:00|3[25]|53|60|70|85))"                                   .
  
           "|6(?:0(?:00|40|5[12]|64|70|9[1-4])|"                               .
                "100|"                                                         .
                "2(?:00|30|40|61|70|80)|"                                      .
                "3(?:00|10|20|30|40|60|72|92)|"                                .
                "4(?:00|30|40|70)|"                                            .
                "5(?:00|10|20|3[45]|41|60|80)|"                                .
                "6(?:00|2[1-3]|30|40|50|60|70|8[23]|90)|"                      .
                "7(?:0[05]|1[05]|20|31|40|5[23]|60|71|80|92)|"                 .
                "8(?:00|18|23|30|40|5[1-57]|62|70|80|93)|"                     .
                "9(?:00|20|33|40|50|60|7[13]|80|90))"                          .
  
           "|7(?:0(?:0[07]|80)|"                                               .
                "1(?:00|20|30|40|50|60|7[13]|8[2-4]|90)|"                      .
                "2(?:00|50|60|70|80)|"                                         .
                "3(?:00|2[13]|30|6[12])|"                                      .
                "4(?:00|30|4[12]|51|70|80|90)|"                                .
                "5(?:00|40|50|60|70)|"                                         .
                "6(?:00|20|50|60|73|80)|"                                      .
                "7(?:00|30|4[12]|5[25]|60|70|90)|"                             .
                "8(?:00|30|40|50|60|70|84)|"                                   .
                "9(?:00|50|60|70|80|90))"                                      .
  
           "|8(?:000|"                                                         .
                "2(?:00|10|20|30|4[05]|50|60|70)|"                             .
                "3(?:0[05]|10|20|30|40|5[05]|6[12]|70|8[0-2])|"                .
                "4(?:00|10|20|44|50|6[24]|7[12])|"                             .
                "5(?:00|20|30|4[134]|50|60|70|8[156]|92)|"                     .
                "6(?:00|20|32|4[13]|5[34]|60|70|80)|"                          .
                "7(?:00|2[1-3]|32|40|5[12]|6[2356]|8[13])|"                    .
                "8(?:00|3[0-2]|40|50|60|70|8[1-3])|"                           .
                "9(?:00|20|30|40|50|6[013]|70|8[13]|90))"                      .
  
           "|9(?:000|"                                                         .
                "2(?:00|10|20|30|40|60|70|80|93)|"                             .
                "3(?:00|10|20|30|40|52|62|70|8[0-2])|"                         .
                "4(?:00|30|40|60|80|9[023])|"                                  .
                "5(?:00|10|20|30|41|50|60|7[45])|"                             .
                "6(?:00|10|20|3[12]|40|70|81|90)|"                             .
                "7(?:00|40|50|60)|"                                            .
                "8(?:00|30|50|70|81)|"                                         .
                "9(?:00|40|70|8[12]|90))"                                      .
      ")",
  
  
  
      #
      # 5 Digit postal code, with leading 0s.
      #
      # Codes starting with 980 are reserved for Monaco, and not recognized
      # by the pattern.
      #
      # Data from: http://download.geonames.org/export/zip/FR.zip
      # 
      France      =>
        "(?k:0(?:1(?:0(?:0[0-9]|1[0-9]|20|59|6[019]|90)|1(?:0[0-9]|"           .
                    "1[0-25-7]|2[0-9]|30|40|5[0-58]|60|7[0-4]|90)|"            .
                    "2(?:0[0-468]|1[0-367]|20|30|40|50|60|70|80|90)|"          .
                    "3(?:0[0-36]|10|20|30|40|50|6[0569]|70|80|90)|4(?:00|"     .
                    "10|20|30|4[0-3]|50|60|70|80)|5(?:0[0-68]|10|40|50|60|"    .
                    "70|80|90)|6(?:0[0-46]|3[02378]|40|60|80)|7(?:0[0-8]|"     .
                    "10|50)|8(?:00|51)|9(?:21|60|90))|"                        .
                "2(?:0(?:0[0-9]|1[0-9]|2[05])|1(?:0[0-9]|10|20|30|40|5[01]|"   .
                    "60|70|90)|2(?:0[0-9]|10|20|30|40|50|60|70|90)|"           .
                    "3(?:0[0-39]|1[045]|2[0-79]|3[01]|40|50|60|70|80|90)|"     .
                    "4(?:0[0-79]|10|20|30|40|50|60|70|80|90)|5(?:00|10|20|"    .
                    "40|50|70|80|90)|6(?:0[0-49]|10|20|30|40|50|70|80|90)|"    .
                    "7(?:00|20|60|90)|8(?:00|10|20|30|40|50|60|70|80)|"        .
                    "93[09])|"                                                 .
                "3(?:0(?:0[03-8]|1[0-9]|21)|1(?:0[0-9]|10|20|30|40|50|60|"     .
                    "70|90)|2(?:0[0-9]|10|20|30|40|50|60|70|90)|"              .
                    "3(?:0[0-79]|1[01459]|2[019]|30|40|50|60|70|80|90)|"       .
                    "4(?:0[0-3569]|10|20|30|40|5[02]|60|70)|5(?:00|10)|"       .
                    "6(?:00|30)|700|800)|"                                     .
                "4(?:0(?:0[0-69]|1[0-9]|29)|1(?:0[0-7]|1[09]|20|30|40|50|"     .
                    "60|70|80|90)|2(?:0[0-39]|10|20|30|40|50|60|70|80|90)|"    .
                    "3(?:0[01]|10|20|30|40|50|60|70|80)|4(?:00|10|20)|"        .
                    "5(?:00|10|30)|6(?:00|60)|700|8(?:00|50|60|70)|99[05])|"   .
                "5(?:0(?:0[0-8]|1[0-24-69])|1(?:0[0-57]|10|20|30|40|50|60|"    .
                    "70|90)|2(?:0[0-289]|20|30|40|50|60|90)|3(?:00|10|20|"     .
                    "30|40|50|80)|4(?:00|60|70|80)|5(?:00|60)|600|700|800)|"   .
                "6(?:0(?:0[0-9]|1[0-36]|3[2-6]|4[4-9]|5[03]|7[1389]|8[2-5]|"   .
                    "99)|1(?:0[0-35-9]|1[03-79]|2[156]|3[0-35-79]|4[0-3]|"     .
                    "5[0-7]|6[0-247]|7[0-357]|8[0-79]|90)|2(?:0[0-69]|"        .
                    "1[0-2]|2[0-9]|3[0-9]|4[0-2]|5[0-579]|60|7[0-2]|"          .
                    "8[1-46-9]|9[02-59])|3(?:0[0-69]|10|20|30|4[0-589]|"       .
                    "5[2-47-9]|6[049]|7[0-369]|80|9[0-2])|4(?:0[0-8]|1[04]|"   .
                    "20|30|40|50|60|70|80)|5(?:0[0-8]|1[013-8]|20|3[0-245]|"   .
                    "40|50|60|70|80|90)|6(?:0[0-79]|10|20|3[1-4]|40|50|"       .
                    "6[06]|70|90)|7(?:0[0-689]|10|2[13]|30|40|50|90)|"         .
                    "8(?:0[0-68]|10|2[569]|3[013]|50|91)|9(?:0[1-69]|"         .
                    "1[02-5]|2[12589]|50|99))|"                                .
                "7(?:00[0-7]|1(?:0[0-9]|10|20|3[0-9]|40|50|60|70|90)|"         .
                    "2(?:0[0-9]|10|20|30|40|50|60|70|90)|3(?:0[0-9]|10|20|"    .
                    "30|40|50|60|70|80)|4(?:0[0-9]|10|30|40|50|60|70)|"        .
                    "5(?:0[0-9]|10|20|30|60|70|80|90)|6(?:00|10|30|60|90)|"    .
                    "7(?:00|90)|800)|"                                         .
                "8(?:0(?:0[0-6]|1[0134]|9[089])|1(?:0[1-79]|10|20|30|40|50|"   .
                    "60|70|90)|2(?:0[0-9]|10|20|30|40|50|60|70|90)|"           .
                    "3(?:0[02-5]|10|20|30|50|60|70|80|90)|4(?:00|10|30|40|"    .
                    "50|60)|500|600|700|800)|"                                 .
                "9(?:0(?:0[0-47-9]|1[4-7])|1(?:0[0-59]|10|20|30|40|60|90)|"    .
                    "2(?:0[019]|10|20|30|40|50|70|90)|3(?:0[01]|10|20|30|"     .
                    "40|50|90)|4(?:0[01]|20|60)|500|600|700|800))"             .
  
           "|1(?:0(?:0(?:0[0-9]|1[0-58]|2[56]|3[0-2]|42|8[0189]|9[126])|"      .
                    "1(?:0[0-5]|10|2[0-28]|30|40|5[0-4]|60|70|80|90)|"         .
                    "2(?:0[0-28]|10|20|30|40|50|60|70|80|90)|3(?:00|10|20|"    .
                    "30|40|5[0-35]|60|7[01]|80|90)|4(?:0[0-4]|10|20|3[0-3]|"   .
                    "40|50)|5(?:00|10)|60[0-356]|700|800|9(?:0[12]|10))|"      .
                "1(?:0(?:0[0-579]|1[0-25-7]|2[0-29])|1(?:0[0-9]|10|20|30|"     .
                    "40|50|60|70|90)|2(?:0[0-589]|10|20|30|40|50|60|70|90)|"   .
                    "3(?:0[0134]|10|20|30|40|50|60|70|80|90)|4(?:0[0-29]|"     .
                    "10|20|30|40|5[1-3]|80|9[0-4])|5(?:00|10|40|60|70|80|"     .
                    "90)|6(?:00|10|20)|7(?:00|8[12459]|90)|8(?:0[0235-8]|"     .
                    "1[06]|23|3[3568]|48|5[05]|60|7[05-8]|8[05]|9[08]))|"      .
                "2(?:0(?:0[0-357-9]|19|2[0-9]|3[0-59]|40)|1(?:0[0-4689]|10|"   .
                    "20|30|40|50|60|70|90)|2(?:0[0-4]|10|20|30|40|50|60|70|"   .
                    "90)|3(?:00|10|20|30|40|50|60|70|80|90)|4(?:0[0-2]|10|"    .
                    "20|30|40|50|60|70|80|90)|5(?:00|10|20|40|50|60|80)|"      .
                    "6(?:00|20|30|40)|7(?:00|20|40|80)|8(?:00|50))|"           .
                "3(?:0(?:0[0-9]|1[0-6]|20|6[67]|8[0589]|9[0-9])|1(?:0[0-9]|"   .
                    "1[0-9]|2[0-46-9]|3[0-389]|4[0-289]|5[0-35-9]|"            .
                    "6[013-589]|7[078]|8[0-2]|9[0-26])|2(?:0[0-3579]|"         .
                    "1[013-9]|2[0-8]|3[0-69]|4[0-589]|5[0-9]|6[0-9]|7[0-9]|"   .
                    "8[0-24-9]|9[0-9])|3(?:0[0-46-9]|1[0-9]|2[0-8]|"           .
                    "3[0-589]|4[02-8]|5[0-24-79]|6[0-46-9]|7[0-24-9]|"         .
                    "8[0-9]|9[0-79])|4(?:0[0-46]|1[0-7]|2[014-68]|3[0-245]|"   .
                    "4[0-8]|5[0-8]|6[02-47]|7[0-48]|8[0-49]|9[03])|"           .
                    "5(?:0[0-3]|1[0-4689]|2[0-589]|3[0-389]|4[0-35-9]|"        .
                    "5[0-289]|6[06-8]|7[02]|8[013]|9[0-49])|6(?:0[0-9]|"       .
                    "1[0-24-79]|2[015-9]|3[0-357]|4[0-369]|5[0-689]|6[0-9]|"   .
                    "7[0-8]|8[013-57-9]|9[0-9])|7(?:0[0-589]|1[02-9]|"         .
                    "2[0-9]|3[0-3]|4[0-79]|5[0-257-9]|6[046]|7[0-9]|"          .
                    "8[0-59]|9[0-9])|8(?:0[0-9]|1[02-5]|2[0-589]|3[0-689]|"    .
                    "4[0-24-7]|5[0-9]|6[0-478]|70|8[01379]|9[05])|"            .
                    "9(?:0[024-8]|1[01]|2[0-4]|3[0-37]|4[0-2]|50|60|80|90))|"  .
                "4(?:0(?:0[05-9]|1[0-9]|2[03-9]|3[0-9]|4[05-8]|5[0-489]|"      .
                    "6[1-7]|7[04-9]|8[1-69]|9[0-9])|1(?:0[0-9]|1[0-47]|"       .
                    "2[0135-8]|30|40|50|6[0-258]|70|90)|2(?:0[0-57-9]|10|"     .
                    "20|30|40|50|60|70|80|90)|3(?:10|20|30|40|50|60|70|80|"    .
                    "90)|4(?:0[0-9]|10|20|30|40|50|6[0-29]|70|80|90)|"         .
                    "5(?:0[0-589]|10|20|30|40|50|70|90)|6(?:0[0-3]|10|20|"     .
                    "30|40|5[0-49]|70|80|90)|7(?:00|10|30|40|50|60|70|80|"     .
                    "9[01])|8(?:0[0-9]|10|30|40|50|60|80)|9(?:0[1-9]|"         .
                    "1[0-69]|2[0-6]|3[0-4]|4[09]|50|60|70|80|90))|"            .
                "5(?:0(?:0[0-8]|1[0-57-9])|1(?:0[0-79]|10|20|30|40|50|60|"     .
                    "70|90)|2(?:00|10|2[09]|30|40|50|60|70|90)|3(?:00|10|"     .
                    "20|40|50|80)|4(?:00|30)|5(?:00|90)|600|700|800)|"         .
                "6(?:0(?:0[0-8]|1[0-9]|2[0-6])|1(?:0[0-9]|1[0-3]|2[01]|30|"    .
                    "40|50|60|70|90)|2(?:00|10|20|30|40|50|60|70|90)|"         .
                    "3(?:00|10|20|30|40|50|60|70|80|90)|4(?:00|10|20|30|40|"   .
                    "50|60|70|80|90)|5(?:00|10|60|70|90)|6(?:00|20)|7(?:00|"   .
                    "10|20|30)|800|9(?:0[1-9]|1[0-9]|2[09]|5[0-59]|99))|"      .
                "7(?:0(?:0[0-9]|1[0-9]|2[0-9]|3[0-9]|4[0-5]|5[1-6]|"           .
                    "7[1-689]|8[6-9])|1(?:0[0-9]|1[0-9]|2[013]|3[0236-9]|"     .
                    "40|50|60|70|8[0-9]|90)|2(?:0[0-9]|1[0145]|20|30|40|50|"   .
                    "60|70|8[1459]|90)|3(?:0[0-9]|1[0-4]|20|30|40|50|60|70|"   .
                    "80|90)|4(?:00|1[0-69]|20|30|4[0-69]|50|60|70|80|90)|"     .
                    "5(?:0[0-49]|10|20|30|40|50|60|70|80|90)|6(?:00|10|20|"    .
                    "30|40|50|70|90)|7(?:00|30|40|50|70|80)|8(?:00|10|40|"     .
                    "70|80|90)|9(?:20|40))|"                                   .
                "8(?:0(?:0[0-7]|1[2-69]|2[0-9]|3[0-79])|1(?:0[0-9]|10|20|"     .
                    "30|40|50|60|70|90)|2(?:0[0-7]|10|20|30|40|50|60|70|"      .
                    "90)|3(?:00|10|20|30|40|50|60|70|80|90)|4(?:00|10)|"       .
                    "5(?:00|10|20|70)|600|700|800|9(?:1[01]|2[02-4]|3[459]|"   .
                    "4[015]|98))|"                                             .
                "9(?:0(?:0[0-79]|1[1257-9]|33)|1(?:0[0-9]|1[01346-9]|20|30|"   .
                    "40|50|60|70|90)|2(?:0[0-489]|10|20|3[0-2]|40|50|60|70|"   .
                    "90)|3(?:00|1[0-9]|20|30|40|50|6[01]|70|80|90)|4(?:00|"    .
                    "10|30|50|60|70|90)|5(?:00|10|20|50|60)|600|700|800))"     .
  
           "|2(?:0(?:0(?:00|90)|1(?:00|1[0-9]|2[1-9]|3[0-9]|4[0-8]|5[0-37]|"   .
                    "6[02-9]|7[0-9]|8[0-9]|9[0-57-9])|2(?:00|1[2-57-9]|"       .
                    "2[0-9]|3[0-9]|4[02-8]|5[0-369]|60|7[02569]|8[7-9]|"       .
                    "9[0-9])|3(?:0[2-69]|11)|4(?:0[1-35-9]|1[0-46-9])|"        .
                    "5(?:0[1-4]|3[78])|6(?:0[014]|11|20)|70[0-3]|900)|"        .
                "1(?:0(?:0[0-9]|1[0-9]|2[1-9]|3[0-9]|4[0-9]|5[1-9]|"           .
                    "6[0-35-9]|7[0-9]|8[013-689]|9[2378])|1(?:10|2[01]|30|"    .
                    "40|50|60|70|90)|2(?:0[0-9]|1[09]|20|30|40|50|6[0-2]|"     .
                    "70|90)|3(?:0[0-59]|10|20|30|40|50|60|70|80|90)|"          .
                    "4(?:0[0-39]|10|20|30|40|50|60|70|90)|5(?:0[0-269]|10|"    .
                    "20|30|40|50|60|70|80|90)|6(?:0[0-49]|10|30|40|90)|"       .
                    "7(?:0[0-59]|19|60)|8(?:0[0-369]|20|50)|9(?:00|10|98))|"   .
                "2(?:0(?:0[0-5]|1[4-7]|2[1-79]|3[1-5]|4[1-69]|7[09]|8[09]|"    .
                    "9[1-35689])|1(?:0[0-9]|1[01]|20|30|40|50|60|70|"          .
                    "9[0-69])|2(?:0[0-69]|10|20|30|40|50|60|70|90)|"           .
                    "3(?:0[0-9]|10|20|30|40|50|60|70|80|90)|4(?:0[02-59]|"     .
                    "10|20|30|40|50|60|70|80|90)|5(?:0[0-59]|10|20|30|40|"     .
                    "50|60|70|80|90)|6(?:0[02-79]|10|20|30|40|50|60|80|90)|"   .
                    "7(?:00|10|20|30|40|50|70|80)|8(?:00|10|20|30|60|70)|"     .
                    "9(?:30|40|50|60|70|80))|"                                 .
                "3(?:0(?:0[0-9]|1[13-6]|20)|1(?:00|10|20|30|40|50|60|70|"      .
                    "90)|2(?:00|10|20|30|40|50|60|70|90)|3(?:00|20|40|50|"     .
                    "60|80)|4(?:00|20|30|50|60|80)|500|600|700|800)|"          .
                "4(?:0(?:0[0-579]|1[0-79]|2[0249]|5[0-359]|60)|"               .
                    "1(?:0[0-24-9]|1[0-4]|2[0-2]|30|40|50|60|70|90)|"          .
                    "2(?:0[0-689]|1[02]|20|30|40|50|60|70|90)|3(?:00|10|20|"   .
                    "30|40|50|60|70|80|90)|4(?:00|10|20|30|40|50|60|70|80|"    .
                    "90)|5(?:00|10|20|30|40|50|60|70|80|90)|6(?:00|10|20|"     .
                    "30|40|50|60|80)|7(?:00|5[0-2589])|800|9(?:1[0235]|26))|"  .
                "5(?:0(?:0[0-9]|1[0-9]|2[0-79]|3[0-9]|4[0-9]|5[0-246-9]|"      .
                    "6[0-389]|7[0-359]|8[02-79]|9[089])|1(?:1[0-9]|20|30|"     .
                    "40|50|60|70|90)|2(?:0[0-9]|1[0-9]|20|30|40|50|60|70|"     .
                    "90)|3(?:0[0-49]|10|20|30|40|50|60|70|80|90)|"             .
                    "4(?:0[0-69]|10|20|30|40|50|6[0-29]|7[09]|80|90)|"         .
                    "5(?:0[0-489]|10|20|30|50|60|70|80)|6(?:0[0-9]|10|20|"     .
                    "30|40|50|60|80|90)|7(?:0[0-26-9]|20|50|70|90)|8(?:00|"    .
                    "20|40|70)|9(?:09|20|3[0-3]|60))|"                         .
                "6(?:0(?:0[0-9]|1[0-5]|2[1-9]|3[0-2])|1(?:0[0-9]|1[019]|20|"   .
                    "3[01]|40|50|60|70|9[09])|2(?:0[0-9]|1[056]|20|30|"        .
                    "4[0-49]|50|60|70|90)|3(?:0[0-49]|10|20|30|40|50|80|"      .
                    "90)|4(?:0[0-29]|10|20|50|60|70)|5(?:0[0-49]|10|30|40|"    .
                    "60|70)|6(?:0[0-39]|20)|7(?:0[0-29]|30|40|50|6[01]|70|"    .
                    "80|90)|80[0-29]|9(?:0[1-79]|5[0-68]))|"                   .
                "7(?:0(?:0[0-9]|1[0235-9]|2[1-356]|3[0-9]|40|9[0-9])|"         .
                    "1(?:0[0-9]|10|2[0-27]|3[0-8]|40|50|60|70|80|90)|"         .
                    "2(?:0[0-9]|10|20|30|40|50|60|70|90)|3(?:0[0-9]|10|20|"    .
                    "30|40|50|60|70|80|90)|4(?:0[0-79]|10|20|30|40|50|60|"     .
                    "70|80|90)|5(?:0[0-9]|10|20|30|40|50|60|70|80|90)|"        .
                    "6(?:0[07]|10|20|30|40|50|60|70|80|90)|7(?:0[0-35]|10|"    .
                    "20|30|40|50|60|70|80|90)|8(?:00|10|20|30|50|60|70|90)|"   .
                    "9(?:09|1[014]|2[0489]|3[0-369]|4[09]|50))|"               .
                "8(?:0(?:0[0-9]|1[189]|2[3-69]|3[3-9]|4[04]|8[08])|"           .
                    "1(?:0[0-689]|1[0-49]|20|3[0-3]|40|50|60|70|90)|"          .
                    "2(?:0[0-3579]|1[01]|20|3[0-24]|40|50|60|70|90)|"          .
                    "3(?:0[0-59]|10|20|30|40|50|60|80)|4(?:0[0-49]|10|"        .
                    "8[019])|50[01]|6(?:00|3[0-3679])|70[0-379]|800|9(?:01|"   .
                    "10|20|3[0-35]|44|50))|"                                   .
                "9(?:0(?:00|18|80)|1(?:0[0-9]|2[0-59]|40|50|60|7[0-4679]|"     .
                    "8[0-79]|9[0-369])|2(?:0[06-9]|1[0-37-9]|2[0-57-9]|"       .
                    "3[138]|4[0-26]|5[0239]|60|70|8[029]|9[09])|3(?:00|10|"    .
                    "2[0-8]|3[0-7]|40|50|60|70|80|9[0-9])|4(?:0[0-4679]|"      .
                    "1[0-49]|20|30|40|5[05]|60|70|80|90)|5(?:00|10|20|30|"     .
                    "40|5[0-9]|6[013]|70|90)|6(?:0[0269]|10|20|30|40|50|60|"   .
                    "7[0-489]|8[0-2489]|90)|7(?:00|10|20|30|40|50|60|70|80|"   .
                    "90)|8(?:0[0-46-9]|10|2[0457]|3[03-79]|40|50|60|70|80|"    .
                    "90)|9(?:00|10|20|30|40|50|70|80|90)))"                    .
  
           "|3(?:0(?:0(?:0[0-36-9]|1[0-9]|2[0-589]|3[1-69]|4[04589]|"          .
                    "5[015])|1(?:0[0-79]|1[0-2459]|2[0-9]|3[0-49]|40|50|60|"   .
                    "70|90)|2(?:0[0-79]|10|20|30|40|5[0-35]|60|70|90)|"        .
                    "3(?:0[0-2]|1[01389]|20|30|40|50|60|80|90)|4(?:0[0-69]|"   .
                    "10|20|30|40|50|60|70|80|90)|5(?:00|10|20|30|40|60|70|"    .
                    "80)|6(?:00|10|20|30|40|50|60|70)|7(?:0[0-3]|20|30|40|"    .
                    "50|60|70)|8(?:00|20|40|70)|9(?:0[013-8]|1[0-48]|"         .
                    "2[0-59]|3[124-79]|4[0-37]|6[09]|7[125]|80))|"             .
                "1(?:0(?:0[0-9]|1[0-9]|2[0-9]|3[0-9]|4[0-9]|5[0-9]|6[0-9]|"    .
                    "7[0-9]|8[0-24-689]|9[0-9])|1(?:0[0-4679]|1[02]|2[0-9]|"   .
                    "3[0-9]|4[0-29]|5[0-259]|60|70|8[09]|90)|2(?:0[013-5]|"    .
                    "10|20|30|4[0-59]|50|60|70|8[09]|90)|3(?:00|1[02-579]|"    .
                    "2[0-2569]|30|40|50|60|70|8[09]|90)|4(?:0[0-6]|10|20|"     .
                    "3[02]|40|50|60|70|8[09]|90)|5(?:0[03-7]|1[02]|"           .
                    "2[0-249]|30|40|50|60|70|8[09]|90)|6(?:0[0-689]|2[019]|"   .
                    "50|60|7[0-9]|8[1-359]|92)|7(?:0[0-9]|1[1256]|50|"         .
                    "7[0-4679]|80|90)|8(?:0[0-79]|10|20|3[0-29]|40|50|60|"     .
                    "70|80)|9(?:0[0-3]|31|4[57]|5[078]|6[02]|9[89]))|"         .
                "2(?:0(?:0[0-57-9]|1[0-46-9]|2[0-2])|1(?:00|10|2[09]|30|40|"   .
                    "50|60|70|90)|2(?:0[019]|20|30|40|50|60|70|90)|3(?:00|"    .
                    "10|20|30|40|50|60|70|80|90)|4(?:00|10|20|30|40|50|60|"    .
                    "80|90)|5(?:0[0-259]|50)|600|7(?:00|20|30)|8(?:00|10))|"   .
                "3(?:0(?:0[0-24-9]|1[0-259]|2[013-9]|3[0-8]|4[0-37-9]|"        .
                    "5[0-9]|6[0-9]|7[0-9]|8[0-9]|9[0-9])|1(?:00|1[02-6]|"      .
                    "2[013-7]|3[038]|4[018]|5[0-35]|6[04-79]|7[0-5]|"          .
                    "8[05-7]|9[0-3])|2(?:00|1[0-49]|20|30|40|50|60|"           .
                    "7[0-489]|9[0-5])|3(?:0[0569]|1[0-49]|2[0-4679]|3[05]|"    .
                    "4[01]|50|60|70|80|9[0-5])|4(?:0[0-59]|10|20|30|40|"       .
                    "5[0-2]|6[019]|70|80|9[0-25])|5(?:0[0-79]|1[05]|"          .
                    "2[0-79]|30|40|50|6[0-5]|70|80|90)|6(?:0[0-9]|1[0-5]|"     .
                    "2[015-79]|40|5[02]|60|70|8[089]|9[0-9])|7(?:0[0-9]|10|"   .
                    "20|3[0-9]|4[017]|50|60|70|80|90)|8(?:0[01]|10|20|30|"     .
                    "40|50|60|70|8[0-7]|90)|9(?:0[0-79]|1[0-589]|20|30|50|"    .
                    "70|80|9[08]))|"                                           .
                "4(?:0(?:0[0-46-9]|1[0-2]|2[3-8]|3[02-57-9]|4[0-35689]|"       .
                    "5[13-68]|6[0-8]|7[0-9]|8[0235-79]|9[0-9])|1(?:1[0-9]|"    .
                    "20|3[0-27-9]|40|50|60|7[0-489]|8[13467]|9[0-9])|"         .
                    "2(?:0[0-479]|10|20|30|40|50|6[0-7]|7[04]|80|9[03-9])|"    .
                    "3(?:0[0-579]|10|20|30|40|50|60|70|80|9[0-46-9])|"         .
                    "4(?:0[0-49]|10|20|3[013-589]|40|50|60|7[037]|80|90)|"     .
                    "5(?:0[0-8]|1[03-8]|2[0-69]|3[04-79]|4[03-5]|50|6[04]|"    .
                    "70|90)|6(?:00|10|20|30|50|60|7[01]|80|90)|7(?:0[0-2]|"    .
                    "10|2[05]|30|4[0-27-9]|5[013]|60|70|90)|8(?:00|10|20|"     .
                    "30|50|7[1-5]|80)|9(?:00|2[0356]|3[2-57-9]|4[02-489]|"     .
                    "5[4-9]|6[0-2457]|7[02-57]|8[0-79]|90))|"                  .
                "5(?:0(?:0[0-9]|1[0-24-68]|2[0-46-9]|3[0-59]|4[02-79]|"        .
                    "5[0-57-9]|6[3-79]|7[013689]|8[0-9]|9[0-49])|"             .
                    "1(?:0[1-689]|1[134]|20|3[0-7]|40|50|6[0-469]|"            .
                    "7[0-24-7]|90)|2(?:0[0-57-9]|10|2[01]|3[056]|40|50|60|"    .
                    "70|90)|3(?:0[0-69]|10|20|30|4[0-259]|50|60|70|80|90)|"    .
                    "4(?:0[0-9]|1[0-9]|20|3[0-359]|40|50|60|70|80|90)|"        .
                    "5(?:0[0-79]|1[0-9]|2[01]|3[0-389]|40|50|60|7[1-46-9]|"    .
                    "80|90)|6(?:0[0-356]|10|20|30|40|5[0-39]|60|80|90)|"       .
                    "7(?:0[0-9]|11|20|30|4[0-46]|50|6[0-9]|7[0-2]|80)|"        .
                    "8(?:0[0-3]|3[0-3]|50|70|90)|9(?:0[0-9]|1[1-9]|2[01]|"     .
                    "60|98))|"                                                 .
                "6(?:0(?:0[0-9]|1[0-9]|2[0-9]|3[23])|1(?:0[0-579]|10|20|"      .
                    "3[01]|40|50|60|70|80|90)|2(?:00|10|20|30|40|5[05]|60|"    .
                    "70|90)|3(?:0[01]|10|20|30|40|50|60|70)|400|50[015]|"      .
                    "600|700|800|91[05])|"                                     .
                "7(?:0(?:0[089]|1[0-9]|2[05-9]|3[2-589]|4[0-57-9]|5[89]|"      .
                    "6[01]|7[1-9]|8[0-29]|9[5-9])|1(?:00|10|20|30|40|5[02]|"   .
                    "60|7[0-59]|90)|2(?:0[04-69]|10|20|30|40|50|60|70|90)|"    .
                    "3(?:0[0-69]|10|2[01]|30|40|50|60|70|80|90)|"              .
                    "4(?:0[0-49]|20|60)|5(?:0[0-29]|10|2[01]|30|4[0-29]|"      .
                    "5[0-6])|60[0-29]|70[0-359]|800|9(?:1[0-357]|2[124-9]|"    .
                    "3[12]|4[12]))|"                                           .
                "8(?:0(?:0[0-9]|1[0-9]|2[1-9]|3[0-79]|4[0-9]|5[0-4689]|"       .
                    "6[135-79]|7[047]|8[019]|9[0-36-9])|1(?:00|1[02-489]|"     .
                    "2[0-2]|3[048]|4[0246-8]|5[02-49]|6[0-59]|7[0-469]|80|"    .
                    "9[0167])|2(?:0[0-9]|1[016-9]|20|3[0-26]|4[0-469]|"        .
                    "5[06]|6[019]|70|80|9[0-35-79])|3(?:0[0-579]|1[1-579]|"    .
                    "2[0-2679]|3[0-4]|4[0-35-79]|5[0-46-9]|6[01]|70|80|90)|"   .
                    "4(?:0[0-9]|10|20|3[0-79]|40|50|60|70|80|90)|"             .
                    "5(?:0[0-9]|1[0169]|2[0-469]|30|40|5[0-79]|60|70|80|"      .
                    "9[01])|6(?:0[0-39]|10|20|30|40|50|60|70|80|90)|"          .
                    "7(?:0[0-26-9]|10|3[01]|40|50|6[01379]|70|8[0-249]|90)|"   .
                    "8(?:0[0-3]|1[67]|21|30|40|50|60|70|80|90)|9(?:00|13|"     .
                    "2[0167]|30|4[0134]|50|60|70|80))|"                        .
                "9(?:0(?:0[0-9]|1[056]|2[19]|3[0-9])|1(?:0[0-9]|10|20|30|"     .
                    "40|50|60|7[01]|8[019]|90)|2(?:0[0-9]|1[019]|20|30|40|"    .
                    "50|6[01]|70|90)|3(?:0[0-9]|10|20|30|50|60|70|80)|"        .
                    "4(?:0[0-9]|10|60)|5(?:0[0-2]|20|70)|60[0-359]|700|"       .
                    "80[0-9]))"                                                .
  
           "|4(?:0(?:0(?:0[0-6]|1[1-35-9]|2[1-7]|90)|1(?:0[0-8]|1[058]|20|"    .
                    "30|4[01]|50|6[01]|70|80|90)|2(?:0[0-2]|10|20|3[0-259]|"   .
                    "40|50|60|70|8[0-26]|90)|3(?:0[0159]|10|20|30|50|60|70|"   .
                    "80|90)|4(?:00|10|20|30|40|6[05]|80)|5(?:0[0-2]|10|30|"    .
                    "50|60)|6(?:0[0-2]|30|60)|70[015]|80[015]|99[0-4])|"       .
                "1(?:0(?:0[0-9]|1[0-35689]|2[0235689]|3[3-5]|4[23])|"          .
                    "1(?:0[0-3569]|10|2[0-2]|30|40|5[01]|60|70|90)|"           .
                    "2(?:0[0-7]|10|20|30|40|50|6[01]|70|90)|3(?:00|10|20|"     .
                    "30|5[03-57]|60|70)|40[0-26]|500|600|700|800|"             .
                    "9(?:0[13-689]|1[03-589]|2[145]|3[0-36]|4[1-3589]|"        .
                    "5[018]|6[03-8]|7[0-6]))|"                                 .
                "2(?:0(?:0[0-9]|1[0-8]|2[1-9]|3[013]|4[1-357-9]|5[0589])|"     .
                    "1(?:00|1[014]|2[02-79]|3[01]|40|5[0235]|6[0-9]|"          .
                    "7[03469]|90)|2(?:10|20|30|40|60|7[0-35-79]|90)|"          .
                    "3(?:0[0-48]|1[0-58]|2[0-38]|3[02-59]|40|5[013-69]|60|"    .
                    "70|80|90)|4(?:0[0-9]|1[0-2]|20|30|40|50|60|70|8[0469]|"   .
                    "90)|5(?:0[0-359]|10|20|30|40|50|60|70|80|90)|"            .
                    "6(?:0[0-9]|10|20|30|40|5[013]|60|70|80)|7(?:0[0-579]|"    .
                    "20|40|50|80)|8(?:0[0-9]|10|20|30|40|90)|9(?:20|40|"       .
                    "5[0-589]|6[1-9]|90))|"                                    .
                "3(?:0(?:0[0-689]|1[0-479])|1(?:0[0-3]|10|20|30|40|50|60|"     .
                    "70|90)|2(?:0[0-3]|10|20|30|40|50|60|70|90)|3(?:00|20|"    .
                    "30|40|50|60|70|80|90)|4(?:00|10|20|30|40|50|90)|"         .
                    "5(?:00|10|20|30|50|80|90)|6(?:00|20)|7(?:00|50|70)|"      .
                    "8(?:00|10))|"                                             .
                "4(?:0(?:0[0-9]|1[0-9]|2[0-4]|3[2-68]|4[0-267]|9[02-579])|"    .
                    "1(?:0[0-79]|1[05-9]|2[0-469]|30|4[0-69]|5[0-9]|60|"       .
                    "7[069]|8[4-8]|9[0-689])|2(?:0[0-59]|1[0-79]|20|"          .
                    "3[0-69]|4[0-59]|50|6[0-358]|7[02-7]|90)|3(?:0[0-9]|"      .
                    "1[0-9]|2[0-9]|3[0-9]|4[0-69]|5[0-36-9]|60|7[0-39]|80|"    .
                    "90)|4(?:0[0-9]|1[02]|20|30|40|50|60|7[0-9]|8[0-4]|90)|"   .
                    "5(?:0[0-69]|10|2[0-2]|30|40|50|60|70|80|90)|"             .
                    "6(?:0[0-69]|1[0-8]|20|30|40|50|60|70|80|90)|"             .
                    "7(?:0[0-36-9]|10|20|30|40|50|60|70|80)|8(?:0[0-9]|"       .
                    "1[0-9]|2[1-49]|30|40|50|60|80)|9(?:00|1[1-9]|2[1-9]|"     .
                    "3[1-9]|4[124579]|5[1-9]|6[3-9]|7[1-8]|8[0-69]))|"         .
                "5(?:0(?:0[0-9]|1[0-25-79]|2[13589]|3[0-58]|4[0-6]|"           .
                    "5[236-8]|6[0-57-9]|7[1-57-9]|8[1278])|1(?:00|10|"         .
                    "2[0-259]|30|4[0-79]|50|6[0-689]|70|90)|2(?:0[0-9]|"       .
                    "1[0-4]|20|30|40|50|60|70|90)|3(?:0[02-8]|1[02]|20|"       .
                    "3[01]|40|60|70|80|90)|4(?:0[0-469]|10|20|3[0-3]|50|60|"   .
                    "70|80|90)|5(?:0[0-4]|10|20|30|50|60|70|90)|6(?:00|20|"    .
                    "30|40|5[0156]|80)|7(?:0[0-29]|20|30|40|50|60|"            .
                    "7[01457])|8(?:0[0-9]|11)|9(?:00|1[0-35-9]|2[0-79]|"       .
                    "3[0-8]|4[3-9]|5[0-7]|6[0-9]|7[0-9]|80))|"                 .
                "6(?:0(?:0[0-589]|1[04-9]|2[0-3]|9[01])|1(?:0[0-36]|10|20|"    .
                    "30|40|50|60|70|90)|2(?:00|10|20|30|40|50|60|70)|"         .
                    "3(?:00|10|20|30|40|50|60)|400|500|600|700|800)|"          .
                "7(?:0(?:0[02-8]|13|2[03]|3[0-29])|1(?:10|20|30|40|50|60|"     .
                    "70|80|90)|2(?:0[0-57-9]|1[013]|20|30|40|50|60|70|90)|"    .
                    "3(?:0[0-57-9]|10|20|30|40|50|60|70|80|90)|4(?:00|10|"     .
                    "20|30|40|50|70|80)|5(?:0[0-2]|10|20|5[0-359])|600|700|"   .
                    "800|9(?:0[19]|1[0-8]|2[0-59]|31))|"                       .
                "8(?:00[0-35-9]|1(?:00|10|20|30|40|50|60|70|90)|2(?:00|10|"    .
                    "20|30|40|50|60|70)|3(?:00|10|20|30|40|70)|400|500|600|"   .
                    "700|800)|"                                                .
                "9(?:0(?:0[0-46-9]|1[014-8]|2[0-468]|3[2356]|4[13-79]|"        .
                    "5[1-359]|66|7[0-29]|80)|1(?:0[0-79]|1[0-25-79]|"          .
                    "2[02-5]|3[05-79]|40|50|60|70|8[0-4]|90)|2(?:20|30|"       .
                    "4[0-59]|50|60|70|80|90)|3(?:0[0-9]|1[0-249]|2[0157-9]|"   .
                    "30|40|50|60|70|80|90)|4(?:0[0-689]|1[0-578]|2[015-8]|"    .
                    "30|40|5[068]|60|8[0146]|90)|5(?:0[0-59]|10|20|30|40|"     .
                    "60|70|90)|6(?:0[0-29]|10|20|30|40|50|60|70|80|90)|"       .
                    "7(?:00|10|30|40|50|70)|80[0-59]|9(?:0[56]|1[1-39]|"       .
                    "2[57]|3[347-9]|4[19])))"                                  .
  
           "|5(?:0(?:0(?:0[0-9]|1[0-6]|50)|1(?:0[0-9]|1[03-5]|20|3[01]|40|"    .
                    "50|60|70|80|90)|2(?:0[0-9]|1[01]|20|30|40|50|60|70|"      .
                    "90)|3(?:0[0-9]|10|20|30|40|50|60|70|80|90)|"              .
                    "4(?:0[0-79]|10|20|30|4[0-24-9]|50|60|70|80|90)|5(?:00|"   .
                    "10|20|30|40|50|60|70|80|90)|6(?:00|10|20|30|40|5[12]|"    .
                    "60|70|80|90)|7(?:00|10|20|30|40|50|60|70)|8(?:00|10|"     .
                    "40|50|60|70|80|90)|95[018])|"                             .
                "1(?:0(?:0[015-9]|1[0-367]|2[12]|3[5-9]|4[1-3]|5[1-9]|"        .
                    "6[0-9]|7[0-79]|8[0-46-9]|9[025-79])|1(?:00|10|2[0-2]|"    .
                    "30|40|50|60|70|90)|2(?:0[0-9]|10|20|30|40|50|60|70|"      .
                    "90)|3(?:0[0-689]|1[089]|20|3[0-4]|4[09]|50|6[01]|70|"     .
                    "80|90)|4(?:0[01]|20|3[0-5]|50|60|70|80|90)|5(?:00|10|"    .
                    "20|30|7[1-3])|6(?:0[01]|6[2-4]|7[357-9]|8[2-9])|"         .
                    "7(?:00|1[35]|2[1-36])|8(?:0[01]|7[13]|8[46])|90[024])|"   .
                "2(?:0(?:0[0-8]|1[1246])|1(?:0[0-9]|1[0-35]|20|30|40|50|60|"   .
                    "70|90)|2(?:0[0-9]|10|20|30|40|50|60|70|90)|3(?:0[01]|"    .
                    "10|20|30|40|60|70)|4(?:00|10)|50[0-2]|600|700|800|"       .
                    "9(?:0[1-6]|1[579]|20))|"                                  .
                "3(?:0(?:0[0-9]|1[02-69]|2[0-2]|3[0-2]|6[0-39]|73|8[0-9]|"     .
                    "9[013-589])|1(?:0[0-59]|10|20|40|50|60|70|90)|"           .
                    "2(?:0[0-5]|10|20|30|40|50|60|70|90)|3(?:00|20|40|50|"     .
                    "60|70|80|90)|4(?:00|10|20|40|70|80)|5(?:00|40)|"          .
                    "6(?:0[0-2]|40)|700|8(?:00|1[01])|9(?:4[0-2]|5[01]|60|"    .
                    "7[01]))|"                                                 .
                "4(?:0(?:0[0-9]|1[0-7]|2[0-39]|3[125-9]|4[1-35-9]|5[2-46]|"    .
                    "6[2-4]|7[1-46]|82|9[6-8])|1(?:00|1[0-689]|2[0-39]|"       .
                    "3[0-689]|40|5[0-49]|60|70|8[0-69]|90)|2(?:0[0-69]|"       .
                    "1[01]|20|30|40|50|6[0-3]|7[0-39]|80|90)|3(?:0[0-59]|"     .
                    "1[0-29]|20|30|40|50|60|70|8[05]|90)|4(?:0[0-69]|"         .
                    "1[0-4]|2[05]|30|40|50|60|70|80|90)|5(?:0[0-79]|"          .
                    "1[0-79]|2[0-9]|30|40|50|60|70|80|90)|6(?:0[0-389]|10|"    .
                    "20|30|40|50|60|70|80|90)|7(?:0[0-689]|1[0-69]|20|30|"     .
                    "40|50|60|70|80|90)|8(?:0[0-3]|10|20|30|40|50|60|70|80|"   .
                    "90)|9(?:00|10|20|3[01349]|4[01]|50|60|70|80|90))|"        .
                "5(?:0(?:0[0-35-8]|1[2-5]|2[01])|1(?:0[0-9]|1[0239]|20|30|"    .
                    "40|50|60|70|90)|2(?:0[0-35]|10|2[01]|30|40|50|60|"        .
                    "7[01]|90)|3(?:00|10|20)|4(?:00|30)|500|600|700|8(?:00|"   .
                    "40))|"                                                    .
                "6(?:0(?:0[0-9]|1[06-9]|2[09]|3[46-9])|1(?:0[0-9]|10|20|30|"   .
                    "40|50|60|7[0-589]|90)|2(?:0[01479]|19|20|3[019]|40|50|"   .
                    "60|7[0-79]|90)|3(?:0[0-9]|1[0-279]|2[0-9]|30|4[0-39]|"    .
                    "50|60|70|8[0-3]|90)|4(?:0[0-79]|1[0139]|20|30|40|50|"     .
                    "60|70|80|90)|5(?:0[0-469]|10|20|3[0-2569]|40|50|60|70|"   .
                    "80|90)|6(?:0[0-379]|10|20|30|40|50|60|70|80|90)|"         .
                    "7(?:0[0-59]|30|40|50|60|70|80)|8(?:0[0-59]|40|5[045]|"    .
                    "60|70|80|9[0-369])|9(?:0[0-39]|10|20|30|5[014679]|"       .
                    "7[0379]|98))|"                                            .
                "7(?:0(?:0[03-9]|1[0-9]|2[0138]|3[0-8]|4[014-69]|5[0-4679]|"   .
                    "6[1-3]|7[0-9]|8[1-4])|1(?:0[0-689]|19|2[05-9]|3[0-3]|"    .
                    "4[0146-9]|5[0-579]|6[0-49]|7[05]|8[015]|9[0-39])|"        .
                    "2(?:0[0-9]|1[124-9]|20|3[0-4]|4[05]|5[05]|60|70|"         .
                    "8[0-39]|9[0-29])|3(?:0[0-49]|10|20|30|40|5[0-249]|"       .
                    "6[0-359]|7[0-39]|8[0-35]|90)|4(?:0[0-59]|1[025]|20|30|"   .
                    "4[05]|5[05]|60|70|80|90)|5(?:0[0-9]|1[05]|2[05]|3[05]|"   .
                    "40|50|6[05]|70|80|90)|6(?:0[0-9]|1[09]|20|3[05]|4[05]|"   .
                    "5[05]|60|70|8[05]|90)|7(?:0[0-59]|10|20|3[019]|4[078]|"   .
                    "5[167]|7[02478]|80|90)|8(?:0[013-59]|1[05]|20|30|40|"     .
                    "5[05]|6[05]|70|80|90)|9(?:05|1[0-3569]|2[05]|3[05]|40|"   .
                    "5[0-57-9]|60|7[0-489]|80|90))|"                           .
                "8(?:0(?:0[0-9]|1[3-9]|2[02-9]|3[3469])|1(?:10|20|30|40|50|"   .
                    "60|70|80|90)|2(?:0[0-9]|10|20|30|40|50|60|70|90)|"        .
                    "3(?:0[0-2]|10|20|30|40|50|60|70|80|90)|4(?:0[0-5]|10|"    .
                    "20|30|40|50|60|70|90)|5(?:0[0-38]|30)|6(?:00|4[0-39]|"    .
                    "60)|700|800)|"                                            .
                "9(?:0(?:0[0-9]|1[0-9]|2[0-9]|3[0-9]|4[0-9]|5[1-9]|"           .
                    "6[0-3569]|7[0-489]|8[0-46-8]|9[127])|1(?:0[08]|1[0-9]|"   .
                    "2[0-9]|3[0-9]|4[0-9]|5[0-9]|6[0-9]|7[0-9]|8[0-24-9]|"     .
                    "9[0-589])|2(?:0[0237-9]|1[0-9]|2[0-79]|3[0-9]|4[0-79]|"   .
                    "5[0-589]|6[0-9]|7[0-57-9]|8[0-8]|9[02-79])|3(?:0[0-9]|"   .
                    "1[0-9]|2[0-2689]|3[0-9]|4[1569]|5[0189]|6[0-5]|"          .
                    "7[03-9]|8[0-3569]|9[0-39])|4(?:0[0-9]|1[0-369]|"          .
                    "2[0-24-9]|3[0-35-7]|4[0-9]|5[0-35-8]|6[0-8]|7[0-689]|"    .
                    "8[0-35-7]|9[0-7])|5(?:0[0-9]|10|2[02-49]|3[0-25-7]|"      .
                    "4[0-4]|5[0-57-9]|6[0-47-9]|7[0-3]|8[0-46-9]|90)|"         .
                    "6(?:0[0-8]|1[0-38]|20|3[0579]|40|5[0-9]|6[0-79]|"         .
                    "7[0-37]|8[0-35-79]|90)|7(?:0[0-9]|1[0-9]|2[0-367]|"       .
                    "3[0-5]|40|50|60|7[079]|8[0-57-9]|9[0-2])|8(?:00|"         .
                    "1[0-8]|20|3[0-289]|4[057-9]|5[0-39]|6[0-9]|7[0-8]|"       .
                    "8[0-579]|9[0-9])|9(?:00|10|20|3[0-3]|4[0-48]|5[0-2]|"     .
                    "6[0-57]|7[0-2569]|8[014]|9[08])))"                        .
  
           "|6(?:0(?:0(?:0[024-9]|1[0-9]|2[1-9]|3[15])|1(?:0[0-9]|1[0-9]|"     .
                    "2[0-36-9]|3[0-248]|4[019]|5[0357]|6[02]|7[035]|"          .
                    "8[013-5]|90)|2(?:0[0-9]|10|20|30|40|5[0-2]|60|7[01]|"     .
                    "8[01]|9[0-39])|3(?:0[0-9]|1[0-9]|2[0139]|3[02]|40|50|"    .
                    "60|70|80|90)|4(?:0[0-369]|10|20|3[0-7]|40|51|60|7[67]|"   .
                    "80|90)|5(?:0[0134689]|10|20|30|4[0-4]|5[0-2]|60|70|80|"   .
                    "90)|6(?:0[0237-9]|1[0-27-9]|20|3[1-57-9]|4[036-9]|50|"    .
                    "60|7[1247]|80|90)|7(?:00|1[01]|2[1-39]|3[0-24]|"          .
                    "4[0-59]|5[01]|6[125]|7[12679]|90)|8(?:0[0-5]|10|20|"      .
                    "3[1-3]|40|50|60|7[0-2]|80|90)|9(?:0[2389]|1[12]|"         .
                    "2[1-4]|3[0-2]|40|50|60|81))|"                             .
                "1(?:0(?:0[0-9]|1[1-9]|2[1-4]|4[12]|51)|1(?:0[0-79]|10|20|"    .
                    "30|40|50|60|70|90)|2(?:0[0-689]|10|20|30|40|50|60|70|"    .
                    "90)|3(?:0[0-6]|10|20|30|40|50|60|70|80|90)|4(?:00|10|"    .
                    "20|3[08]|4[08]|5[08]|70|90)|5(?:00|50|60|70)|600|"        .
                    "7(?:00|90)|8(?:00|91)|9(?:61|84|9[24]))|"                 .
                "2(?:0(?:0[0-57-9]|1[0-9]|2[0-9]|3[0-46]|5[1-59]|6[0-79]|"     .
                    "7[0-29]|8[019]|9[0-2])|1(?:0[0-9]|1[0-46-9]|2[0-46-9]|"   .
                    "3[0-246-9]|4[0-579]|5[0-35-9]|6[0-24-69]|7[023569]|"      .
                    "8[02579]|9[0-469])|2(?:0[0-79]|1[0-357-9]|2[0-68]|"       .
                    "3[0-2]|4[025-9]|5[0-9]|60|70|80|90)|3(?:0[0-9]|1[01]|"    .
                    "2[0-257]|3[0-6]|40|50|6[01]|70|80|90)|4(?:0[0-8]|"        .
                    "1[0-289]|20|30|40|5[0-39]|60|70|80|90)|5(?:0[0-9]|10|"    .
                    "20|30|40|50|60|7[05]|80|90)|6(?:0[0-4689]|10|20|30|40|"   .
                    "50|60|70|80|90)|7(?:0[0-29]|10|20|30|40|50|60|70|80|"     .
                    "90)|8(?:0[0-69]|10|20|30|40|50|60|70|8[0-29]|90)|"        .
                    "9(?:0[1-9]|10|2[0-39]|30|40|5[0-5]|6[05-9]|7[0-8]|80|"    .
                    "90))|"                                                    .
                "3(?:0(?:0[0-9]|1[0-9]|2[0-489]|3[0-9]|4[02-69]|5[014-8]|"     .
                    "6[34])|1(?:00|1[0-9]|2[02]|30|40|50|60|7[0-578]|90)|"     .
                    "2(?:0[0-6]|10|20|30|40|50|60|70|90)|3(?:0[0-8]|10|20|"    .
                    "30|40|50|60|70|80|90)|4(?:0[0-9]|10|20|30|40|50|60|70|"   .
                    "80|90)|5(?:0[0-6]|10|20|30|40|50|60|70|80|90)|6(?:00|"    .
                    "10|20|30|40|50|60|70|80|90)|7(?:00|10|20|30|40|50|60|"    .
                    "70|80|90)|8(?:0[0-48]|10|20|30|40|50|70|80|90)|9(?:00|"   .
                    "10|20|30|40|5[09]|6[0-9]|7[02]|80|90))|"                  .
                "4(?:0(?:0[0-46-8]|1[0-35-9]|2[0-47-9]|3[0-9]|4[0-46]|"        .
                    "5[0-9]|6[0-24]|7[1589]|8[0-2679]|90)|1(?:0[0-9]|"         .
                    "1[0-356]|2[0-2]|30|4[0-35-8]|50|60|70|8[1-57]|90)|"       .
                    "2(?:0[0-68]|10|20|3[0-8]|40|50|60|70|90)|3(?:0[0-47]|"    .
                    "10|20|30|40|50|60|70|90)|4(?:0[0-4]|10|20|30|40|50|60|"   .
                    "70|80|90)|5(?:0[0-6]|1[01]|20|30|60|70)|6(?:0[0-5]|40|"   .
                    "60|80)|7(?:0[0-5]|80)|8(?:00|11|70)|990)|"                .
                "5(?:0(?:0[0-9]|1[03-8]|2[0-5])|1(?:0[0-8]|1[0-267]|20|30|"    .
                    "40|50|7[01]|90)|2(?:0[0-4]|20|30|40|50|60|70|90)|"        .
                    "3(?:0[0-37-9]|1[0-2]|2[01]|30|50|60|70|80|90)|"           .
                    "4(?:0[0-2]|10|2[019]|30|40|60|90)|5(?:0[0-3]|10|60|"      .
                    "90)|6(?:0[01]|60|70|90)|7(?:0[016]|10)|80[01]|"           .
                    "9(?:0[1-57]|1[124578]|2[01]|30|5[01]))|"                  .
                "6(?:0(?:0[0-6]|1[1-57-9]|2[015-9]|3[0-49]|46|50|70)|"         .
                    "1(?:0[0-3]|1[0-3]|2[0-3]|30|4[0145]|50|6[0-25]|70|80|"    .
                    "90)|2(?:0[0-2]|10|20|30|40|50|60|70|80|90)|3(?:0[0-2]|"   .
                    "10|20|3[01459]|40|50|60|70|80|90)|4(?:0[0-3]|10|"         .
                    "2[0-3]|30|40|50|60|70|80|90)|5(?:0[0-29]|10|30|40|50|"    .
                    "60|70)|6(?:0[0-24-69]|10|20|5[0-29]|6[04]|70|80|90)|"     .
                    "7(?:0[0-4]|20|30|40|5[015]|60)|8(?:00|20|3[0-26]|45|"     .
                    "5[0346]|6[036]|70)|9(?:06|21|3[13]|4[015]|5[019]|"        .
                    "6[0-8]|87))|"                                             .
                "7(?:0(?:0[0-9]|1[0-9]|2[0-9]|3[0-9]|4[3-6]|59|6[01457-9]|"    .
                    "7[013-7]|8[0-9]|9[0-3689])|1(?:0[029]|1[02-8]|2[0-69]|"   .
                    "3[0-378]|4[0-6]|5[0-258]|6[0-35-79]|7[0-3]|90)|"          .
                    "2(?:0[0-79]|1[0-9]|20|3[0-2459]|4[0-39]|50|6[0-29]|70|"   .
                    "80|90)|3(?:0[0-8]|1[0-289]|20|30|40|50|60|70|8[0-2]|"     .
                    "90)|4(?:0[0-57-9]|1[0-2]|20|30|4[01]|5[0-9]|60|70|80|"    .
                    "90)|5(?:0[0-79]|10|2[01]|30|4[0-2]|50|60|70|80|90)|"      .
                    "6(?:0[0-9]|10|20|30|40|50|60|70|80|90)|7(?:0[0-9]|10|"    .
                    "2[0-8]|30|50|60|70|90)|8(?:0[0-479]|10|20|3[1-4689]|"     .
                    "4[0-3]|50|60|70|80|9[12])|9(?:0[05-79]|1[13]|"            .
                    "2[0-35-8]|3[0-3]|4[2-489]|5[2357-9]|6[0-79]|7[024-9]|"    .
                    "8[0-6]|9[09]))|"                                          .
                "8(?:0(?:0[0-9]|1[02-9]|2[0-79]|40|5[0-9]|6[0-9]|7[0-467]|"    .
                    "8[2-6]|9[0-379])|1(?:00|1[068]|2[014-8]|3[0-49]|40|"      .
                    "5[0-39]|60|7[0-3]|80|90)|2(?:00|10|2[01]|30|40|50|"       .
                    "6[0-5]|7[0-4]|80|90)|3(?:0[0-9]|1[0-7]|20|3[0-3]|40|"     .
                    "50|60|70|80|9[0-39])|4(?:00|10|20|40|60|70|80|90)|"       .
                    "5(?:0[0-49]|10|20|30|40|50|60|70|80|90)|6(?:00|10|20|"    .
                    "30|40|50|60|80|90)|7(?:0[0-5]|20|30|40|50|60|70|80|"      .
                    "90)|8(?:0[0-2469]|20|30|40|50|70|90)|9(?:10|2[013579]|"   .
                    "4[13-57-9]|50|6[08]|70|80|90))|"                          .
                "9(?:0(?:0[1-9]|6[124])|1(?:00|1[05]|2[04-69]|3[0-2469]|"      .
                    "4[0-578]|5[0-49]|6[01]|7[0-3]|9[0-259])|2(?:0[0-9]|"      .
                    "1[0-9]|2[05-9]|3[0279]|4[0-7]|5[0-35-9]|6[0-9]|"          .
                    "7[0-2569]|8[0-9]|9[0-4])|3(?:0[0-379]|1[0679]|"           .
                    "2[0-26-9]|3[06-9]|4[0-9]|5[0-9]|6[0-79]|7[0-3679]|"       .
                    "8[0459]|9[0-9])|4(?:0[0-689]|1[0-9]|2[0-9]|3[0-9]|"       .
                    "4[0-9]|5[0-9]|6[013-9]|7[024-9]|8[0-9]|9[0-35])|"         .
                    "5(?:0[0-359]|1[0-9]|20|3[01]|4[0-4]|5[0-3]|6[013-59]|"    .
                    "7[0-4689]|8[0-3]|9[0-5])|6(?:0[0-9]|1[0-3569]|2[0-9]|"    .
                    "3[0-9]|4[0-9]|5[0-9]|6[014579]|7[0-79]|8[024-79]|"        .
                    "9[0-46])|7(?:0[0-29]|14|2[0679]|3[0-25]|4[0-79]|5[15]|"   .
                    "60|7[01]|80|9[0-5])|8(?:0[0-689]|1[1-4679]|2[02-49]|"     .
                    "3[0-36]|4[01]|50|60|70|8[1-39]|9[01])|9(?:0[0-8]|10|"     .
                    "2[1-6]|3[0-9]|4[25-9]|5[1-57]|6[0-489]|70|98)))"          .
  
           "|7(?:0(?:0(?:0[0-7]|1[349]|2[0-2]|30)|1(?:0[0-4]|10|20|30|40|"     .
                    "50|60|70|80|90)|2(?:0[0-4]|10|20|30|40|50|70|80|90)|"     .
                    "3(?:0[0-46]|10|20|60)|4(?:00|40)|500|600|700|80[07])|"    .
                "1(?:0(?:0[0-9]|1[0-27-9]|2[0-9]|31|4[09])|1(?:0[0-9]|"        .
                    "1[08]|20|30|40|50|60|70|90)|2(?:0[0-69]|10|20|30|40|"     .
                    "50|60|70|90)|3(?:0[0-9]|10|2[0-8]|3[0-79]|40|50|60|70|"   .
                    "80|90)|4(?:0[0-57-9]|10|20|30|40|50|60|70|80|90)|"        .
                    "5(?:0[0-39]|10|20|30|40|50|70|80|90)|6(?:0[0-49]|20|"     .
                    "40|70|80)|7(?:00|10|40|60)|8(?:00|50|70|80)|9(?:60|"      .
                    "90))|"                                                    .
                "2(?:0(?:0[0-9]|1[013-689]|2[14-9]|3[02-9]|4[0-57-9]|"         .
                    "5[12589]|7[0-359]|8[0-9]|9[1-356])|1(?:0[09]|10|20|30|"   .
                    "40|50|60|70|90)|2(?:0[0-3568]|10|20|3[0-4679]|40|50|"     .
                    "60|70|90)|3(?:0[0-589]|10|20|30|40|50|60|70|80|90)|"      .
                    "4(?:0[0-79]|30|40|50|60|70)|5(?:00|10|30|40|50|60)|"      .
                    "6(?:00|10|50)|70[02-5]|800|90[28])|"                      .
                "3(?:0(?:0[0-9]|1[014-9]|2[0-24-6]|31|65|7[39]|89|9[14])|"     .
                    "1(?:0[0-9]|10|2[0-479]|30|40|5[0-579]|60|70|9[0-39])|"    .
                    "2(?:0[0-9]|1[0-2469]|2[013-59]|3[0-259]|40|50|"           .
                    "6[01459]|7[067]|9[0-2459])|3(?:0[0-39]|10|2[0-29]|30|"    .
                    "40|50|60|7[0-9]|8[12]|90)|4(?:0[0-39]|10|20|40|50|60|"    .
                    "70|80|9[0-49])|5(?:00|20|30|40|50|7[0-39]|90)|"           .
                    "6(?:0[0-49]|10|20|30|40|60|70)|7(?:0[0-589]|10|20|30|"    .
                    "90)|8(?:0[0-24-9]|70))|"                                  .
                "4(?:0(?:0[0-9]|1[0-6]|2[0145]|3[46]|4[01]|5[459])|"           .
                    "1(?:0[0-9]|1[0-3]|20|3[0-79]|40|5[0-9]|6[0-69]|70|90)|"   .
                    "2(?:0[0-9]|10|20|30|40|50|60|70|90)|3(?:0[0-57-9]|"       .
                    "1[014]|20|3[0-47-9]|40|50|60|7[0-4]|80|90)|"              .
                    "4(?:0[0-59]|10|20|30|40|50|60|70|80|90)|5(?:0[0-39]|"     .
                    "20|40|50|60|70|80)|6(?:0[0-79]|50|60)|7(?:0[0-469]|"      .
                    "40)|8(?:0[0-9]|90)|9(?:10|20|30|4[0-69]|5[0-4]|"          .
                    "6[0-469]|70|8[124-9]|9[013-9]))|"                         .
                "5(?:0(?:0[0-9]|1[0-9]|2[0134689]|3[0-689]|4[0-9]|5[1-689]|"   .
                    "6[0-9]|7[2-9]|8[0-9]|9[02-7])|1(?:0[0-9]|1[0-689]|"       .
                    "2[02-9]|3[01489]|4[0-24]|5[0-9]|6[1-9]|7[0-24679]|"       .
                    "8[0-24689]|9[124-8])|2(?:0[1-9]|1[0-9]|2[0-46-9]|"        .
                    "3[0-9]|4[01348]|5[0236]|6[0-69]|7[02589]|8[0-48]|"        .
                    "9[0-24589])|3(?:0[2-9]|1[0-57-9]|2[0-9]|3[0357-9]|"       .
                    "4[0-589]|5[0235-9]|6[0-7]|7[0-689]|8[0-9]|9[0-24-9])|"    .
                    "4(?:0[0-35-8]|1[0-35-9]|2[0-9]|3[0-24-9]|4[0-79]|"        .
                    "5[0-9]|6[02-8]|7[0-9]|8[0-8]|9[0-35-9])|5(?:0[2-9]|"      .
                    "1[0-2]|2[1-8]|3[3-8]|4[0-8]|5[0-8]|6[0-9]|7[0-9]|"        .
                    "8[0-9]|9[1-9])|6(?:0[0-9]|1[0-46-9]|2[0-9]|3[0-9]|"       .
                    "4[0-46-9]|5[0-9]|6[0-57-9]|7[013-57-9]|8[0-357-9]|"       .
                    "9[0-46-9])|7(?:0[0-35-9]|1[02-9]|2[0-79]|3[0-247-9]|"     .
                    "4[0-357-9]|5[03-79]|6[1-9]|7[0-358]|8[0-69]|9[04689])|"   .
                    "8(?:0[02-9]|1[2357-9]|2[0-9]|3[0-9]|4[013-9]|5[0-578]|"   .
                    "6[0-9]|7[0-24-9]|8[0-79]|9[0-57-9])|9(?:0[0-57-9]|"       .
                    "1[13-9]|2[0-9]|3[0-9]|4[0-9]|5[0-9]|6[0-25-79]|7[0-9]|"   .
                    "8[013-9]|9[013-8]))|"                                     .
                "6(?:0(?:0[0-8]|1[127-9]|2[0-24-689]|3[0-35-9]|4[0-79]|"       .
                    "5[0-9]|6[0-9]|7[0-249]|8[03-7]|9[2-9])|1(?:0[017-9]|"     .
                    "1[013679]|2[0-579]|3[0-9]|4[0-4]|5[0-359]|6[014]|"        .
                    "7[0-9]|8[135-9]|9[0-7])|2(?:0[0-9]|10|20|3[0-35-9]|40|"   .
                    "50|60|70|80|90)|3(?:0[0-68]|10|20|30|40|50|60|7[09]|"     .
                    "80|90)|4(?:0[0-59]|1[089]|20|30|40|50|60|70|80|90)|"      .
                    "5(?:0[0-49]|10|20|30|40|50|60|70|80|90)|6(?:00|10|20|"    .
                    "30|40|50|60|80|90)|7(?:00|10|2[013]|30|40|50|60|70|80|"   .
                    "90)|8(?:0[0-9]|10|2[13-5]|40|50|60|70|8[0-57]|90)|"       .
                    "9(?:0[02]|1[0457]|2[05-79]|3[045]|4[05]|50|60|70|80))|"   .
                "7(?:0(?:0[0-9]|1[0-9]|2[013-8]|39|4[0-3]|5[0-2]|90)|"         .
                    "1(?:0[0-9]|1[0-58]|2[02-467]|3[013-589]|4[01458]|"        .
                    "5[0147]|6[03-79]|7[01346-8]|8[13-7]|9[0-9])|"             .
                    "2(?:0[0-9]|1[0-9]|2[0-59]|3[0-249]|4[0-36-9]|5[0-579]|"   .
                    "6[0-46]|7[0-2]|8[0-2]|9[0-9])|3(?:0[0-57-9]|1[0-689]|"    .
                    "2[07]|3[0-57]|4[0-46-9]|5[0-3]|60|70|8[0-24589]|90)|"     .
                    "4(?:0[0-579]|1[0-79]|2[0-79]|3[0-79]|4[0-8]|5[0-58]|"     .
                    "6[02-57-9]|70|8[0-46-9])|5(?:0[0-9]|1[05]|2[0-9]|"        .
                    "4[0-9]|5[0-9]|6[0-9]|70|8[0-35]|90)|6(?:0[0-9]|"          .
                    "1[0-24-7]|20|30|4[01569]|50|60|70|80|90)|7(?:0[0-689]|"   .
                    "1[014-7]|2[0-3]|30|50|60|7[126-9]|80|9[1-689])|"          .
                    "8(?:1[013-9]|20|3[0-57-9]|40|50|60|7[0-3569]|80|90)|"     .
                    "9(?:10|2[03]|3[0-39]|40|5[01]|61|70|8[1-369]|90))|"       .
                "8(?:0(?:0[0-9]|1[0-57-9]|2[0-246-9]|3[02-5]|4[1-9]|"          .
                    "5[1-79]|6[0-24-7]|7[189]|8[1-9]|9[1-69])|"                .
                    "1(?:0[0-24-689]|1[0-9]|2[0-24-69]|3[0-59]|4[0-35-9]|"     .
                    "5[0-57-9]|6[02-79]|7[0-479]|8[0-689]|9[0-9])|"            .
                    "2(?:0[0-9]|1[0249]|2[0-39]|3[0-49]|4[0-49]|50|60|70|"     .
                    "8[0-9]|9[0-49])|3(?:0[0-46-9]|1[0-79]|2[0-2]|3[019]|"     .
                    "4[0-24-69]|5[0-69]|6[0-48]|7[0-9]|80|9[015])|"            .
                    "4(?:0[0-49]|1[0-35-79]|2[0-49]|3[019]|40|5[0178]|60|"     .
                    "7[0-29]|80|90)|5(?:0[0-79]|1[0-59]|20|3[0-69]|40|50|"     .
                    "60|70|80|9[0-29])|6(?:0[0-69]|1[029]|20|30|40|50|60|"     .
                    "70|80|90)|7(?:0[0-359]|1[0-58]|20|30|40|50|60|7[0189]|"   .
                    "80|90)|8(?:0[0-69]|10|20|30|40|5[0-249]|60|70|8[1-6]|"    .
                    "9[07])|9(?:1[05]|2[0-9]|3[01]|4[0-689]|5[05]|60|70|80|"   .
                    "9[05-7]))|"                                               .
                "9(?:0(?:0[0-9]|1[0-8]|2[1-9]|3[0-9]|4[1-69]|5[0-69]|"         .
                    "6[0189]|7[0-79]|8[0-8]|9[1-389])|1(?:0[0-69]|10|20|30|"   .
                    "4[0-5]|50|60|70|8[0-2459]|90)|2(?:0[0-689]|10|20|"        .
                    "3[0-4]|40|50|60|70|90)|3(?:0[0-9]|10|20|30|40|50|60|"     .
                    "70|80|90)|4(?:0[0-49]|10|20|30|40|50|60)|5(?:00|10)|"     .
                    "600|700|800|9(?:39|5[03])))"                              .
  
           "|8(?:0(?:0(?:0[0-9]|1[0-79]|2[0-35-9]|3[0-46-9]|4[0-46-9]|"        .
                    "5[014-7]|6[0-489]|75|8[0-9]|9[0-79])|1(?:0[0-9]|"         .
                    "1[058]|2[02]|3[0-24-6]|4[02-6]|50|60|70|90)|"             .
                    "2(?:0[0-689]|10|20|30|40|50|60|70|90)|3(?:0[0-39]|10|"    .
                    "20|3[0-69]|40|50|60|70|90)|4(?:00|10|20|30|40|50|60|"     .
                    "70|80|90)|5(?:00|10|20|3[1-59]|40|50|60|70|80)|6(?:00|"   .
                    "10|20|30|40|50|70|80|90)|7(?:00|10|40|50|70|80)|"         .
                    "8(?:00|20|30|50|60|70|80|9[01])|9(?:1[09]|60|70|80))|"    .
                "1(?:0(?:0[0-7]|1[1-9]|2[0-35-8]|3[014-9]|90)|1(?:0[0-9]|"     .
                    "1[056]|20|30|40|50|60|70|90)|2(?:0[0-9]|1[05]|20|30|"     .
                    "40|50|60|70|90)|3(?:0[0-5]|10|20|30|40|50|60|70|80|"      .
                    "90)|4(?:00|30|40|50|70|90)|5(?:0[0-369]|30|40|70|80)|"    .
                    "6(?:0[0-59]|30|40|60)|7(?:00|10)|800|990)|"               .
                "2(?:0(?:0[0-689]|1[3-579]|2[47]|3[0237]|4[078]|5[347]|"       .
                    "6[057]|7[07]|8[07])|1(?:0[0-49]|10|20|30|40|50|60|70|"    .
                    "90)|2(?:0[0-28]|10|20|30|40|50|70|90)|3(?:0[0-3]|30|"     .
                    "40|50|60|70|90)|4(?:0[0-3]|10|40)|500|600|7(?:00|10)|"    .
                    "800)|"                                                    .
                "3(?:0(?:0[0-8]|1[2-69]|3[068]|4[0-289]|5[0-9]|6[0-59]|"       .
                    "7[016-9]|8[0-9]|9[0-57-9])|1(?:0[078]|1[019]|20|"         .
                    "3[016]|4[039]|50|6[0-467]|7[0-79]|8[013-57-9]|"           .
                    "9[0-269])|2(?:00|10|20|3[016-8]|40|50|60|70)|3(?:00|"     .
                    "1[0-7]|20|30|40|50|7[0-29]|80|90)|4(?:0[0-9]|1[128]|"     .
                    "20|30|40|60|70|8[0-9]|90)|5(?:0[0-479]|1[0-248]|20|30|"   .
                    "50|60|70|80|90)|6(?:0[0-4689]|1[03-68]|30|40|60|70|80|"   .
                    "90)|7(?:0[0-57]|20|40|80|90)|8(?:00|20|30|40|60|70|"      .
                    "90)|9(?:10|20|5[1-47]|80|9[0-8]))|"                       .
                "4(?:0(?:0[04-9]|1[013-689]|2[1-579]|3[1-6]|4[1-9]|"           .
                    "5[014689]|7[1278]|8[1-5]|9[0-9])|1(?:0[0-9]|10|2[0-4]|"   .
                    "3[0-59]|4[0-479]|50|60|70|90)|2(?:0[0-9]|10|20|3[0-2]|"   .
                    "40|50|60|7[0-9]|90)|3(?:0[0-9]|10|20|30|40|50|60|70|"     .
                    "80|90)|4(?:0[0-5]|10|20|30|40|50|60|70|80|90)|"           .
                    "5(?:0[0-57]|10|30|50|60|70|80)|6(?:0[0-39]|60)|"          .
                    "7(?:0[0-6]|40|50|60)|8(?:0[0-58]|10|20|30|40|50|60|"      .
                    "7[0-48])|9(?:0[1259]|1[1-9]|5[1-46]|6[13-57-9]|"          .
                    "7[1-367]))|"                                              .
                "5(?:0(?:0[0-9]|1[0235-9]|2[01346]|3[356])|1(?:0[0-9]|"        .
                    "1[013489]|20|3[0-39]|40|50|6[0-579]|70|80|90)|"           .
                    "2(?:0[0-689]|10|20|30|40|50|60|70|80|9[0-29])|"           .
                    "3(?:0[0-79]|10|20|30|4[0-2]|50|60|70|90)|"                .
                    "4(?:0[0-4679]|10|20|30|40|50|60|70|80|90)|5(?:0[0-69]|"   .
                    "10|20|30|40|50|60|70|80|90)|6(?:0[0-479]|1[02-6]|20|"     .
                    "30|40|60|70|80|90)|7(?:0[0237-9]|10|40|50|70)|"           .
                    "80[03-69]|9(?:19|2[1-8]|3[0-4]))|"                        .
                "6(?:0(?:0[0-9]|1[0-3]|2[0-39]|3[04-68]|4[2-7]|5[0-6]|"        .
                    "6[0-35-9]|7[1-46]|8[0-9]|9[0-8])|1(?:0[0-9]|1[07]|20|"    .
                    "3[0-57-9]|40|50|60|70|80|90)|2(?:0[0-2469]|10|20|30|"     .
                    "40|50|60|70|8[0-29]|90)|3(?:00|10|20|30|40|50|6[0-29]|"   .
                    "70|80|90)|4(?:00|10|20|30|40|50|60|70|80|90)|"            .
                    "5(?:0[0-289]|10|30|40|50|80)|6(?:00|10)|700|800|"         .
                    "9(?:05|10|6[0-49]|8[0-4]))|"                              .
                "7(?:0(?:0[0-9]|1[0-35-8]|2[0-356]|3[0-46-9]|4[0-9]|"          .
                    "5[0-589]|6[015-9]|7[013-9]|8[0-59]|90)|1(?:00|10|20|"     .
                    "30|40|50|60|70|90)|2(?:0[0-356]|10|2[0-3]|30|40|50|60|"   .
                    "70|80|90)|3(?:00|10|20|30|40|50|60|70|80)|4(?:00|10|"     .
                    "20|30|40|60|70|80)|5(?:00|10|20|70|90)|6(?:00|20|40)|"    .
                    "7(?:00|20)|8(?:00|90)|9(?:00|19|20|30|50))|"              .
                "8(?:0(?:0[0-9]|1[0-8]|2[015-79]|33|5[01]|60|8[4-689]|99)|"    .
                    "1(?:0[0-9]|10|2[0-3579]|3[0-39]|4[0-39]|5[0-6]|"          .
                    "6[0-259]|70|87|9[0-589])|2(?:0[0-79]|1[0-4]|20|30|40|"    .
                    "50|60|70|90)|3(?:0[0-7]|10|20|30|40|50|60|70|80|90)|"     .
                    "4(?:0[0-35-9]|10|20|30|40|50|60|70|80|90)|"               .
                    "5(?:0[0-479]|10|20|30|40|50|60|80)|6(?:00|30|40|50)|"     .
                    "700|80[0-59])|"                                           .
                "9(?:0(?:0[0-79]|1[0-2569]|2[0-9]|30|89|9[0-59])|"             .
                    "1(?:0[0-9]|1[036]|20|30|4[04]|50|60|70|90)|"              .
                    "2(?:0[0-79]|10|20|30|40|50|60|70|90)|3(?:0[0-79]|10|"     .
                    "20|3[01]|40|50|60|80|90)|4(?:00|10|20|30|40|50|60|70|"    .
                    "80)|5(?:00|1[05]|2[05]|30|50|60|70|80)|6(?:00|30|60|"     .
                    "90)|7(?:00|10|40|7[0-2])|800))"                           .
  
           "|9(?:0(?:0(?:0[0-9]|1[0-689]|2[0-35]|40)|1(?:0[01]|10|20|30|40|"   .
                    "50|60|70)|200|3(?:00|30|40|50|60|70|80)|400|500|600|"     .
                    "700|8(?:00|50))|"                                         .
                "1(?:0(?:0[0-9]|1[0-9]|2[0-9]|3[0-9]|4[0-9]|5[0-9]|"           .
                    "7[0-247-9]|80|9[07])|1(?:0[0-9]|2[0-9]|3[0-35-7]|"        .
                    "4[0-269]|5[0-46-9]|6[0-9]|7[0-47-9]|80|9[0-9])|"          .
                    "2(?:0[014579]|1[0134]|2[0-9]|30|4[01]|50|6[0-35-9]|70|"   .
                    "80|9[0-24-9])|3(?:0[0-9]|1[0-245]|2[0-589]|3[0-59]|"      .
                    "4[0-9]|5[013-59]|60|7[014]|8[0-9]|90)|4(?:0[0-79]|"       .
                    "1[024-8]|2[0-9]|30|40|50|6[0-3]|70|80|90)|5(?:10|20|"     .
                    "30|4[0-29]|5[01]|60|7[0-489]|80|90)|6(?:0[0-359]|"        .
                    "1[0239]|2[05]|30|40|50|60|70|80|9[0-9])|7(?:0[0-9]|"      .
                    "1[0-3]|20|30|4[0-9]|50|6[0-47]|70|8[013]|9[0-2])|"        .
                    "8(?:0[0-79]|1[0-5]|2[01]|30|4[019]|5[0-25]|6[01]|"        .
                    "7[0-9]|8[0-79]|9[0-689])|9(?:1[0-79]|2[1-4]|30|4[0-9]|"   .
                    "5[1-9]|6[1-9]|7[1-9]|8[1-68]))|"                          .
                "2(?:0(?:0[0-9]|1[0-9]|2[0-9]|3[3-9]|4[0-9]|5[0-9]|"           .
                    "6[013-9]|7[0-9]|8[1-9]|9[235-9])|1(?:0[0-689]|1[0-9]|"    .
                    "2[0-9]|3[0-9]|4[0-9]|5[0-9]|6[0-9]|7[0-9]|8[1-689]|"      .
                    "9[013-69])|2(?:0[0-689]|1[0-69]|2[0-9]|3[0-57-9]|"        .
                    "4[0-79]|5[0-46-9]|6[0-369]|7[0-59]|8[0-246-8]|"           .
                    "9[0-35-8])|3(?:0[0-9]|1[0-46-9]|2[0-9]|3[0-379]|"         .
                    "4[0-2]|5[0-79]|6[0-69]|7[029]|8[08]|9[0-9])|"             .
                    "4(?:0[0-9]|1[0-9]|2[03]|3[08]|4[1-578]|54|99)|"           .
                    "5(?:0[0-9]|1[1346-9]|2[1-57-9]|3[1-8]|4[1-6]|5[235]|"     .
                    "6[1-79]|7[13-8]|8[1-8]|9[1-9])|6(?:0[0-79]|1[13-6]|"      .
                    "2[24]|3[1-8]|4[1-359]|5[013-689]|6[05]|7[12579]|"         .
                    "8[2-689]|9[1358])|7(?:0[0-9]|1[1-5]|2[125-9]|3[05-9]|"    .
                    "4[1-578]|5[12568]|6[1-46-8]|7[2-469]|8[1-9]|9[1-9])|"     .
                    "8(?:0[0-9]|1[135-9]|2[0-4]|4[2-8]|5[1-69]|6[1-7]|"        .
                    "8[1-79]|9[1-8])|9(?:0[1-46-9]|1[1-9]|2[0-9]|3[0-9]|59|"   .
                    "7[0-57-9]|8[013-9]|99))|"                                 .
                "3(?:0(?:0[0-35-9]|1[1-46-8]|2[124])|1(?:0[0-8]|1[0-24-8]|"    .
                    "2[0-367]|3[013-6]|4[0-9]|5[0-8]|6[0-9]|7[0-24-7]|"        .
                    "8[1-46-9]|9[0-79])|2(?:0[0-9]|1[0-46-9]|2[0-2]|"          .
                    "3[0135]|4[015]|50|6[01]|7[0145]|8[2-6]|9[047])|"          .
                    "3(?:0[0-8]|1[015]|2[0-5]|3[0-24-7]|4[0-689]|5[0-2]|"      .
                    "6[0-6]|70|8[0-2]|90)|4(?:0[0-8]|1[0-2]|2[0-4]|3[0167]|"   .
                    "4[01]|5[013-8]|6[0-5]|7[0239]|8[1-79]|93)|5(?:0[0-8]|"    .
                    "1[1-7]|2[1-46-8]|3[1-9]|4[1457]|5[4-68]|6[1-4]|"          .
                    "7[14-8]|8[1-9]|9[13])|6(?:0[0-689]|1[1-9]|2[1-37]|31|"    .
                    "9[1-9])|7(?:0[015]|1[129]|3[1346-8]|61)|8(?:0[0-267]|"    .
                    "1[2-6]|8[13-57]|9[19])|90[17-9])|"                        .
                "4(?:0(?:0[0-9]|1[0-9]|2[0-9]|3[0-9]|4[0-9]|5[1-5]|94)|"       .
                    "1(?:0[0-9]|1[0-9]|2[0-9]|3[0-9]|4[0-9]|5[0-9]|6[0-69]|"   .
                    "7[0-5]|9[0-79])|2(?:0[0-9]|1[0149]|2[0-9]|3[0-9]|"        .
                    "4[0-4679]|5[0-9]|6[0-9]|7[0-9]|81|90)|3(?:0[0-9]|"        .
                    "1[0-29]|2[0-247]|4[0-59]|5[013-79]|6[0-689]|7[0-9]|"      .
                    "8[0-9]|9[0-689])|4(?:0[0-9]|1[0-579]|20|3[0-9]|40|"       .
                    "5[0-79]|60|7[0-9]|80|90)|5(?:0[0-9]|1[0-9]|2[0-8]|"       .
                    "3[1-9]|4[1-46-9]|5[0-3]|6[1-9]|7[1-9]|8[1-9]|9[1-9])|"    .
                    "6(?:0[0-4679]|1[1-46-9]|2[1-36-8]|3[1-9]|4[1-578]|"       .
                    "5[1346-9]|6[13479]|7[1-9]|8[1-8])|7(?:0[0-4679]|"         .
                    "1[0-59]|2[1-9]|3[1-9]|4[1-589]|6[1-8]|8[1-59])|"          .
                    "8(?:0[0-9]|1[1-9]|3[1-39]|5[1-9]|6[1-79]|80|9[1-4])|"     .
                    "9(?:4[125-9]|5[1-689]|6[1-68]|7[1-8]))|"                  .
                "5(?:0(?:0[0-8]|1[0-9]|2[0-57-9]|3[0-8]|4[0-26]|5[0-69]|"      .
                    "6[0-79]|7[0-9]|9[0-8])|1(?:0[0-9]|1[0-27-9]|2[0-79]|"     .
                    "3[0-579]|4[0-6]|5[0-57-9]|6[0-259]|70|80|9[0-9])|"        .
                    "2(?:0[0-79]|1[0-9]|2[0-4689]|3[0-49]|40|5[0-29]|60|70|"   .
                    "80|90)|3(?:0[0-469]|1[0-689]|2[0-489]|3[0-5]|40|"         .
                    "5[015]|60|7[09]|80|90)|4(?:00|1[0-29]|20|30|4[015]|50|"   .
                    "6[01]|7[0-9]|80|90)|5(?:0[0-9]|10|2[0-9]|30|40|5[019]|"   .
                    "60|7[013]|80|90)|6(?:0[0-59]|1[0-9]|20|30|40|5[0-29]|"    .
                    "60|70|80|9[0-367])|7(?:0[0-9]|1[0-3569]|2[0-7]|3[1-4]|"   .
                    "4[0-27]|50|6[019]|70|80)|8(?:0[0-9]|1[0-6]|20|30|"        .
                    "4[02-4]|50|6[1-68]|7[0-79]|80|9[127])|9(?:0[12578]|"      .
                    "1[1-3569]|2[0-8]|3[0-4]|4[0-9]|5[0-46-9]|7[0-8]))|"       .
                "8799)"                                                        .
      ")",
  
  
      #
      # 5 Digit postal code, with leading 0s.
      #
      # Data from: http://download.geonames.org/export/zip/DE.zip
      # 
      Germany     =>
        "(?k:0(?:1(?:0(?:6[79]|9[79])|1(?:0[89]|2[79]|39|5[679]|69|8[79])|"    .
                    "2(?:1[79]|3[79]|5[79]|7[79])|3(?:0[79]|14|2[468])|"       .
                    "4(?:45|5[48]|6[258]|7[178])|5(?:58|61|8[79]|9[14])|"      .
                    "6(?:09|1[269]|23|40|6[25]|8[39])|7(?:05|2[38]|3[1478]|"   .
                    "44|6[28]|7[3468]|96)|8(?:09|1[469]|2[459]|33|4[478]|"     .
                    "55|77|96)|9(?:0[0469]|17|20|36|45|68|79|8[37]|"           .
                    "9[03468]))|"                                              .
                "2(?:6(?:2[57]|33|4[03]|8[19]|9[249])|7(?:08|27|3[0369]|"      .
                    "4[278]|63|79|8[258]|9[14679])|8(?:2[6-9]|9[49])|"         .
                    "9(?:06|2[39]|43|5[3679]|7[79]|9[1479]))|"                 .
                "3(?:0(?:4[2468]|5[0-58]|9[69])|1(?:03|1[69]|3[09]|49|59|"     .
                    "72|85|97)|2(?:0[25]|2[269]|38|4[69]|53))|"                .
                "4(?:1(?:0[3579]|29|5[57-9]|7[7-9])|2(?:0[579]|29|49|"         .
                    "7[579]|8[89]|99)|3(?:1[5-9]|2[89]|4[79]|5[67])|4(?:16|"   .
                    "2[05]|35|42|51|6[03])|5(?:09|19|23|39|52|6[457]|"         .
                    "7[1459])|6(?:0[03]|1[0378]|26|39|43|5[1457]|68|"          .
                    "8[03578])|7(?:03|20|36|4[169]|58|69|7[49])|8(?:08|"       .
                    "2[1478]|38|49|6[02]|74|8[069]|95)|9(?:1[06]|2[48]|"       .
                    "3[12468]))|"                                              .
                "6(?:1(?:08|1[02468]|2[02468]|3[02]|79|8[48]|9[38])|2(?:17|"   .
                    "3[17]|4[269]|5[4589]|68|79|95)|3(?:08|1[1378]|33|"        .
                    "4[378]|6[69]|8[568])|4(?:0[68]|2[059]|49|5[68]|"          .
                    "6[34679]|84|93)|5(?:0[27]|2[68]|3[67]|4[2378]|56|67|"     .
                    "7[178])|6(?:18|28|3[268]|4[278]|67|79|8[268])|7(?:12|"    .
                    "2[124579]|31|49|66|7[349]|8[056]|9[1246])|"               .
                    "8(?:0[03489]|4[24679]|6[129]|8[689]|9[56])|9(?:0[159]|"   .
                    "1[78]|2[2568]))|"                                         .
                "7(?:3(?:18|3[03468]|4[39]|56|6[68]|8[179])|4(?:07|"           .
                    "2[2679])|5(?:4[5689]|5[1247]|70|8[069])|6(?:07|1[369]|"   .
                    "29|39|46)|7(?:4[3579]|51|68|7[48])|8(?:06|19)|9(?:07|"    .
                    "19|2[24679]|37|5[02578]|73|8[0579]))|"                    .
                "8(?:0(?:5[68]|6[0246])|1(?:07|1[258]|3[24]|4[147])|2(?:09|"   .
                    "2[38]|3[3679]|48|58|6[12579]|8[09]|9[47])|3(?:0[149]|"    .
                    "1[258]|2[14-68]|4[049]|5[259]|7[13]|9[36])|4(?:12|"       .
                    "2[78]|3[29]|5[19]|68|85|9[169])|5(?:2[3579]|3[89]|"       .
                    "4[1378])|6(?:06|26|4[58]))|"                              .
                "9(?:0(?:28|30)|1(?:1[1-4679]|2[0235-8]|3[01])|2(?:1[27]|"     .
                    "2[1478]|3[256]|4[1349])|3(?:06|2[268]|37|5[0356]|66|"     .
                    "76|8[057]|9[02459])|4(?:05|19|2[379]|3[02579]|56|"        .
                    "6[58]|7[147]|8[1478]|96)|5(?:09|1[478]|26|4[48]|57|69|"   .
                    "7[3579]|99)|6(?:0[03]|1[89]|2[379]|3[348]|48|6[19])))"    .
  
           "|1(?:0(?:1(?:1[579]|7[89])|24[3579]|3(?:1[57-9]|6[579])|"          .
                    "4(?:0[579]|3[579])|5(?:5[13579]|8[579])|62[3579]|"        .
                    "7(?:0[79]|1[13579]|7[79]|8[13579])|82[3579]|"             .
                    "9(?:6[13579]|9[79]))|"                                    .
                "1011|2(?:0(?:4[3579]|5[13579]|99)|1(?:0[13579]|5[79]|"        .
                    "6[13579])|2(?:0[3579]|4[79]|7[79])|3(?:0[579]|4[79]|"     .
                    "5[13579])|4(?:3[579]|59|8[79])|5(?:2[4679]|5[579]|"       .
                    "8[79])|6(?:19|2[1379]|79|8[13579]))|"                     .
                "3(?:0(?:47|5[13579]|8[689])|1(?:2[579]|5[689]|8[79])|"        .
                    "3(?:4[79]|5[13579])|4(?:0[3579]|3[579]|6[579])|"          .
                    "5(?:0[3579]|8[13579]|9[13579])|62[79])|"                  .
                "4(?:0(?:5[023579]|89)|1(?:09|29|31|6[3579]|9[3579])|"         .
                    "4(?:6[179]|7[1368]|8[02])|5(?:13|32|4[278]|5[02478])|"    .
                    "6(?:12|2[147]|41|56|6[29])|7(?:1[25]|2[78]|7[02468]|"     .
                    "89|9[378])|8(?:06|2[2378])|9(?:13|29|4[37]|59|7[49]))|"   .
                "5(?:2(?:3[0246]|9[59])|3(?:06|2[0468]|4[45]|66|7[02478])|"    .
                    "5(?:1[78]|2[68]|37|6[269])|7(?:11|3[28]|4[15689]|"        .
                    "5[124578])|8(?:06|27|3[1478]|48|59|6[48]|9[08])|"         .
                    "9(?:07|1[03]|26|3[68]))|"                                 .
                "6(?:2(?:2[57]|30|4[478]|59|69|78)|3(?:0[367]|21|4[18]|"       .
                    "5[269])|5(?:15|4[078]|5[269]|6[257])|7(?:27|6[167]|75|"   .
                    "9[28])|8(?:1[68]|27|3[1357]|45|6[68])|9(?:09|18|2[18]|"   .
                    "4[59]))|"                                                 .
                "7(?:0(?:3[3469]|8[79]|9[1489])|1(?:09|11|2[169]|39|5[349]|"   .
                    "6[68]|79|9[24])|2(?:0[79]|1[3479]|3[57]|48|5[2589]|68|"   .
                    "79|91)|3(?:09|2[12689]|3[57]|4[89]|58|67|7[359]|89|"      .
                    "9[0-28])|4(?:06|19|2[49]|38|4[09]|5[49]|89|9[1358])|"     .
                    "50[69])|"                                                 .
                "8(?:0(?:5[579]|69)|1(?:0[679]|19|4[67]|8[124]|9[0568])|"      .
                    "2(?:09|11|25|3[01369]|4[69]|58|7[369]|9[29])|"            .
                    "3(?:1[147]|20|3[47]|47|56|7[45])|4(?:3[579]|4[25]|"       .
                    "6[159])|5(?:07|1[0369]|28|46|5[16]|6[59]|7[34]|8[16])|"   .
                    "609)|"                                                    .
                "9(?:0(?:5[3579]|6[13579]|7[13579]|8[69])|2(?:0[59]|17|30|"    .
                    "4[369]|58|60|73|88|94)|3(?:0[0369]|22|3[69]|48|57|"       .
                    "7[0246]|86|9[59])|4(?:06|1[27])))"                        .
  
           "|2(?:0(?:0(?:38|88|9[579])|14[4689]|2(?:49|5[13579])|35[04579]|"   .
                    "45[79]|53[579])|"                                         .
                "1(?:0(?:29|3[13579]|7[3579])|1(?:0[79]|29|4[79])|"            .
                    "2(?:1[78]|2[0478]|44|5[5689]|6[16]|7[1249])|"             .
                    "3(?:3[579]|5[478]|6[0589]|7[169]|8[02568]|9[14578])|"     .
                    "4(?:0[013679]|23|3[5689]|4[124579]|65|8[13]|93)|"         .
                    "5(?:0[29]|1[46]|2[124679])|6(?:14|29|35|4[0134679]|"      .
                    "8[02-4]|98)|7(?:0[269]|1[0247]|2[03679]|3[02479]|45|"     .
                    "5[56]|6[2359]|7[0256]|8[124579]))|"                       .
                "2(?:0(?:4[13579]|8[13579])|1(?:1[13579]|4[3579]|59|"          .
                    "7[579])|29[79]|3(?:0[13579]|3[579]|59|9[13579])|"         .
                    "4(?:1[579]|5[3579])|5(?:2[3579]|4[79]|59|8[79])|"         .
                    "60[579]|76[13579]|8(?:4[468]|5[01]|69|8[059])|"           .
                    "9(?:2[679]|4[169]|5[25689]|6[24579]))|"                   .
                "3(?:5(?:39|5[2468]|6[024689]|70)|6(?:1[179]|2[36-9]|69|"      .
                    "8[349])|7(?:01|1[4579]|3[08]|4[34679]|58|69|7[4579]|"     .
                    "95)|8(?:1[23568]|2[0134679]|4[357]|58|6[03679]|79|"       .
                    "8[13]|9[689])|9(?:09|1[19]|23|36|4[2468]|52|6[68]|"       .
                    "7[024]|9[269]))|"                                         .
                "4(?:1(?:0[35-79]|1[134689]|4[35-9]|59|61)|2(?:1[147]|"        .
                    "2[02369]|3[2589]|4[124578]|5[0134679])|3(?:06|2[1679]|"   .
                    "40|5[1478]|6[0134679]|76|9[2589])|40[124579]|"            .
                    "5(?:3[4679]|58|68|76|8[29]|9[48])|6(?:01|1[0369]|"        .
                    "2[0235689]|3[124578]|4[0134679])|7(?:68|8[2-47]|"         .
                    "9[0134679])|8(?:0[0235689]|1[134679]|37|48|5[0257]|"      .
                    "6[0134679]|7[0235689]|8[124578]|9[0134679])|9(?:3[79]|"   .
                    "4[134]|55|6[0369]|7[25-7]|8[03689]|9[124679]))|"          .
                "5(?:3(?:3[5-7]|48|5[58]|6[1458]|7[013679])|4(?:04|2[19]|"     .
                    "3[67]|51|6[29]|7[49]|8[25689]|9[124579])|5(?:24|4[18]|"   .
                    "5[147]|6[0369]|7[235689]|8[124578]|9[0134679])|693|"      .
                    "7(?:0[49]|1[2589]|2[14579]|46|6[147]|7[0469]|8[2568]|"    .
                    "9[124579])|8(?:13|2[16]|3[26]|4[0259]|5[0235689]|"        .
                    "6[02-4689]|7[0235689]|8[124579]|99)|9(?:17|2[03467]|"     .
                    "38|46|80|9[2679]))|"                                      .
                "6(?:1(?:2[1-3579]|3[135]|6[09]|8[08]|97)|2(?:0[39]|1[59])|"   .
                    "3(?:16|4[059]|8[24689])|4(?:09|19|27|34|4[16]|52|65|"     .
                    "74|8[679])|5(?:06|2[49]|32|48|5[36]|7[19])|6(?:0[357]|"   .
                    "2[49]|3[29]|55|7[06]|8[39])|7(?:2[135]|36|5[79]|89)|"     .
                    "8(?:02|1[07]|26|3[15]|4[24579]|71|9[279])|"               .
                    "9(?:0[134679]|19|3[15-79]|54|69))|"                       .
                "7(?:2(?:11|3[29]|4[35689]|5[12479]|83|99)|3(?:0[58]|1[38]|"   .
                    "2[147]|3[03679]|56|67|74|8[369])|4(?:04|1[29]|32|"        .
                    "4[269]|7[2468]|9[89])|5(?:68|7[02468]|80)|6(?:07|"        .
                    "1[269]|2[48]|3[278])|7(?:11|2[169]|49|5[135]|77|"         .
                    "9[38])|80[149])|"                                         .
                "8(?:19[579]|2(?:0[13579]|1[13579]|3[79]|59|7[79])|"           .
                    "3(?:0[79]|2[579]|35|5[579])|7(?:1[79]|5[579]|7[79]|"      .
                    "90)|8(?:16|32|44|57|65|7[069]))|"                         .
                "9(?:22[13579]|3(?:0[38]|13|2[038]|3[169]|4[258]|"             .
                    "5[1-35689]|6[124579]|7[89]|8[69]|9[2-469])|4(?:1[036]|"   .
                    "39|5[169]|6[258]|7[1-35689]|8[124578]|9[0134679])|"       .
                    "5(?:25|49|5[369]|6[258]|7[14-689]|8[124578]|"             .
                    "9[0134679])|6(?:14|33|4[0369]|64|83|9[039])))"            .
  
           "|3(?:0(?:1(?:59|6[13579]|7[13579])|4(?:19|49|5[13579])|5(?:19|"    .
                    "21|39|59)|6(?:2[579]|5[579]|69)|8(?:2[367]|5[135]|80|"    .
                    "90)|9(?:00|16|26|38|52|66|74|8[29]))|"                    .
                "1(?:0(?:08|2[089]|3[23569]|61|7[39]|8[457-9]|9[134679])|"     .
                    "1(?:3[4579]|41|57|6[27]|7[147]|8[058]|9[1569])|"          .
                    "2(?:2[468]|34|4[169]|75)|3(?:03|1[19])|5(?:15|35|"        .
                    "4[27]|5[235689]|82|9[25])|6(?:0[034689]|1[389]|"          .
                    "2[1-36-9]|3[2-46-8]|55|75|8[38]|9[1389])|7(?:0[0278]|"    .
                    "1[0-2457-9]|37|49|8[579])|8(?:12|32|4[08]|55|6[0378]))|"  .
                "2(?:0(?:49|5[12])|1(?:0[578]|20|3[09])|2(?:57|78|89)|"        .
                    "3(?:12|39|51|6[19])|4(?:2[3579]|57|69|79)|5(?:4[579]|"    .
                    "84)|6(?:0[29]|57|76|8[39]|9[49])|7(?:5[68]|60|91)|"       .
                    "8(?:05|16|25|3[29]))|"                                    .
                "3(?:0(?:14|3[49]|98)|1(?:0[0246]|29|42|54|6[15]|7[58]|"       .
                    "8[149])|3(?:11|3[0245]|78|97)|4(?:15|28|4[29])|519|"      .
                    "6(?:0[24579]|1[13579]|4[79]|59|89|99)|7(?:19|29|39|58|"   .
                    "75|90)|8(?:03|1[38]|2[49]))|"                             .
                "4(?:1(?:1[79]|2[13578]|3[0-24])|2(?:12|25|33|46|53|6[06]|"    .
                    "7[07]|8[169]|9[258])|3(?:0[258]|1[147]|2[03679]|46|"      .
                    "5[59]|69|7[69]|8[58]|9[369])|4(?:14|3[149]|54|66|"        .
                    "7[1479]|97)|5(?:08|1[369]|37|49|60|76|8[27]|9[0369])|"    .
                    "6(?:13|2[168]|3[02379]))|"                                .
                "5(?:0(?:3[79]|4[13]|66|75|8[0358]|9[1469])|1(?:0[248]|"       .
                    "1[024679])|2(?:16|3[269]|60|7[49]|8[2578])|3(?:05|15|"    .
                    "2[1579]|9[02468])|4(?:1[058]|2[38]|35|4[047]|5[27]|"      .
                    "6[0369])|5(?:1[069]|7[689]|8[0-6])|6(?:06|1[49]|25|"      .
                    "3[038]|4[1479]|8[3-9]|90)|7(?:08|1[369]|45|5[369]|"       .
                    "6[478]|8[19]|9[2469]))|"                                  .
                "6(?:0(?:3[79]|4[13]|88|93)|1(?:0[03]|1[059]|2[49]|3[27]|"     .
                    "4[258]|5[147]|6[03679]|79|99)|2(?:0[58]|1[1479]|51|"      .
                    "6[69]|7[257]|8[024679])|3(?:04|18|2[03569]|41|5[58]|"     .
                    "6[479]|81|9[169])|4(?:04|1[49]|33|48|5[267]|6[069]))|"    .
                "7(?:0(?:7[3579]|8[135])|1(?:15|2[047]|3[0369]|54|7[06]|"      .
                    "8[16]|9[1479])|2(?:1[3-8]|35|4[279]|69|76|8[147]|"        .
                    "9[03679])|3(?:08|18|27|39|45|5[159])|4(?:12|3[14]|"       .
                    "4[14579])|5(?:20|3[49]|47|74|8[169])|6(?:03|19|2[07]|"    .
                    "3[2359]|4[02379]|71|88|9[1679]))|"                        .
                "8(?:023|1(?:0[02468]|1[02468]|2[0246]|5[49]|6[25]|"           .
                    "7[0369])|2(?:2[689]|39|59|68|7[124579]|81)|3(?:0[024]|"   .
                    "1[259]|2[124579]|50|6[48]|7[235689]|8[124578])|"          .
                    "4(?:4[02468]|5[89]|6[124578]|7[0134679]|8[69])|5(?:18|"   .
                    "2[478]|3[01369]|4[237]|5[0134679])|6(?:4[024]|67|78|"     .
                    "85|90)|7(?:0[0479]|2[39])|8(?:2[0289]|3[568]|55|"         .
                    "7[1579]|89|9[59]))|"                                      .
                "9(?:014|1(?:0[468]|1[02468]|2[02468]|30|6[47]|7[159])|"       .
                    "2(?:18|21|4[059]|6[14]|79|88|91)|3(?:07|1[79]|26|"        .
                    "4[035]|5[69]|65|87|9[378])|4(?:18|3[459]|4[3468])|"       .
                    "5(?:17|24|39|7[69]|9[069])|6(?:06|1[59]|2[49]|38|"        .
                    "4[69])))"                                                 .
  
           "|4(?:0(?:2(?:1[0-3579]|2[13579]|3[13579])|4(?:68|7[024679]|89)|"   .
                    "5(?:4[579]|89|9[13579])|6(?:2[579]|6[78]|70|99)|"         .
                    "7(?:2[134]|64|89)|8(?:22|32|78|8[0235]))|"                .
                "1(?:06[135689]|1(?:69|79|89|99)|23[689]|3(?:34|52|6[36]|"     .
                    "7[29])|4(?:6[024689]|7[02])|5(?:1[5-7]|39|4[0-2]|"        .
                    "6[49])|7(?:4[7-9]|51)|8(?:12|36|4[49]))|"                 .
                "2(?:1(?:0[3579]|1[13579])|2(?:7[579]|8[13579])|3(?:2[79]|"    .
                    "49|69|89|99)|4(?:77|89|99)|5(?:49|5[135]|79)|"            .
                    "6(?:5[13579]|9[79])|7(?:19|81|99)|8(?:5[3579]|9[79])|"    .
                    "929)|"                                                    .
                "4(?:1(?:3[579]|4[13579])|2(?:2[579]|6[3579]|8[79])|3(?:09|"   .
                    "19|2[89]|39|5[79]|69|79|88)|5(?:3[246]|7[579]|81)|"       .
                    "6(?:2[357-9]|49|5[1-3])|7(?:8[79]|9[13579])|"             .
                    "8(?:0[13579]|6[679]|79|9[24]))|"                          .
                "5(?:1(?:2[78]|3[0134689]|4[13-579])|2(?:19|39|5[79]|"         .
                    "7[679]|89)|3(?:0[79]|2[679]|5[5-79])|4(?:03|68|"          .
                    "7[0235689]|81)|5(?:2[579]|49)|6(?:5[79]|6[135]|99)|"      .
                    "7(?:01|11|21|3[19]|68|7[02])|8(?:79|8[134689]|"           .
                    "9[124679])|96[468])|"                                     .
                "6(?:04[579]|1(?:1[79]|4[579])|2(?:3[68]|4[024]|8[246])|"      .
                    "3(?:25|4[28]|5[49]|9[579])|4(?:1[49]|46|59|8[357]|99)|"   .
                    "5(?:09|1[49]|3[579]|6[29]))|"                             .
                "7(?:05[1357-9]|1(?:19|3[7-9]|6[679]|7[89]|9[89])|"            .
                    "2(?:2[689]|39|49|59|69|79)|4(?:4[1357]|75|95)|"           .
                    "5(?:0[69]|33|46|5[19]|74|89)|6(?:08|2[3-7]|38|47|52|"     .
                    "6[159])|79[89]|8(?:0[02-579]|29|39|77)|9(?:06|18|29))|"   .
                "8(?:079|1(?:4[3579]|5[13579]|6[1357])|2(?:31|49|68|82|91)|"   .
                    "3(?:0[18]|17|2[49]|36|4[16]|5[16]|6[169])|4(?:29|"        .
                    "3[12]|55|65|77|8[058]|9[369])|5(?:2[79]|31|65|99)|"       .
                    "6(?:07|1[29]|2[49]|53|83|91)|7(?:03|12|2[07]|3[49]))|"    .
                "9(?:0(?:7[468]|8[02468]|90)|1(?:24|34|43|52|63|7[069]|86|"    .
                    "9[16])|2(?:0[15]|1[49])|3(?:2[468]|56|77|93)|"            .
                    "4(?:0[16]|1[39]|2[49]|3[49]|48|5[13679]|7[79]|9[27])|"    .
                    "5(?:0[49]|25|36|4[59]|65|77|8[46]|9[34679])|6(?:10|"      .
                    "2[46]|3[2578]|61|8[158]|9[269])|7(?:16|33|4[04]|5[17]|"   .
                    "6[27]|7[0479])|8(?:0[89]|11|2[48]|3[258]|4[34679])))"     .
  
           "|5(?:0(?:1(?:2[679]|69|7[01]|8[19])|2(?:26|59)|3(?:21|54|74|"      .
                    "89)|6(?:6[78]|7[0246-9])|7(?:3[3579]|6[579])|"            .
                    "8(?:2[3579]|5[89])|9(?:3[13579]|6[89]|9[679]))|"          .
                "1(?:06[13579]|1(?:0[3579]|4[3579])|3(?:7[13579]|81|99)|"      .
                    "4(?:2[79]|6[579]|91)|5(?:03|1[59]|45|70|8[08]|9[78])|"    .
                    "6(?:4[357]|74|88)|7(?:0[29]|66|89))|"                     .
                "2(?:0(?:6[2468]|7[02468]|80)|1(?:34|46|5[269])|2(?:2[2-4]|"   .
                    "49)|3(?:49|5[135]|7[29]|8[258]|9[1369])|4(?:28|4[15]|"    .
                    "5[79]|77|99)|5(?:11|25|3[18]))|"                          .
                "3(?:1(?:1[13579]|2[13579]|7[3579])|22[579]|3(?:32|4[037]|"    .
                    "59)|4(?:2[46]|74|89|98)|5(?:0[15-8]|18|20|3[349]|"        .
                    "4[57]|57|6[027]|7[27-9])|6(?:04|19|39)|7(?:21|57|73|"     .
                    "83|97)|8(?:0[49]|19|4[024]|59|79|81|94)|9(?:0[29]|"       .
                    "1[39]|25|37|4[0579]))|"                                   .
                "4(?:29[02-68]|3(?:0[689]|1[01346-8]|2[09]|3[128]|"            .
                    "4[0134679])|4(?:1[13]|2[124679]|39|41|5[0135-79]|"        .
                    "7[02]|8[3467]|9[278])|5(?:1[68]|2[34689]|3[134689]|"      .
                    "5[028]|68|7[04689]|8[4-79]|9[57])|6(?:08|1[0-24679]|"     .
                    "3[46]|4[679]|5[57]|6[24689]|7[35]|8[79]))|"               .
                "5(?:1(?:1[68]|2[0246-9]|3[01])|2(?:18|3[2479]|46|5[27]|"      .
                    "6[238]|7[0168]|8[368]|9[1469])|4(?:1[13]|2[245]|"         .
                    "3[0257]|4[24]|5[0279]|69|71|8[137]|9[014679])|"           .
                    "5(?:4[356]|59|6[689]|7[168]|8[35]|9[0235-79])|"           .
                    "6(?:0[68]|1[89]|2[14679])|7(?:43|5[68]|6[578]|"           .
                    "7[4679]))|"                                               .
                "6(?:0(?:68|7[0235-7])|1(?:12|3[023]|54|7[09]|82|91)|"         .
                    "2(?:0[346]|18|20|3[57]|4[249]|5[34]|69|7[16]|8[138]|"     .
                    "9[01459])|3(?:0[57]|1[67]|2[1-39]|3[023578]|4[01689]|"    .
                    "5[57]|68|7[079])|4(?:1[024]|2[2478]|5[79]|62|7[0279])|"   .
                    "5(?:6[467]|7[59]|8[147-9]|9[3489])|6(?:26|3[07]|"         .
                    "4[258]|5[1369])|7(?:2[79]|36|4[356]|5[1349]|6[1679])|"    .
                    "8(?:1[248]|2[0135689]|4[13]|5[0689]|6[124579]))|"         .
                "7(?:0(?:7[2468]|80)|2(?:23|34|5[08]|71|9[09])|3(?:19|"        .
                    "3[49]|68|9[29])|4(?:13|39|62|8[29])|5(?:18|20|3[79]|"     .
                    "48|55|6[27]|7[278]|8[0134679])|6(?:1[024]|2[79]|"         .
                    "3[25689]|4[124578]))|"                                    .
                "8(?:0(?:89|9[13579])|1(?:19|35)|2(?:39|56|85)|3(?:00|13|"     .
                    "3[29])|45[2-6]|5(?:0[79]|1[135]|40|53|66|79)|"            .
                    "6(?:3[68]|4[024]|75)|7(?:0[68]|10|3[09]|6[29]|91)|"       .
                    "8(?:0[29]|4[09]))|"                                       .
                "9(?:0(?:6[3579]|7[1357])|1(?:74|9[29])|2(?:2[79]|69)|"        .
                    "3(?:02|2[09]|48|68|79|87|9[49])|4(?:2[357]|39|57|69|"     .
                    "94)|5(?:05|1[049]|5[5-8]|81|9[07])|60[29]|75[579]|"       .
                    "8(?:2[13]|46|72|89)|9(?:09|29|39|55|6[49])))"             .
  
           "|6(?:0(?:3(?:08|1[13468]|2[0235-79]|8[5689])|4(?:3[1357-9]|"       .
                    "8[6-9])|5(?:2[89]|49|9[4689]))|"                          .
                "1(?:1(?:18|3[078]|69|84|9[147])|2(?:0[0369]|3[19]|50|67|"     .
                    "7[369])|3(?:48|5[02]|8[19])|4(?:4[09]|62|7[69]))|"        .
                "3(?:0(?:6[579]|7[135])|1(?:10|28|50|65|79)|2(?:25|63)|"       .
                    "3(?:03|2[29])|4(?:05|5[02467]|77|86)|5(?:0[05]|1[27]|"    .
                    "26|3[38]|4[369]|7[19]|8[49]|9[49])|6(?:07|19|28|"         .
                    "3[3679]|54|67|7[49]|8[38]|9[14579])|7(?:39|4[13]|55|"     .
                    "6[28]|7[36]|85|9[16])|8(?:0[18]|1[14]|2[05689]|3[149]|"   .
                    "4[0369]|5[367]|6[0347-9]|7[124579]|97)|9(?:06|1[16]|"     .
                    "2[04578]|3[0134679]))|"                                   .
                "4(?:2(?:8[3579]|9[1357])|3(?:19|31|4[27]|54|67|72|8[05]|"     .
                    "9[057])|40[14579]|5(?:21|46|6[09]|7[29]|8[49])|6(?:25|"   .
                    "46|5[38]|6[58]|7[38]|8[369])|7(?:11|20|3[29]|4[37]|"      .
                    "5[034679])|8(?:07|23|3[29]|46|5[039]))|"                  .
                "5(?:1(?:8[3579]|9[13579])|2(?:0[1357]|19|2[0-4]|3[29])|"      .
                    "3(?:07|2[169]|4[3-7]|66|75|8[58]|9[169])|4(?:28|39|51|"   .
                    "6[28]|7[49])|5(?:10|2[079]|49|5[0-68]|8[29]|9[479])|"     .
                    "6(?:0[46]|1[148]|2[034679])|7(?:19|60|79|95)|"            .
                    "8(?:1[27]|24|3[05]|43)|9(?:29|3[1346]))|"                 .
                "6(?:1(?:1[13579]|2[135-9]|3[0-3])|2(?:65|71|8[07]|9[29])|"    .
                    "3(?:33|46|5[29]|86|99)|4(?:24|40|5[039]|8[24]|97)|"       .
                    "5(?:0[0134679]|3[89]|40|57|64|7[18]|8[39])|6(?:06|"       .
                    "2[059]|36|4[069]|63|79|87|93)|7(?:0[169]|40|63|73|"       .
                    "8[07]|9[38])|8(?:0[269]|22|39|49|51|6[29]|7[179]|"        .
                    "8[257]|9[24])|9(?:0[13479]|1[4679]|5[3-57]|69|7[68]|"     .
                    "8[179]|9[469]))|"                                         .
                "7(?:0(?:59|6[13579]|71|98)|1(?:05|1[27]|2[25-7]|3[346]|"      .
                    "4[1679]|5[027-9]|6[15-79])|2(?:2[79]|4[056]|5[1689]|"     .
                    "69|7[138]|8[013]|9[2457])|3(?:0[4578]|1[01679]|46|54|"    .
                    "6[013568]|7[346-8])|4(?:3[3-5]|5[49]|6[68]|7[1-35]|"      .
                    "8[02379])|5(?:4[79]|5[01]|7[4578]|8[0235-7]|"             .
                    "9[0-35689])|6(?:5[3579]|6[13]|7[78]|8[01568]|9[1379])|"   .
                    "7(?:0[015-7]|1[4-68]|2[2457-9]|3[12457]|4[24-689]|"       .
                    "5[2-4679])|8(?:0[68]|1[134679]|2[1-4679]))|"              .
                "8(?:1(?:59|6[13579]|99)|2(?:19|29|39|59)|30[579]|5(?:19|"     .
                    "26|35|4[29])|6(?:23|4[279])|7(?:23|53|66|75|8[29]|"       .
                    "9[49])|80[49])|"                                          .
                "9(?:1(?:1[578]|2[01346]|51|68|81|9[08])|2(?:07|14|2[16]|"     .
                    "3[149]|4[25]|5[0134679])|4(?:12|2[79]|3[4679]|69|"        .
                    "8[38]|93)|5(?:0[29]|1[478])))"                            .
  
           "|7(?:0(?:1(?:7[3468]|8[02468]|9[0-3579])|3(?:2[79]|7[2468])|"      .
                    "4(?:3[579]|69|99)|5(?:6[3579]|9[79])|6(?:19|29)|"         .
                    "7(?:3[46]|71|94)|8(?:06|25|39))|"                         .
                "1(?:0(?:3[24]|6[3579]|8[38]|93)|1(?:0[16]|1[16]|2[06]|"       .
                    "3[149]|4[49]|5[4579])|2(?:29|54|63|7[27]|8[27]|"          .
                    "9[2679])|3(?:3[246]|64|84|9[47])|40[49]|5(?:22|"          .
                    "4[0369]|54|6[036]|7[03679])|6(?:3[468]|4[02]|65|7[29]|"   .
                    "86|9[16])|7(?:0[16]|1[178]|2[0369]|3[2579]))|"            .
                "2(?:07[0246]|1(?:08|1[69]|2[47]|3[158]|4[14579]|60|7[258]|"   .
                    "8[1469])|2(?:02|1[38]|2[14679]|50|7[05]|8[05]|"           .
                    "9[0134679])|3(?:36|48|5[15689]|6[124579]|79|93)|"         .
                    "4(?:0[16]|1[14579]|5[89]|6[19]|7[4579]|88)|5(?:0[15]|"    .
                    "1[0134679]|25|3[124579]|55|74|8[124579])|6(?:22|"         .
                    "3[169]|4[49]|5[4578]|6[0134679])|7(?:6[02468]|70|93)|"    .
                    "8(?:0[05]|1[038]|2[079]))|"                               .
                "3(?:0(?:3[357]|54|6[16]|7[29]|8[47]|9[2589])|"                .
                    "1(?:0[124578]|1[0134679])|2(?:07|3[05]|4[09]|5[27]|"      .
                    "6[25689]|7[124578])|3(?:12|2[69]|3[37]|4[024579])|"       .
                    "4(?:3[0-4]|4[17]|5[037]|6[03679]|79|8[5689]|"             .
                    "9[124579])|5(?:2[579]|4[07]|5[037]|6[035689]|"            .
                    "7[124579])|6(?:14|3[05]|42|5[05]|6[03679])|7(?:28|"       .
                    "3[02-4]|6[05]|7[0369]))|"                                 .
                "4(?:0(?:7[2468]|8[01])|1(?:7[27]|8[29]|9[369])|2(?:06|"       .
                    "1[149]|2[369]|3[2589]|4[35689]|5[124579])|3(?:21|"        .
                    "3[67]|4[38]|5[47]|6[0369]|7[2469]|8[2589]|9[124579])|"    .
                    "4(?:05|17|2[034679])|5(?:23|3[258]|4[124579]|64|"         .
                    "7[259]|8[2569]|9[24579])|6(?:13|2[69]|3[2589]|53|"        .
                    "7[03679])|7(?:06|22|3[16]|4[034679])|8(?:21|3[1248]|"     .
                    "4[27]|5[058]|6[124579]|89)|9(?:0[69]|1[258]|2[14578]|"    .
                    "3[0134679]))|"                                            .
                "5(?:0(?:15|3[18]|45|5[03679])|1(?:7[23579]|8[01]|96)|"        .
                    "2(?:03|1[07]|2[38]|3[369]|4[2589])|3(?:05|2[38]|"         .
                    "3[14579]|65|78|8[2579]|9[124579])|4(?:17|28|3[38]|"       .
                    "4[3679]))|"                                               .
                "6(?:006|1(?:3[13579]|49|8[579]|99)|2(?:2[7-9]|75|87|97)|"     .
                    "3(?:07|16|27|3[27]|44|5[169])|4(?:37|48|56|6[17]|"        .
                    "7[034679])|5(?:3[024]|4[79]|71|9[3679])|6(?:46|6[19]|"    .
                    "76|8[49]|9[48])|7(?:0[3679]|26|44|5[16]|6[1478]|"         .
                    "7[0134679])|8(?:29|3[135]|4[68]|5[57]|6[35]|7[0279]|"     .
                    "8[79]|91))|"                                              .
                "7(?:6(?:5[246]|94)|7(?:0[49]|16|2[38]|3[16]|4[0369]|56|"      .
                    "6[17]|7[036]|8[147]|9[0134679])|8(?:15|3[0369]|55|66|"    .
                    "7[16]|8[03679])|9(?:33|4[48]|55|6[036]|7[124578]))|"      .
                "8(?:0(?:48|5[0246]|7[38]|8[3679]|98)|1(?:12|2[06]|3[26]|"     .
                    "4[1478]|66|76|8[37]|9[49])|2(?:24|3[49]|4[47]|5[0369]|"   .
                    "6[2679])|3(?:15|3[37]|4[35]|5[14579])|4(?:6[2457]|"       .
                    "7[69])|5(?:32|49|5[49]|6[47]|7[0369]|8[0235689]|"         .
                    "9[124578])|6(?:0[0134679]|28|47|5[258]|6[124579])|"       .
                    "7(?:13|27|3[03679]))|"                                    .
                "9(?:098|1(?:0[02468]|1[0-2457]|8[39]|9[49])|2(?:06|1[159]|"   .
                    "2[47]|3[258]|4[149]|5[2468]|6[138]|7[1469]|8[0235689]|"   .
                    "9[124579])|3(?:12|3[16]|4[168]|5[0369]|6[124579]|79|"     .
                    "95)|4(?:00|1[058]|2[34679])|5(?:13|39|4[01]|7[68]|"       .
                    "8[589]|9[124579])|6(?:18|39|50|6[49]|7[47]|8[235689]|"    .
                    "9[124579])|7(?:13|25|3[03679]|61|7[147]|8[07]|9[038])|"   .
                    "8(?:0[124579]|22|37|4[38]|5[369]|6[258]|7[124579])))"     .
  
           "|8(?:0(?:33[135-79]|469|53[89]|6(?:3[46-9]|8[679])|79[6-9]|"       .
                    "80[1-579]|9(?:3[3579]|9[23579]))|"                        .
                "1(?:24[13579]|3(?:69|7[13579])|47[5-79]|5(?:39|4[13579])|"    .
                    "6(?:6[79]|7[13579])|73[579]|82[579]|92[579])|"            .
                "2(?:0(?:08|24|3[12]|4[19]|5[47]|6[14579])|1(?:10|31|40|52|"   .
                    "66|78|94)|2(?:05|1[16]|2[39]|3[479]|56|6[69]|7[25689]|"   .
                    "8[124578]|9[0134679])|3(?:19|27|35|4[03679]|62|77|"       .
                    "8[03679]|9[0235689])|4(?:0[124579]|18|3[1-35689]|"        .
                    "4[124579]|67|8[178]|9[0134679])|5(?:15|38|4[1479]))|"     .
                "3(?:0(?:2[246]|43|5[29]|64|7[15]|8[038]|9[38])|1(?:0[149]|"   .
                    "1[259]|2[235689]|3[124579])|2(?:09|2[49]|3[36]|4[26]|"    .
                    "5[034679]|78)|3(?:0[18]|1[37]|2[49]|3[49]|4[2469]|"       .
                    "5[2589]|6[124578]|7[0134679]|95)|4(?:04|1[0367]|35|"      .
                    "5[1478]|71|8[3679])|5(?:12|27|3[0369]|4[34679]|"          .
                    "5[0235689]|6[124579])|6(?:07|2[034679]|46|6[16]|"         .
                    "7[0134679]|84)|7(?:0[0378]|14|27|3[04579]))|"             .
                "4(?:0(?:28|3[0246]|48|5[16]|6[169]|7[269]|8[2589]|"           .
                    "9[124578])|1(?:0[0134679]|3[07]|4[049]|5[25]|"            .
                    "6[034689]|7[124578]|8[0134679])|3(?:07|2[369]|"           .
                    "3[23579]|47|59|6[47]|7[158]|8[14579])|4(?:05|1[69]|"      .
                    "2[478]|3[124579]|53|78|89|94)|5(?:0[38]|1[38]|2[49]|"     .
                    "3[39]|4[34679]|5[0235689]|6[124578]|7[0134679]))|"        .
                "5(?:0(?:49|5[1357]|7[27]|8[048]|9[258])|1(?:0[147]|"          .
                    "1[0134679]|2[0235689]|3[124579])|2(?:2[19]|3[258]|"       .
                    "4[147]|5[034689]|76|83|9[0368])|3(?:0[124579]|5[46]|"     .
                    "68|7[56]|86|9[159])|4(?:0[2568]|1[0134679]|35|4[57]|"     .
                    "5[2679]|6[124579])|5(?:21|40|51|6[07]|7[09]|86|"          .
                    "9[189])|6(?:0[49]|1[47]|2[25]|3[05]|4[0369]|5[235689]|"   .
                    "6[124579])|7(?:16|37|48|57|64|7[478]))|"                  .
                "6(?:1(?:5[02-4679]|6[13579]|79|99)|3(?:16|43|56|68|81|"       .
                    "9[19])|4(?:05|15|2[04]|38|4[147]|5[0369]|6[25]|"          .
                    "7[03679]|8[0235689]|9[124578])|5(?:0[024578]|"            .
                    "1[013479]|29|5[14689]|6[124578]|7[0134679])|6(?:09|"      .
                    "3[37]|4[137]|5[0357]|6[03689]|7[2-689]|8[124578]|"        .
                    "9[024578])|7(?:0[0134679]|20|3[235689]|4[124578]|"        .
                    "5[0134679])|8(?:07|25|3[036]|4[25]|5[034679]|"            .
                    "6[0235689]|7[124579]|99)|9(?:1[169]|2[0235689]|"          .
                    "3[124578]|4[0134679]|56|7[124578]|8[0134679]))|"          .
                "7(?:4(?:3[579]|48|5[29]|6[36]|7[147]|8[0478]|9[034679])|"     .
                    "5(?:09|27|3[48]|4[14579]|61)|6(?:00|16|29|3[47]|"         .
                    "4[02578]|5[0134679]|6[0235689]|7[124579])|7(?:00|19|"     .
                    "2[47]|3[034679]|4[0235689]|5[124578]|6[0134679]|"         .
                    "7[0235689]|8[124579]))|"                                  .
                "8(?:0(?:4[568]|69|7[49]|8[56]|9[0479])|1(?:3[18]|4[2579]|"    .
                    "6[17]|7[1589])|2(?:1[2-4]|39|5[05]|6[037]|7[1369]|"       .
                    "8[14579]|99)|3(?:1[679]|26|39|48|5[36]|6[1478]|"          .
                    "7[0134679])|4(?:00|1[06]|2[27]|3[0367]|4[1478]|"          .
                    "5[0134679]|7[17]|8[0134679]|99)|5(?:1[258]|2[14579])|"    .
                    "6(?:05|3[0134679]|62|77|82|9[03679])|7(?:09|1[89]))|"     .
                "9(?:0(?:40|7[3579]|81)|1(?:29|34|43|5[05]|6[058]|"            .
                    "7[134679]|8[0235689]|9[124578])|2(?:3[13]|5[07]|6[49]|"   .
                    "7[58]|8[147]|9[0134679])|3(?:12|3[15]|4[034679]|"         .
                    "5[0235689]|6[124578])|4(?:07|15|2[03689]|3[124578]|"      .
                    "4[0134679])|5(?:18|2[02]|37|4[27]|5[158]|6[1478]|84|"     .
                    "97)|6(?:0[14578]|1[0134679])))"                           .
  
           "|9(?:0(?:4(?:0[2389]|1[19]|2[579]|3[19]|4[139]|5[13579]|6[19]|"    .
                    "7[1358]|8[029]|91)|5(?:1[38]|22|3[07]|4[27]|5[269]|62|"   .
                    "7[149]|8[47]|9[269])|6(?:0[27]|1[034679])|76[23568])|"    .
                "1(?:0(?:5[2468]|7[47]|8[03568]|9[0134679])|1(?:26|54|"        .
                    "6[16]|7[147]|8[03679])|2(?:07|17|2[047]|3[035689]|"       .
                    "4[124579]|57|7[58]|8[124679])|3(?:01|15|2[0257]|"         .
                    "3[02468]|4[14679]|5[0235689]|6[124579])|4(?:13|38|"       .
                    "4[38]|5[269]|6[0235689]|7[124578]|8[0134679])|5(?:22|"    .
                    "41|5[05]|6[047]|7[258]|8[03679]|9[0235689])|"             .
                    "6(?:0[124578]|1[0134679]|2[0235689]|3[124579])|"          .
                    "7(?:1[079]|2[0235689]|3[124578]|4[0134679]|57|8[158]|"    .
                    "9[0235689])|80[124579])|"                                 .
                "2(?:2(?:24|37|4[259]|5[369]|6[0235689]|7[124578]|"            .
                    "8[0134679])|3(?:18|3[149]|4[258]|5[358]|6[0134679])|"     .
                    "4(?:21|3[169]|4[24579])|5(?:07|2[16]|3[369]|"             .
                    "4[0235689]|5[124579])|6(?:37|48|55|6[05]|7[06]|8[15]|"    .
                    "9[034679])|7(?:0[0235689]|1[124578]|2[0134679]))|"        .
                "3(?:0(?:4[79]|5[13579]|7[37]|8[03679]|9[0235689])|"           .
                    "1(?:0[124579]|28|3[38]|4[29]|5[258]|6[147]|7[03679]|"     .
                    "8[0235689]|9[124579])|3(?:09|26|3[369]|4[235689]|"        .
                    "5[124689])|4(?:13|26|37|4[49]|5[358]|6[2468]|"            .
                    "7[0134679]|8[0235689]|9[124579]))|"                       .
                "4(?:0(?:3[246]|51|6[05]|7[28]|8[169]|9[49])|1(?:0[47]|"       .
                    "1[0368]|2[147]|3[03679]|4[0235689]|5[124578]|"            .
                    "6[0134679])|2(?:09|27|3[49]|4[49]|5[0235689]|"            .
                    "6[124579])|3(?:15|27|3[0369]|4[24578]|5[0134679]|"        .
                    "6[0235689]|7[124579])|4(?:05|19|2[48]|3[1679]|47|69|"     .
                    "74|8[16]|9[16])|5(?:0[158]|1[38]|2[2679]|3[0235689]|"     .
                    "4[124578]|5[0134679]|6[0235689]|7[124579]))|"             .
                "5(?:0(?:28|3[02])|1(?:00|1[19]|26|3[18]|45|5[28]|6[38]|"      .
                    "7[369]|8[0235689]|9[124579])|2(?:13|3[34679])|3(?:26|"    .
                    "3[69]|4[69]|5[25689]|6[124579])|4(?:4[4578]|6[0369]|"     .
                    "7[38]|8[258]|9[0134679])|5(?:0[0235689]|1[124579])|"      .
                    "6(?:15|32|43|5[29]|66|7[169]|8[0235689]|9[124578])|"      .
                    "70[0134679])|"                                            .
                "6(?:0(?:4[79]|5[02])|1(?:0[36]|1[047]|2[0369]|3[258]|"        .
                    "4[25689]|5[124578]|6[0134679]|7[0235689]|8[124578]|"      .
                    "9[0134679])|2(?:15|24|3[17]|4[27]|5[037]|6[0489]|"        .
                    "7[124579])|3(?:17|28|3[27]|4[269]|5[258]|6[14579])|"      .
                    "4(?:50|65|7[269]|8[24679])|5(?:15|2[348]))|"              .
                "7(?:0(?:7[02468]|8[024])|199|2(?:0[49]|1[58]|2[258]|"         .
                    "3[024679]|4[134679]|5[0235689]|6[124578]|7[0134679]|"     .
                    "8[0235689]|9[124579])|3(?:18|20|3[247]|4[0268]|"          .
                    "5[03579])|4(?:12|2[124]|37|4[07]|5[036]|6[149]|7[58]|"    .
                    "8[368]|9[0134679])|5(?:0[0235689]|1[134679]|"             .
                    "2[0235689]|3[124579])|6(?:1[68]|3[138]|4[057]|"           .
                    "5[034679]|88)|7(?:0[258]|1[147]|2[03-579]|37|53|6[29]|"   .
                    "7[235689]|8[0235689]|9[124579])|8(?:16|28|3[34679]|"      .
                    "4[0235689]|5[124579]|77|9[26])|9(?:0[0134679]|22|"        .
                    "4[147]|5[03679]|80|9[0369]))|"                            .
                "8(?:5(?:2[7-9]|30|4[47]|5[349]|74|87|9[03679])|6(?:17|"       .
                    "3[149]|46|6[03679]|7[38]|93)|7(?:0[148]|1[146]|24|39|"    .
                    "4[3469]))|"                                               .
                "9(?:0(?:8[4-79]|9[1246-9])|1(?:0[02]|30|89|9[258])|3(?:10|"   .
                    "26|3[048])|4(?:2[3578]|3[89]|4[148])|51[08]|6(?:10|"      .
                    "2[58]|3[1468])|7(?:06|1[38]|3[45]|5[259]|6[258])|"        .
                    "8(?:1[79]|26|3[0147]|4[268]|6[79]|8[057]|9[1478])|"       .
                    "9(?:47|5[58]|7[46]|8[68]|9[1468])))"                      .
      ")",
  
  
      #
      # Postal codes of Greenland use a slice of the Danish postal code system.
      # Greenlands postal code consist of 4 digits, the first two being 39.
      # Except Santas postal code. He uses 2412.
      #
      # Data from: http://download.geonames.org/export/zip/GL.zip
      #
      Greenland   =>
        "(?k:2412"                                                             .
           "|39(?:0[05]|1[0-359]|2[0-4]|3[02]|40|5[0-35]|6[124]|"              .
                 "7[0-2]|8[0245]|92)"                                          .
      ")",
  
  
      #
      # Postal codes for Italy use 5 digits, with leading 0s. Codes starting
      # with 4789 belong to San Marino.
      #
      # Data from: http://download.geonames.org/export/zip/IT.zip
      # 
  
      Italy       =>
        "(?k:0(?:0(?:0(?:1[0-357-9]|2[0-9]|3[0-9]|4[0-9]|5[0-57-9]|"           .
                    "6[0-35-9])|1(?:19|2[0-8]|3[1-9]|4[1-9]|5[1-9]|6[1-9]|"    .
                    "7[1-9]|8[1-9]|9[1-9]))|"                                  .
                "1(?:0(?:1[0-24-9]|2[0-8]|3[02-9])|100)|"                      .
                "2(?:0(?:1[0-689]|2[0-68]|3[0-57-9]|4[0-9])|100)|"             .
                "3(?:0(?:1[0-46-9]|2[0-9]|3[0-9]|4[0-9])|100)|"                .
                "4(?:0(?:1[0-9]|2[0-9])|100)|"                                 .
                "5(?:0(?:1[0-8]|2[0-689]|3[0-2459])|100)|"                     .
                "6(?:0(?:1[024689]|2[0-9]|3[013-689]|4[0-79]|5[013-79]|"       .
                    "6[0-689]|7[023]|8[1349])|1(?:00|2[1-9]|3[124]))|"         .
                "7(?:0(?:1[0-9]|2[0-9]|3[0-9]|4[013-9])|100)|"                 .
                "8(?:0(?:1[0-35-9]|2[0-9]|3[0-9]|4[02-9])|100)|"               .
                "9(?:0(?:1[0-9]|2[0-9]|3[0-9]|4[0-57-9]|7[0-9]|8[0-68]|"       .
                    "9[0-9])|1(?:00|2[1-9]|3[14]|70)))"                        .
  
           "|1(?:0(?:0(?:1[0-9]|2[02-689]|3[0-24-8]|4[0-68]|5[0-9]|6[0-9]|"    .
                    "7[0-8]|8[0-8]|9[0-589])|1(?:00|2[1-9]|3[1-9]|4[1-9]|"     .
                    "5[1-6]))|"                                                .
                "1(?:0(?:1[0-8]|2[0-9])|100)|"                                 .
                "2(?:0(?:1[0-9]|2[0-9]|3[0-9]|4[0-9]|5[0-68]|6[0-689]|"        .
                    "7[0-9]|8[0-47-9])|100)|"                                  .
                "3(?:0(?:1[0-27-9]|2[0-8]|3[0-9]|4[013-9]|60)|100|"            .
                    "8(?:1[124-8]|2[1-5]|3[13-6]|4[13-578]|5[1-6]|6[1-8]|"     .
                    "7[1-8]|8[1-8]|9[13-9])|900)|"                             .
                "4(?:0(?:1[0-9]|2[0-6]|3[0-79]|4[0-9]|5[0-57-9])|100)|"        .
                "5(?:0(?:1[0-9]|2[0-9]|3[0-689]|4[0-689]|5[0-9]|6[0-9]|"       .
                    "7[0-9])|100)|"                                            .
                "6(?:0(?:1[0-9]|2[0-9]|3[0-689]|4[0-9])|1(?:00|2[1-9]|"        .
                    "3[1-9]|4[1-9]|5[1-9]|6[1-7]))|"                           .
                "7(?:0(?:1[0-579]|2[0-8]|3[0-57-9]|4[0-8]|5[1-8])|100)|"       .
                "8(?:0(?:1[0-9]|2[0-7]|3[0-9])|100)|"                          .
                "9(?:0(?:1[0-8]|2[0158]|3[0-478])|1(?:00|2[1-6]|3[1-9])))"     .
  
           "|2(?:0(?:0(?:1[0-9]|2[0-9]|3[027]|40|56|6[0-9]|7[078]|8[0-9]|"     .
                    "9[0-9])|1(?:2[1-9]|3[1-9]|4[1-9]|5[1-9]|6[12])|"          .
                    "8(?:1[1-6]|2[1-6]|3[1-8]|4[1-7]|5[1-7]|6[1-7]|7[1-7]|"    .
                    "8[1-6])|900)|"                                            .
                "1(?:0(?:1[0-9]|2[0-9]|3[0-9]|4[0-9]|5[0-9])|100)|"            .
                "2(?:0(?:1[0-9]|2[0-9]|3[0-9]|4[04-6]|6[0369]|7[0-9])|100)|"   .
                "3(?:0(?:1[0-9]|2[0-79]|3[0-8])|100|8(?:0[124-8]|1[13-9]|"     .
                    "2[1-9]|3[1-8]|4[1-9]|5[12457]|6[124578]|7[013-9]|"        .
                    "8[013-9]|9[0-9])|900)|"                                   .
                "4(?:0(?:1[0-9]|2[0-9]|3[013-9]|4[0-9]|5[0-9]|6[0-9])|"        .
                    "1(?:00|2[1-9]))|"                                         .
                "5(?:0(?:1[0-9]|2[0-9]|3[0-9]|4[0-9]|5[0-9]|6[0-589]|"         .
                    "7[0-9]|8[0-9])|1(?:00|2[1-9]|3[1-6]))|"                   .
                "6(?:0(?:1[0-9]|2[0-9]|3[0-9]|4[0-9])|100|8(?:1[1-8]|"         .
                    "2[1-8]|3[1-9]|4[1-9]|5[1-9]|6[1-7])|900)|"                .
                "7(?:0(?:1[0-9]|2[0-9]|3[0-9]|4[0-9]|5[0-57-9])|100)|"         .
                "8(?:0(?:1[0-79]|2[148]|4[0135-7]|5[03]|6[0-24-689]|"          .
                    "7[0-9])|100|8(?:0[1-5]|1[1-9]|2[1-8]|3[1-368]|4[1-5]|"    .
                    "5[1-9]|6[1-68]|7[135-79]|8[13-7]|9[13-9])|922)|"          .
                "9(?:0(?:1[0-9]|2[0-9])|100))"                                 .
  
           "|3(?:0(?:0(?:1[03-6]|2[0-9]|3[0-9])|1(?:00|2[1-6]|3[1-35]|"        .
                    "4[12]|7[0-5]))|"                                          .
                "1(?:0(?:1[0-8]|2[0-9]|3[0-9]|4[0-9]|5[0-9])|100)|"            .
                "2(?:0(?:1[02-6]|2[0-26-8]|3[0-7]|4[0-7])|100)|"               .
                "3(?:0(?:1[0135-9]|2[0-9]|3[0-9]|4[0-9]|5[0-9]|7[024-9]|"      .
                    "8[0-7]|9[02457-9])|1(?:00|70))|"                          .
                "4(?:0(?:1[0-24-8]|7[0-9])|1(?:00|2[1-9]|3[1-9]|4[1-9]|51|"    .
                    "70))|"                                                    .
                "5(?:0(?:1[0-9]|2[0-9]|3[0-24-8]|4[0-8])|1(?:00|2[1-9]|"       .
                    "3[1-9]|4[1-3]))|"                                         .
                "6(?:0(?:1[0-6]|2[0-8]|3[0-6]|4[0235-7]|5[0-7]|6[0-6]|"        .
                    "7[0-35-8])|100)|"                                         .
                "7(?:0(?:1[0-9]|2[0-4689]|3[0-25689]|4[0-79]|5[0-9]|"          .
                    "6[02-46-9])|1(?:00|2[1-9]|3[1-9]|42))|"                   .
                "8(?:0(?:1[0-35-9]|2[0-9]|3[0-9]|4[0-35-9]|5[0-79]|6[0-9]|"    .
                    "7[0-9]|8[0-35-9])|100)|"                                  .
                "9(?:0(?:1[0-9]|2[0-9]|3[0-9]|4[0-9]|5[0-8])|100))"            .
  
           "|4(?:0(?:0(?:1[0-9]|2[0-7]|3[02-8]|4[1-3568]|5[0-79]|6[0-9])|"     .
                    "1(?:00|2[1-9]|3[1-9]|41))|"                               .
                "1(?:0(?:1[0-9]|2[0-35-9]|3[0-9]|4[02-689]|5[1-9])|100)|"      .
                "2(?:0(?:1[0-9]|2[0-8]|3[0-579]|4[0-9])|100)|"                 .
                "3(?:0(?:1[0-57-9]|2[0-24589]|3[025-9]|4[0-57-9]|"             .
                    "5[0-35689])|1(?:00|26))|"                                 .
                "4(?:0(?:1[0-24-69]|2[0-35-9]|3[03-579]|4[1-357-9])|100)|"     .
                "5(?:0(?:1[0-2457-9]|2[0-7]|3[0-9])|100)|"                     .
                "6(?:0(?:1[0-47-9]|2[02-9]|3[0-35-79]|4[0-9])|100)|"           .
                "7(?:0(?:1[0-9]|2[013578]|3[02459]|4[23])|1(?:00|2[12])|"      .
                    "8(?:14|2[24-6]|3[2-8]|4[1-3]|5[3-5]|6[1-7])|900)|"        .
                "8(?:0(?:1[0-578]|2[024-7])|100))"                             .
  
           "|5(?:0(?:0(?:1[02-489]|2[0-35-8]|3[1-9]|41|5[0-689]|6[0-8])|"      .
                    "1(?:00|2[1-79]|3[1-79]|4[1-5]))|"                         .
                "1(?:0(?:1[0-35-9]|2[0148]|3[014-79])|100)|"                   .
                "2(?:0(?:1[014-8]|2[0-24-9]|3[0-35-8]|4[13-8])|100)|"          .
                "3(?:0(?:1[1-9]|2[0-7]|3[014-7]|4[0-357-9])|100)|"             .
                "4(?:0(?:1[0-6]|2[136-9]|3[358])|100)|"                        .
                "5(?:0(?:1[0-689]|2[02357]|3[0-68]|4[0-2579]|5[14]|"           .
                    "6[0-24])|100)|"                                           .
                "6(?:0(?:1[0-279]|2[0-589]|3[0-8]|4[013-68])|1(?:00|"          .
                    "2[1-8]))|"                                                .
                "7(?:0(?:1[467]|2[0-3578]|3[0-46-9])|1(?:00|2[1-8]))|"         .
                "8(?:0(?:1[0-2457-9]|2[02-7]|3[1346-8]|4[02-5]|5[13-5])|"      .
                    "100)|"                                                    .
                "9(?:0(?:1[1356]|2[14-6])|100))"                               .
  
           "|6(?:0(?:0(?:1[013589]|2[0-24-7]|3[013-9]|4[01348])|1(?:00|"       .
                    "2[1-9]|31))|"                                             .
                "1(?:0(?:1[0-4]|2[0-689]|3[02-47-9]|4[0-9])|100)|"             .
                "2(?:0(?:1[0-2457-9]|2[0-24-9]|3[24-689])|100)|"               .
                "3(?:0(?:20|31|6[1-9]|7[1-9]|8[1-8]|9[1-6])|100|8(?:1[1-6]|"   .
                    "2[1-8]|3[1-9]|4[1-8]|5[1-8])|900)|"                       .
                "4(?:0(?:1[0-68]|2[013-8]|3[0-79]|4[0-79])|100)|"              .
                "5(?:0(?:1[0-579]|2[02-9])|1(?:00|2[1-9]|3[12]))|"             .
                "6(?:0(?:1[0-24-9]|2[0-36]|3[0-46-8]|4[0-7]|5[0-24])|100)|"    .
                "7(?:0(?:1[02-579]|2[0-9]|3[0-9]|4[013-9]|5[0-9]|"             .
                    "6[0-46-9])|100))"                                         .
  
           "|7(?:0(?:0(?:1[013-9]|2[0-9]|3[2378]|4[2-4]|5[46])|1(?:00|"        .
                    "2[1-9]|31))|"                                             .
                "1(?:0(?:1[0-9]|2[0-9]|3[0-9]|4[0-3578])|100)|"                .
                "2(?:0(?:1[02-9]|2[0-9])|100)|"                                .
                "3(?:0(?:1[0-9]|2[0-9]|3[0-9]|4[0-9]|5[0-9])|100)|"            .
                "4(?:0(?:1[0-9]|2[0-8])|100)|"                                 .
                "5(?:0(?:1[0-9]|2[0-9])|100)|"                                 .
                "6(?:01[1-7]|12[135]))"                                        .
  
           "|8(?:0(?:0(?:1[0-46-9]|2[0-9]|3[0-689]|4[0-24-9]|5[013-9]|"        .
                    "6[0-35-79]|7[013-9])|1(?:00|2[1-9]|3[1-9]|4[1-7]))|"      .
                "1(?:0(?:1[0-467]|2[0-578]|3[0-9]|4[0-4679]|5[0-9])|100)|"     .
                "2(?:0(?:1[0135-9]|2[0-9]|3[0-46-8])|100)|"                    .
                "3(?:0(?:1[0-8]|2[0-9]|3[0-24-9]|4[0-9]|5[0-9])|100)|"         .
                "4(?:0(?:1[0-9]|2[0-9]|3[0-9]|4[02-9]|5[0-35-79]|6[0-25-9]|"   .
                    "7[03-9]|8[0-8]|9[0-25689])|1(?:00|2[1-9]|3[1-5]))|"       .
                "5(?:0(?:1[0-8]|2[0-9]|3[0-9]|4[02-46-9]|5[0-9])|100)|"        .
                "6(?:0(?:1[0-9]|2[0-9]|3[0-9]|4[0-9]|7[0-57-9]|8[0-9]|"        .
                    "9[0-7])|1(?:00|70))|"                                     .
                "7(?:0(?:1[0-9]|2[0-46-9]|3[0-8]|4[0-8]|5[0-8]|6[0-24679]|"    .
                    "7[0-6])|100)|"                                            .
                "8(?:0(?:2[0-245]|4[0-24-79]|5[014-6]|6[02457-9]|70)|100|"     .
                    "8(?:1[1-9]|2[1-5]|3[1-8]|4[12])|900)|"                    .
                "9(?:0(?:1[0-8]|2[0-9]|3[0-9]|4[0-9]|5[0246-8]|6[02-59])|"     .
                    "1(?:00|2[1-9]|3[1-5])|8(?:1[2-9]|2[1-4]|3[1-4]|4[1-4]|"   .
                    "5[1-3]|6[1-46-8])|900))"                                  .
  
           "|9(?:0(?:0(?:1[0-9]|2[0-9]|3[0-9]|4[0-9])|1(?:00|2[1-9]|3[1-9]|"   .
                    "4[1-9]|51))|"                                             .
                "1(?:0(?:1[0-9]|2[0-9])|100)|"                                 .
                "2(?:0(?:1[0-9]|2[0-9])|100)|"                                 .
                "3(?:01[0-9]|100)|"                                            .
                "4(?:01[0-9]|100)|"                                            .
                "5(?:0(?:1[0-9]|2[0-2457-9]|3[0-9]|4[0-9])|1(?:00|2[1-9]|"     .
                    "31))|"                                                    .
                "6(?:01[0-9]|100)|"                                            .
                "7(?:01[0-9]|100)|"                                            .
                "8(?:0(?:2[0-35-9]|3[0-9]|4[0-9]|5[013-9]|6[0-9]|7[0-9])|"     .
                    "1(?:00|2[1-9]|3[1-9]|4[1-9]|5[1-9]|6[1-8])))"             .
      ")",
  
  
      #
      # The numbering system for postal codes of Liechtenstein is part of
      # the numbering system for Swiss postal codes. Four digits are used
      # and all postal codes in Liechtenstein start with 94, the third
      # digit an 8 or a 9.
      #
      # Data from: http://download.geonames.org/export/zip/LI.zip
      #
      # The file above does not include 9489 (instead, a different file
      # reports it to be in CH), but 9489 is the postal code for Schaan Log,
      # which is located in Liechtenstein.
      #
      # http://postal-codes.findthedata.com/l/57083/9489-Schaan-Log
      #
      Liechtenstein => "(?k:94(?:8[5-9]|9[0-8]))",
  
  
      #
      # https://www.post.lu/documents/10181/2314856/EptSggaCsv.csv/
      #           ee8fa0de-5e84-4e31-8cbd-b7b57679c21a?param=0.19755403072045696
      # (http://bit.ly/1PeTVqY)
      #
      Luxembourg =>
        "(?k:0(?:1(?:01|2[13-5]|3[12]|4[1-3]|61|7[13]|8[1-3]|9[12])|"          .
                "2(?:02|11|31|41|51|6[23]|91)|"                                .
                "3(?:2[1-5]|32|42|6[12]|72|8[1-3]|91)|"                        .
                "4(?:0[1-3]|1[12]|2[12]|4[1-356]|5[13]|6[2-4]|7[12]|8[12]|"    .
                    "9[1-7])|"                                                 .
                "5(?:21|3[12]|5[1-4]|6[12]|8[1-4])|"                           .
                "6(?:1[12]|4[1-4]|6[1-4]|7[12]|9[12])|"                        .
                "7(?:2[1-3]|5[1-4]|6[13]|7[12])|"                              .
                "8(?:0[1-9]|1[1-4]|2[1-3]|3[1-4]|41|5[2-5]|61|81)|"            .
                "9(?:0[134]|1[1-4]|2[12]|4[2-4]|5[1-4]|6[1-3]|7[1-3]|"         .
                    "8[1-3]|9[1-5]))"                                          .
  
           "|1(?:0(?:09|1[0-9]|2[0-9]|30|50|60|90)|"                           .
                "1(?:1[0-9]|2[0-9]|3[0-9]|4[0-9]|5[0-39]|6[01])|"              .
                "2(?:0[89]|1[0-9]|2[0-9]|3[0-9]|4[0-9]|5[0-9]|6[0-9]|"         .
                    "7[0-9]|8[0-3])|"                                          .
                "3(?:09|1[0-9]|2[0-9]|3[0-9]|4[0-9]|5[0-9]|6[0-9]|7[0-6])|"    .
                "4(?:09|1[1-9]|2[0-9]|3[0-4]|4[589]|5[0-9]|6[0-9]|7[0-9]|"     .
                    "8[0-4]|9[09])|"                                           .
                "5(?:0[89]|1[0-9]|2[0-9]|3[0-9]|4[0-9]|5[0-2])|"               .
                "6(?:1[013-9]|2[0-9]|3[0-9]|4[0-9]|5[0-6]|6[01]|70)|"          .
                "7(?:09|1[0-9]|2[0-9]|3[0-9]|4[0-9]|5[0-3])|"                  .
                "8(?:1[1-8]|2[0-2]|3[1-9]|4[0-356]|5[0-9]|6[0-8]|7[0-3]|"      .
                    "8[0-2]|9[6-9])|"                                          .
                "9(?:1[0-9]|2[0-9]|3[0-9]|4[0-9]|5[0-4]))"                     .
  
           "|2(?:0(?:1[0-9]|20|8[024-9]|9[013-9])|"                            .
                "1(?:1[1-9]|2[0-57-9]|3[0-57-9]|4[0-9]|5[0-9]|6[0-9]|"         .
                    "7[0-9]|8[0-4])|"                                          .
                "2(?:1[0-5]|2[0-9]|3[0-4]|4[0-3]|6[1-35-9]|7[0-3])|"           .
                "3(?:0[89]|1[0-9]|2[02-46-9]|3[0-9]|4[0-9]|5[0-9]|6[01]|70|"   .
                    "8[01])|"                                                  .
                "4(?:09|1[0-9]|2[02-9]|3[0-6]|4[0-9]|5[0-4])|"                 .
                "5(?:1[0-9]|2[0-9]|3[0-9]|4[0-9]|5[0-9]|6[0-7])|"              .
                "6(?:09|1[0-79]|2[0-9]|3[0-7]|5[1-4]|6[1-9]|7[0-4]|8[01])|"    .
                "7(?:1[1-9]|2[0-9]|3[0-46-9]|4[01]|6[1-4])|"                   .
                "8(?:50|60|8[07-9])|"                                          .
                "9(?:00|1[0-689]|2[0-25689]|3[0-9]|4[0-269]|5[0-8]|"           .
                    "6[014-68]|7[14-9]|8[0-8]|9[0-24-9]))"                     .
  
           "|3(?:2(?:0[15689]|1[0-9]|2[0-59]|3[0-9]|4[0-39]|5[0-9]|"           .
                    "6[015-79]|7[0-9]|8[0-8]|90)|"                             .
                "3(?:1[13-8]|2[0-9]|3[02-7]|4[015-9]|5[0-9]|6[0-9]|7[0-8]|"    .
                    "8[02-69]|9[0-8])|"                                        .
                "4(?:0[1-39]|1[0-9]|2[0-9]|3[0-3569]|4[0-9]|5[0-4]|6[0-9]|"    .
                    "7[0-6]|8[0-9]|9[0-3])|"                                   .
                "5(?:0[1-9]|1[0-7]|2[0-69]|3[0-29]|4[0-9]|5[0-5]|6[0-9]|"      .
                    "7[0-6]|8[2-589]|9[0-8])|"                                 .
                "6(?:01|1[1-7]|2[0-2]|3[015-8]|4[0-4]|5[0-8]|60|7[0-9]|"       .
                    "8[0-2])|"                                                 .
                "7(?:0[15]|1[0-9]|2[0-9]|3[013-9]|4[0-4]|5[0-5]|6[1-8]|"       .
                    "7[0-6]|8[0-246-9]|90)|"                                   .
                "8(?:01|1[0-9]|2[0-6]|3[0-9]|4[0-4]|5[0-9]|6[0-4]|7[0-9]|"     .
                    "8[0-4]|9[5-9])|"                                          .
                "9(?:0[19]|1[0-9]|2[0-9]|3[0-9]|4[013-5]|6[01]|8[05]))"        .
  
           "|4(?:0(?:0[1-9]|1[0-9]|2[0-9]|3[0-9]|4[0-9]|5[0-9]|6[0-9]|"        .
                    "7[0-4]|8[0-68])|"                                         .
                "1(?:0[0-35-9]|1[0-689]|2[0-356]|3[0-9]|4[0-39]|5[0-6]|"       .
                    "6[4-9]|7[0-9]|80)|"                                       .
                "2(?:0[1-9]|1[013467]|2[0-2]|3[0-9]|4[0-9]|5[0-6]|6[0-8]|"     .
                    "7[0-25-9]|8[0-39])|"                                      .
                "3(?:0[1-9]|1[04-9]|2[0-8]|3[0-7]|4[0-9]|5[0-5]|6[0-9]|"       .
                    "7[0-3]|8[0-5]|9[0-8])|"                                   .
                "4(?:0[125-9]|1[0-9]|2[0-39]|3[0-9]|4[0-9]|5[019]|6[0-9]|"     .
                    "7[05-9]|8[0-9]|9[0-49])|"                                 .
                "5(?:0[1-9]|1[0-9]|2[0-9]|3[0-9]|4[0-9]|5[0-9]|6[0-59]|"       .
                    "7[0-9]|8[0-3]|9[0-9])|"                                   .
                "6(?:0[1-9]|1[0-3]|2[0-9]|3[0-689]|4[0-9]|5[0136-8]|6[0-9]|"   .
                    "7[0-26-9]|8[0-9]|9[0-36-8])|"                             .
                "7(?:0[126-9]|1[0-9]|2[0-2]|3[0-9]|4[0-5]|5[0-9]|6[0-3]|"      .
                    "7[0-9]|8[0-6]|9[5-8])|"                                   .
                "8(?:0[124-9]|1[0-589]|2[02-69]|3[0-47-9]|4[02-9]|5[03]|"      .
                    "7[0-9]|8[0-9]|9[0-5])|"                                   .
                "9(?:0[126-9]|1[0-9]|2[0-9]|3[0-9]|4[0-9]|5[0-689]|6[0-9]|"    .
                    "7[0-9]|8[0-24-9]|9[0-9]))"                                .
  
           "|5(?:2(?:01|1[1-9]|2[0-2]|3[0-9]|4[0134]|5[0-6]|80|9[09])|"        .
                "3(?:1[024-8]|2[02468]|3[0-79]|4[0-2]|5[1-359]|6[0-9]|"        .
                    "7[0-8]|80)|"                                              .
                "4(?:0[1-578]|1[0-9]|2[1-79]|3[0-59]|4[0-7]|5[01]|6[056]|"     .
                    "7[01]|8[0-3589]|9[59])|"                                  .
                "5(?:0[15-7]|1[1-9]|2[0-3]|3[0-9]|4[0489]|5[0-9]|6[01]|"       .
                    "7[0-7])|"                                                 .
                "6(?:0[125]|1[0-9]|2[06-9]|3[0-9]|40|5[0-9]|7[015]|8[0-7]|"    .
                    "9[0-358])|"                                               .
                "7(?:01|1[0-46-9]|2[0-3]|30|4[01]|5[0-6]|6[0-2]|7[0-6])|"      .
                "8(?:0[189]|1[0-9]|2[0-689]|3[0-9]|4[0-46]|5[02-69]|6[0-9]|"   .
                    "7[0-68]|8[04-9]|9[0-389])|"                               .
                "9(?:4[0-3]|5[0-9]|6[0-49]|7[0-8]))"                           .
  
           "|6(?:1(?:01|1[1-9]|2[0-59]|3[0-9]|4[0-9]|5[05]|6[0-3569]|"         .
                    "7[015]|8[0-9]|9[05-7])|"                                  .
                "2(?:01|1[0-5]|25|3[01589]|4[0356]|5[0-25])|"                  .
                "3(?:01|1[0-5]|40|50|60|70|80)|"                               .
                "4(?:0[12689]|1[0-9]|2[0-3]|3[0-9]|4[0-35-9]|5[0-5]|6[0-9]|"   .
                    "7[0-9]|8[0-8]|9[0-79])|"                                  .
                "5(?:5[0-357-9]|6[02]|7[0-29]|8[0-35-7]|90)|"                  .
                "6(?:01|1[0-9]|2[0-3]|3[0-8]|4[5-9]|5[01]|6[013569]|7[0-8]|"   .
                    "8[0-9]|9[0-35])|"                                         .
                "7(?:01|1[1-9]|2[0-6]|3[0-9]|4[0-5]|5[0-9]|6[0-5]|7[0-9]|"     .
                    "8[0-6]|9[0-6])|"                                          .
                "8(?:15|3[0-9]|4[0-2]|5[0-28]|6[89]|7[01]|80)|"                .
                "9(?:0[156]|1[0-9]|2[1-356]|3[01349]|4[0-8]|5[0156]|"          .
                    "6[0-29]|7[0-9]|8[0-25-9]|9[0-25-9]))"                     .
  
           "|7(?:2(?:0[129]|1[0-9]|2[0-9]|3[0-9]|4[0-9]|5[0-9]|6[0-489]|"      .
                    "7[04])|"                                                  .
                "3(?:0[2-9]|1[0-9]|2[0-9]|3[0-9]|4[0-9]|5[0-9]|6[0-4]|"        .
                    "7[0-9]|8[0-4]|9[0-25-7])|"                                .
                "4(?:09|1[0-25-8]|2[013-5]|3[0-35]|4[0-9]|5[0-8]|6[0-5]|"      .
                    "7[0135]|8[0-2])|"                                         .
                "5(?:0[125-8]|1[1-9]|2[0-6]|3[1-9]|4[0-7]|5[3-9]|6[0-9]|"      .
                    "7[0-2]|9[0-9])|"                                          .
                "6(?:01|1[023589]|2[0-7]|3[3-69]|4[019]|5[0-3]|6[0-4]|"        .
                    "7[03]|8[01])|"                                            .
                "7(?:0[13]|1[0-6]|2[0-467]|3[0-57-9]|4[01]|5[089]|6[0-9]|"     .
                    "7[0-47-9]|8[0-9]|9[0-5]))"                                .
  
           "|8(?:0(?:0[125-9]|1[0-9]|2[0-9]|3[0-9]|4[0-9]|5[0-9]|6[0-9]|"      .
                    "7[0-9]|8[0-9]|9[0-9])|"                                   .
                "1(?:1[0-25-9]|2[013-9]|3[0-57-9]|4[0-25-79]|5[0-46-9]|"       .
                    "6[05-7]|79|8[0-9]|9[01])|"                                .
                "2(?:0[159]|1[0-9]|2[0-9]|3[0-9]|4[0-9]|5[0-589]|6[0-9]|"      .
                    "7[0-47-9]|8[0-9]|9[0-5])|"                                .
                "3(?:0[1-3689]|1[0-9]|2[0-9]|3[0-9]|4[0-5]|5[0-9]|6[0-9]|"     .
                    "7[0-689]|8[013-8]|9[0-689])|"                             .
                "4(?:01|1[0-5]|2[0-4]|3[5-8]|4[0-57-9]|5[0-3]|6[0-9]|"         .
                    "7[0-9]|80)|"                                              .
                "5(?:0[126-9]|1[01]|2[1-35-9]|3[0137-9]|4[0-6]|5[0-278]|"      .
                    "6[0-2])|"                                                 .
                "6(?:0[69]|1[0-5]|20)|"                                        .
                "7(?:0[15-8]|1[015]|20)|"                                      .
                "8(?:0[125689]|1[1-46-9]|2[0-6]|3[1-58]))"                     .
  
           "|9(?:0(?:0[1-46]|1[0-9]|2[0-9]|3[0-3]|4[0-8]|5[0-6]|6[0-9]|"       .
                    "7[0-2]|8[0-9]|9[0-489])|"                                 .
                "1(?:1[5-9]|2[0-9]|3[0-7]|4[024-7]|5[013-8]|6[013-9]|"         .
                    "7[0-35-79]|8[0-4689]|9[01])|"                             .
                "2(?:0[1-9]|1[0-8]|2[014-9]|3[0-9]|4[0-59]|5[0-9]|6[0-8]|"     .
                    "7[35-9]|8[0-9]|9[0-4])|"                                  .
                "3(?:30|40|5[0-79]|6[014-689]|7[0-35-8]|8[0-2]|9[0-25])|"      .
                "4(?:0[15-9]|1[0-24-9]|2[0-6]|40|5[1-9]|6[1-6])|"              .
                "5(?:0[126]|1[0-9]|2[0-3]|3[0-9]|4[0-5]|5[0-9]|60|7[0-9])|"    .
                "6(?:3[1-35-9]|4[013-578]|5[013-79]|6[0235689]|7[0-468]|"      .
                    "8[12479]|9[06])|"                                         .
                "7(?:0[16-9]|1[0-5]|3[78]|4[0-9]|5[1-9]|6[0-9]|7[0-69]|80)|"   .
                "8(?:0[15-9]|3[013-9]|4[01])|"                                 .
                "9(?:0[1-35-9]|1[0-3]|4[02-468]|5[0246]|6[02468]|7[0246]|"     .
                    "8[02]|9[0-39]))"                                          .
      ")",
  
  
      #
      # Postal codes of Monaco are part of the system used for France.
      # Monaco uses postal codes starting with 980. 98000 is for all
      # physical addresses, while numbers ending in 01 - 99 are reserved
      # for special deliveries.
      #
      # http://www.upu.int/fileadmin/documentsFiles/activities/
      #                                                addressingUnit/mcoEn.pdf
      #
      Monaco => "(?k:980[0-9][0-9])",
  
      #
      # Postal codes in Norway use 4 digits. Leading 0s happen, but not all
      # combinations are used.
      #
      # Data from: http://download.geonames.org/export/zip/GL.zip
      #
      Norway      =>
        "(?k:0(?:0(?:01|1[058]|2[14-68]|3[0-47]|4[05-8]|5[015]|60|80)|"        .
                "1(?:0[1-79]|1[0-9]|2[0-589]|3[0-9]|5[0-57-9]|6[0-24-9]|"      .
                    "7[0-9]|8[0-8]|9[0-68])|"                                  .
                "2(?:0[1-478]|1[1-8]|30|4[047]|5[0-9]|6[02-8]|7[0-9]|"         .
                    "8[0-467])|"                                               .
                "3(?:0[1-9]|1[13-9]|23|30|4[09]|5[0-9]|6[0-9]|7[0-9]|"         .
                    "8[0-3])|"                                                 .
                "4(?:0[1-689]|1[0-35]|2[1-4]|4[0-25]|5[0-24-9]|6[0-57-9]|"     .
                    "7[02-9]|8[0-9]|9[0-6])|"                                  .
                "5(?:0[1-9]|1[0-35-8]|20|40|5[0-9]|6[0-9]|7[0-9]|8[0-9]|"      .
                    "9[0-8])|"                                                 .
                "6(?:0[1-9]|1[1-9]|2[0-46]|5[0-9]|6[0-9]|7[0-9]|8[0-9]|"       .
                    "9[0-4])|"                                                 .
                "7(?:0[125]|1[02]|5[0-8]|6[03-8]|7[0-9]|8[1-9]|9[01])|"        .
                "8(?:0[15-7]|40|5[0-8]|6[0-4]|7[0-7]|8[0-4]|9[01])|"           .
                "9(?:0[1-578]|1[3-5]|5[0-9]|6[02-489]|7[0-35-9]|8[0-8]))"      .
  
           "|1(?:0(?:0[135-9]|11|5[1-6]|6[1-57-9]|71|8[1346-9])|"              .
                "1(?:0[129]|12|5[0-8]|6[0-9]|7[026-9]|8[12457-9])|"            .
                "2(?:0[1-57]|1[45]|5[0-9]|6[236]|7[0-589]|8[13-6]|9[0145])|"   .
                "3(?:0[0-79]|1[1-46-9]|2[1-9]|3[0-9]|4[0-24689]|5[0-46-9]|"    .
                    "6[0-9]|7[1-35-9]|8[013-9]|9[0-79])|"                      .
                "4(?:0[0-9]|1[0-9]|2[019]|3[0-2]|4[0-9]|5[013-578]|6[89]|"     .
                    "7[0-9]|8[0-8])|"                                          .
                "5(?:0[1-4689]|1[0-9]|2[0-689]|3[0-9]|4[015]|5[056]|60|70|"    .
                    "8[01]|9[0-36-9])|"                                        .
                "6(?:0[1-9]|1[02-9]|2[014-689]|3[02-46-9]|4[0-2]|"             .
                    "5[013-57-9]|6[1-7]|7[0-35689]|8[02-4]|9[02])|"            .
                "7(?:0[1-9]|1[0-589]|2[0-7]|3[03-589]|4[0235-7]|5[1-479]|"     .
                    "6[013-9]|7[126-9]|8[1-9]|9[0-4689])|"                     .
                "8(?:0[1-9]|1[1-6]|2[0357]|3[0-3]|5[019]|6[0167]|7[0158]|"     .
                    "80|9[0-3])|"                                              .
                "9(?:0[013]|1[0-2467]|2[013-9]|3[01]|4[01]|5[04]|6[013]|"      .
                    "7[01]))"                                                  .
  
           "|2(?:0(?:0[013-9]|1[0-9]|2[0-8]|3[0-6]|4[01]|5[0-8]|6[0-26-9]|"    .
                    "7[0-46]|8[01]|9[0-3])|"                                   .
                "1(?:0[01]|1[046]|2[03]|3[034]|5[01]|6[0-24-6]|70)|"           .
                "2(?:0[1-689]|1[0-46-9]|2[03-6]|3[0235]|40|56|6[014-6]|"       .
                    "7[01]|8[03])|"                                            .
                "3(?:0[1-9]|1[25-9]|2[0-6]|3[024-8]|4[0145]|5[035]|6[045]|"    .
                    "72|8[0-9]|9[01])|"                                        .
                "4(?:0[1-35-9]|1[0-2568]|2[0-357-9]|3[025-8]|4[0368]|5[01]|"   .
                    "60|7[6-8]|8[015])|"                                       .
                "5(?:0[01]|1[02]|4[024]|5[025]|6[01]|8[0-24])|"                .
                "6(?:0[1-9]|1[0-9]|2[4-69]|3[0-79]|4[0235-9]|5[1-36-9]|"       .
                    "6[0-9]|7[02-7]|8[02-8]|9[03-5])|"                         .
                "7(?:1[1-8]|20|30|4[023]|50|60|70)|"                           .
                "8(?:0[1-9]|1[015-9]|2[0-257]|3[0-26-9]|4[036-9]|5[013478]|"   .
                    "6[0-2467]|7[09]|8[0-2]|9[03])|"                           .
                "9(?:0[017]|1[078]|2[039]|3[03679]|4[03]|5[02-49]|6[067]|"     .
                    "7[3-57]|85))"                                             .
  
           "|3(?:0(?:0[1-9]|1[1-9]|2[1-9]|3[0-9]|4[0-8]|5[013-8]|6[01]|"       .
                    "7[015]|8[0-9]|9[025])|"                                   .
                "1(?:0[13-9]|1[0-9]|2[0-8]|3[1-357-9]|4[0-58]|5[0-47-9]|"      .
                    "6[0-9]|7[0-9]|8[0-9]|9[1-69])|"                           .
                "2(?:0[1-9]|1[0-9]|2[0-9]|3[0-9]|4[0-69]|5[1-9]|6[0-57-9]|"    .
                    "7[014-7]|8[0-245]|9[0-24-7])|"                            .
                "3(?:0[01]|2[0-2]|3[01]|4[0-2]|5[01589]|6[01]|7[01])|"         .
                "4(?:0[1-9]|1[0-4]|2[015-8]|3[01]|4[0-2]|7[0-24-8]|8[0-4]|"    .
                    "9[01])|"                                                  .
                "5(?:0[1-47]|1[0-9]|2[0-689]|3[013-9]|4[014]|5[01]|6[01]|"     .
                    "7[015-79]|8[018]|9[35])|"                                 .
                "6(?:0[1-689]|1[0-9]|2[0-46-9]|3[0-2]|4[6-8]|5[0268]|"         .
                    "6[0156]|7[1-9]|8[0134]|9[0-27])|"                         .
                "7(?:0[1-578]|1[0-9]|2[0-9]|3[0-9]|4[0-46-9]|5[03]|6[06]|"     .
                    "70|8[01357-9]|9[0-68])|"                                  .
                "8(?:0[0-5]|1[0-2]|2[05]|3[0-6]|4[01489]|5[03-5]|64|70|"       .
                    "8[02-8]|9[0135])|"                                        .
                "9(?:0[1-6]|1[0-9]|2[0-24589]|3[013679]|4[0-46-9]|50|"         .
                    "6[05-7]|70|9[13-9]))"                                     .
  
           "|4(?:0(?:0[1-9]|1[0-9]|2[0-9]|3[1-6]|4[1-9]|5[0-9]|6[4-9]|"        .
                    "7[06-9]|8[1-9]|9[0-9])|"                                  .
                "1(?:0[02]|1[09]|2[0346-9]|3[0479]|4[68]|5[02-4689]|"          .
                    "6[01347-9]|7[034]|8[027]|98)|"                            .
                "2(?:0[0189]|3[03-579]|4[04]|50|6[0245]|7[024-6]|80|"          .
                    "9[14-9])|"                                                .
                "3(?:0[1-9]|1[0-9]|2[1-9]|3[02359]|4[0-9]|5[2-8]|"             .
                    "6[02-57-9]|7[0-689]|8[0179]|9[1-8])|"                     .
                "4(?:0[0-3]|20|3[2468]|4[013]|6[0235]|73|8[045]|9[0-2])|"      .
                "5(?:0[1-69]|1[3-79]|2[0-589]|3[246]|4[04]|5[0-478]|6[03]|"    .
                    "7[5-79]|8[068]|9[056])|"                                  .
                "6(?:0[4-689]|1[0-9]|2[0-689]|3[0-9]|4[05-7]|5[16-9]|"         .
                    "6[1-6]|7[0-9]|8[1-9]|9[13-9])|"                           .
                "7(?:0[0-35]|15|2[04]|3[03-57]|4[12578]|5[4-6]|6[068]|70|"     .
                    "80|9[0-5])|"                                              .
                "8(?:0[1-489]|1[025-8]|2[013-578]|3[024689]|4[1-46-9]|"        .
                    "5[1-9]|6[1-589]|7[06-9]|8[4-9]|9[1-468])|"                .
                "9(?:0[0-29]|1[0256]|20|34|5[0-35]|7[1-4]|8[05]|9[034]))"      .
  
           "|5(?:0(?:0[3-9]|1[0-9]|2[0-2]|3[1-9]|4[1-35]|5[2-9]|6[378]|"       .
                    "7[235]|8[129]|9[346-9])|"                                 .
                "1(?:0[14-9]|1[13-9]|2[124]|3[0-24-7]|4[1-8]|5[1-5]|6[0-5]|"   .
                    "7[0-46-9]|8[34])|"                                        .
                "2(?:0[0-36-9]|1[0-25-8]|2[1-9]|3[0-25-9]|4[34]|5[1-47-9]|"    .
                    "6[0-578]|8[1-6]|9[139])|"                                 .
                "3(?:0[0-9]|1[04589]|2[1-35-79]|3[13-7]|4[1-35-7]|"            .
                    "5[03-578]|6[0356]|7[1489]|8[0-24578]|9[2-46-9])|"         .
                "4(?:0[1-46-9]|1[0-9]|2[0378]|3[07]|4[03-579]|5[0-57-9]|"      .
                    "6[02-5]|7[02-6]|8[046]|9[89])|"                           .
                "5(?:0[1-9]|1[124-9]|2[1-357-9]|3[1-8]|4[124-9]|5[01459]|"     .
                    "6[0135-8]|7[04-68]|8[02-689]|9[013-68])|"                 .
                "6(?:0[0-245]|1[024]|2[06-9]|3[025-7]|4[0-35-79]|5[023]|"      .
                    "8[0357]|9[03-6])|"                                        .
                "7(?:0[0-9]|1[0-589]|2[1-9]|3[01346]|4[1-35-9]|5[0-2]|"        .
                    "6[03]|7[036-9]|8[0-8])|"                                  .
                "8(?:0[3-9]|1[0-9]|2[0-24589]|3[1568]|4[157-9]|5[1-47-9]|"     .
                    "6[1-489]|7[1-36-9]|8[1246-9]|9[23569])|"                  .
                "9(?:0[2-46-8]|1[1-8]|3[16-9]|4[1378]|5[1-7]|6[0-267]|"        .
                    "7[07-9]|8[13467]|9[134]))"                                .
  
           "|6(?:0(?:0[1-9]|1[0-9]|2[0-68]|3[05-9]|4[03-8]|5[0-257-9]|"        .
                    "6[02-57-9]|7[06]|8[02-579]|9[0-24-689])|"                 .
                "1(?:0[0-6]|10|20|3[39]|4[0-469]|5[0-6]|6[0156]|7[04]|"        .
                    "8[34]|9[06])|"                                            .
                "2(?:0[01]|1[0-68]|2[024]|3[089]|4[09]|5[09]|6[03-5]|7[02]|"   .
                    "8[0-35]|9[02-4])|"                                        .
                "3(?:0[01]|1[05]|20|3[09]|50|6[034]|8[67]|9[0-9])|"            .
                "4(?:0[1-57-9]|1[0-689]|2[1-359]|3[013-6]|4[03-57]|5[03-7]|"   .
                    "6[0-2]|7[0256]|8[01346-8]|9[0349])|"                      .
                "5(?:0[1-46-9]|1[0-24-8]|2[0-59]|3[089]|7[01]|90)|"            .
                "6(?:0[01]|1[0-3]|2[0289]|3[0136-9]|4[02-5]|5[0235-9]|"        .
                    "7[04]|8[036-9]|9[0347-9])|"                               .
                "7(?:0[0-478]|1[013-9]|2[136-9]|3[0147]|4[01]|5[01]|6[13]|"    .
                    "7[0-26-9]|8[1-489]|9[1-35-9])|"                           .
                "8(?:0[0-9]|1[0-57-9]|2[1-36-9]|4[1378]|5[1-689]|6[13689]|"    .
                    "7[0-35-9]|8[124-8]|9[13-689])|"                           .
                "9(?:0[0-39]|1[24-9]|2[146-9]|4[0-2467]|5[1378]|6[1346-9]|"    .
                    "7[13578]|8[0-8]|9[1356]))"                                .
  
           "|7(?:0(?:0[3-6]|1[0-689]|2[0-9]|3[0-46-9]|4[0-9]|5[0-46-9]|"       .
                    "7[024589]|8[0-389]|9[127-9])|"                            .
                "1(?:0[015]|1[02-49]|2[015-79]|30|4[02]|5[02369]|6[05-9]|"     .
                    "7[06-8]|80|9[04])|"                                       .
                "2(?:0[0136]|1[1-3]|2[13478]|3[124-689]|4[0-367]|5[025-79]|"   .
                    "6[013468]|7[03]|8[024-9]|9[0158])|"                       .
                "3(?:0[0-2]|1[05689]|2[0179]|3[1-68]|4[0-35]|5[013-578]|61|"   .
                    "7[024]|8[03467]|9[1-37-9])|"                              .
                "4(?:0[0-9]|1[0-9]|2[0-24-9]|3[0-9]|4[0-9]|5[0-9]|"            .
                    "6[1-35-9]|7[0-9]|8[0-9]|9[0-7])|"                         .
                "5(?:0[0-9]|1[02-479]|2[059]|3[013]|4[019]|5[01]|6[0236]|"     .
                    "70|8[0134]|9[016])|"                                      .
                "6(?:0[0-9]|1[09]|2[02-49]|3[0-4]|5[0-8]|60|7[01]|90)|"        .
                "7(?:0[1-57-9]|1[0-8]|2[4-69]|3[024-9]|4[024-68]|5[01]|"       .
                    "6[01]|7[017]|9[0167])|"                                   .
                "8(?:0[0-58]|1[07-9]|2[02]|56|6[0349]|7[013]|8[24]|"           .
                    "9[02368])|"                                               .
                "9(?:0[01]|4[04]|50|60|7[01367]|8[0-25]|9[034]))"              .
  
           "|8(?:0(?:0[1-9]|1[0-69]|2[0-36-9]|3[0-278]|4[17-9]|5[068]|"        .
                    "6[34]|7[0-69]|8[46-9]|9[1-8])|"                           .
                "1(?:0[0238]|1[048]|2[08]|3[0568]|4[0569]|5[017-9]|6[018]|"    .
                    "7[08]|8[124-9]|9[035-8])|"                                .
                "2(?:0[0-35-9]|1[014589]|2[06]|3[0-3]|5[0156]|6[0146]|"        .
                    "7[013-68]|8[135689]|9[01478])|"                           .
                "3(?:0[0159]|1[0-7]|2[02-68]|40|5[27]|60|7[0236-8]|"           .
                    "8[02478]|9[0238])|"                                       .
                "4(?:0[0-9]|1[0-6]|2[68]|3[0289]|4[57]|5[059]|6[59]|7[05]|"    .
                    "8[013-589]|93)|"                                          .
                "5(?:0[1-9]|1[02-8]|2[023]|3[013-69]|4[036]|9[01])|"           .
                "6(?:0[1-478]|1[03-8]|2[246]|3[048]|4[0-36-8]|5[124-9]|"       .
                    "6[013-6]|72|8[01]|9[01])|"                                .
                "7(?:0[01]|2[03-5]|3[0235]|4[023]|5[02-4]|6[12467]|70)|"       .
                "8(?:0[0-59]|13|2[07]|30|4[24]|5[0-24]|6[015]|70|80|"          .
                    "9[0-27])|"                                                .
                "9(?:0[0-24-9]|10|2[0-2]|6[01]|76|8[015]))"                    .
  
           "|9(?:0(?:0[6-9]|1[0-9]|2[02479]|3[0478]|4[02369]|5[05-79]|"        .
                    "6[02489])|"                                               .
                "1(?:0[0-8]|1[089]|2[08]|3[0-24-8]|4[0-46-8]|5[1-369]|"        .
                    "6[1-39]|8[0-24-79]|9[02-57])|"                            .
                "2(?:40|5[1-9]|6[0-35-9]|7[0-9]|8[0-8]|9[0-4689])|"            .
                "3(?:0[02-6]|1[0156]|2[12569]|3[4-6]|5[0578]|6[05]|"           .
                    "7[02369]|8[0-24-9]|9[1-35])|"                             .
                "4(?:0[2-9]|1[1459]|2[03-7]|3[069]|4[0-8]|5[013-5]|"           .
                    "7[01569]|8[0-9]|9[6-8])|"                                 .
                "5(?:0[1-9]|1[0-9]|2[015]|3[1-36]|4[05]|5[01]|8[02-7]|"        .
                    "9[035])|"                                                 .
                "6(?:0[09]|1[056]|2[014]|5[07]|64|7[02]|9[0-2])|"              .
                "7(?:0[09]|1[0-7]|22|3[05]|4[02]|5[01]|6[03-58]|7[0-35]|82|"   .
                    "90)|"                                                     .
                "8(?:0[02]|1[015]|2[06]|4[056])|"                              .
                "9(?:00|1[024-7]|25|3[05]|5[01]|60|8[0-2]|9[01]))"             .
      ")",
  
  
      #
      # San Marino uses a slice of the postal codes for Italy. 
      # Any postal code starting with 4789, followed by another 
      # digit is from San Marino
      #
      # Data: http://download.geonames.org/export/zip/SM.zip
      #
     'San Marino' => "(?k:4789[0-9])",
  
  
      Spain       =>  "(?k:(?k:0[1-9]|[1-4][0-9]|5[0-2])(?k:[0-9])(?k:[0-9]{2}))",
                      # Five digits, first two indicate the province.
                      # Third digit: large town, main delivery rounds.
                      # Last 2 digits: delivery area, secondary delivery route
                      #                or link to rural areas.
  
      #
      # Switzerland uses four digit postal codes; leading 0s are not used.
      # Not every combination is in use. Postal codes starting with 948 and
      # 949 are used by Liechtenstein, and will not be recognized by the
      # pattern below.
      #
      # Data from: http://download.geonames.org/export/zip/CH.zip
      #
      Switzerland =>
        "(?k:1(?:0(?:0[0-9]|1[0-2457-9]|2[02-9]|3[0-9]|4[0-7]|5[2-589]|"       .
                    "6[1-368]|7[0-36-8]|8[0-58]|9[0-8])|"                      .
                "1(?:1[02-7]|2[1-8]|3[124-6]|4[1-9]|6[2-9]|7[02-6]|8[02-9]|"   .
                    "9[5-7])|"                                                 .
                "2(?:0[0-9]|1[1-9]|2[02-8]|3[1-4679]|4[0-8]|5[1-8]|6[0-9]|"    .
                    "7[0-9]|8[13-9]|9[0-9])|"                                  .
                "3(?:0[02-8]|1[0-35-8]|2[0-69]|3[078]|4[1-8]|5[02-8]|"         .
                    "7[2-7])|"                                                 .
                "4(?:0[014-9]|1[0235-8]|2[0-9]|3[0-9]|4[0-356]|5[02-4]|"       .
                    "6[2-48]|7[03-5]|8[2-69])|"                                .
                "5(?:09|1[02-5]|2[1-9]|3[02-8]|4[1-5]|5[1-5]|6[2-8]|"          .
                    "8[02-9]|95)|"                                             .
                "6(?:0[7-9]|1[0-9]|2[3-8]|3[0-8]|4[2-9]|5[1-46-9]|"            .
                    "6[0135-79]|7[03-9]|8[0-9]|9[0-24-79])|"                   .
                "7(?:0[0-2457-9]|1[2-9]|2[0-8]|3[0-8]|4[0-24-9]|5[2-467]|"     .
                    "6[23]|7[2-6]|8[2-9]|9[1-7])|"                             .
                "8(?:0[0-9]|1[14-8]|2[02-4]|3[23]|4[4-7]|5[2-46]|6[02-9]|"     .
                    "7[0-5]|8[0245]|9[0-35-9])|"                               .
                "9(?:0[2-8]|1[1-489]|2[0-35-9]|3[2-46-8]|4[1-8]|5[013578]|"    .
                    "6[1-9]|7[1-8]|8[1-8]|9[1-467]))"                          .
  
           "|2(?:0(?:0[0-46-9]|1[02-79]|2[2-578]|3[4-7]|4[236]|5[2-46-8]|"     .
                    "6[3578]|7[2-5]|8[78])|"                                   .
                "1(?:0[358]|1[2-7]|2[3467]|49)|"                               .
                "20[6-8]|3(?:0[0-46]|1[468]|2[25]|3[368]|4[05]|5[034]|"        .
                    "6[02-4])|"                                                .
                "4(?:0[056]|1[46])|"                                           .
                "5(?:0[0-5]|1[02-8]|2[035]|3[2-8]|4[02-5]|5[2-8]|6[02-5]|"     .
                    "7[25-7])|"                                                .
                "6(?:0[3-8]|1[02356])|"                                        .
                "7(?:1[02-8]|2[023]|3[23568]|4[02-8]|62)|"                     .
                "8(?:0[0235-7]|1[2-4]|2[2-9]|3[02]|4[23]|5[2-7]|6[34]|73|"     .
                    "8[2-9])|"                                                 .
                "9(?:0[02-8]|1[24-6]|2[2-6]|3[235]|4[2-467]|5[02-4]))"         .
  
           "|3(?:0(?:0[0-8]|1[0-57-9]|2[0479]|3[02-9]|4[0-9]|5[02-4]|"         .
                    "6[35-8]|7[0-8]|8[2-9]|9[5-9])|"                           .
                "1(?:1[0-6]|2[2-8]|32|4[4578]|5[02-9]|7[2-9]|8[2-6])|"         .
                "2(?:0[2-8]|1[02-6]|2[56]|3[2-8]|5[0-7]|6[2-46-8]|7[0-4]|"     .
                    "8[02-6]|9[2-8])|"                                         .
                "3(?:0[235-9]|1[2-57]|2[1-6]|6[0235-8]|7[2-7]|80)|"            .
                "4(?:0[0-2]|1[2-9]|2[1-9]|3[2-9]|5[2-7]|6[2-5]|7[2-6])|"       .
                "5(?:0[346-8]|1[023]|3[1-8]|43|5[0-35-7])|"                    .
                "6(?:0[0-57-9]|1[2-9]|2[2-9]|3[1-68]|4[5-7]|5[2-8]|6[1-5]|"    .
                    "7[1-4])|"                                                 .
                "7(?:0[02-7]|1[13-8]|2[2-5]|5[2-8]|6[2-6]|7[0-35-8]|8[0-5]|"   .
                    "92)|"                                                     .
                "8(?:0[013-7]|1[2-68]|2[2-6]|5[2-8]|6[02-4])|"                 .
                "9(?:0[0-8]|1[0-46-9]|2[02-9]|3[0-57-9]|4[02-9]|5[1-7]|"       .
                    "6[0135-8]|7[0-9]|8[2-9]|9[1-9]))"                         .
  
           "|4(?:0(?:0[0-57-9]|1[0-35-9]|2[03-5]|3[0-59]|4[0-2]|5[1-9]|65|"    .
                    "7[058]|8[0-9]|9[1-6])|"                                   .
                "1(?:0[1-8]|1[24-8]|2[3-7]|3[23]|4[2-8]|53)|"                  .
                "2(?:0[2-46-8]|2[2-9]|3[2-4]|4[2-7]|5[2-4])|"                  .
                "3(?:0[2-5]|1[02-7]|2[2-5]|3[2-4])|"                           .
                "4(?:02|1[0-9]|2[1-6]|3[1-8]|4[1-8]|5[0-35-8]|6[0-9]|"         .
                    "9[2-7])|"                                                 .
                "5(?:0[0-39]|1[2-5]|2[2-58]|3[2-9]|4[23]|5[1-46-8]|6[2-6]|"    .
                    "7[1346-9]|8[1-8])|"                                       .
                "6(?:0[0139]|1[1-8]|2[0-689]|3[02-4]|40|5[2-8]|6[35])|"        .
                "7(?:0[2-4]|1[02-9])|"                                         .
                "8(?:0[0-35-9]|1[2-4]|5[236])|"                                .
                "9(?:0[0-2]|1[1-79]|2[2-4]|3[2-8]|4[2-4]|5[02-5]))"            .
  
           "|5(?:0(?:0[014]|1[02-578]|2[2-8]|3[2-7]|4[02-46]|5[346-8]|"        .
                    "6[2-4]|7[02-9]|8[02-5])|"                                 .
                "1(?:0[235-8]|1[236])|"                                        .
                "2(?:0[01]|1[023]|2[2-5]|3[2-7]|4[2-6]|7[2-7])|"               .
                "3(?:0[013-6]|1[2-8]|2[2-6]|3[02-4])|"                         .
                "4(?:0[0-24-68]|1[235-7]|2[0356]|3[0-26]|4[2-5]|5[2-4]|"       .
                    "6[2-7])|"                                                 .
                "5(?:0[2-7]|12|2[245])|"                                       .
                "6(?:0[013-8]|1[0-9]|2[0-8]|3[02467]|4[2-7])|"                 .
                "7(?:0[2-8]|12|2[2-8]|3[2-7]|4[256]))"                         .
  
           "|6(?:0(?:0[02-9]|1[0-9]|2[0-8]|3[0-9]|4[2-578]|5[2356]|"           .
                    "6[0-46-8]|7[2-48]|8[3-6])|"                               .
                "1(?:0[2356]|1[02-4]|2[2356]|3[023]|4[2-7]|5[2-46]|"           .
                    "6[0-367]|7[034]|82|9[267])|"                              .
                "2(?:0[3-8]|1[0-8]|2[12]|3[1-6]|4[2-8]|5[23]|6[02-5]|"         .
                    "7[4-7]|8[013-9]|9[45])|"                                  .
                "3(?:0[0-4]|1[02-57-9]|3[0-3]|4[0-69]|5[346]|6[235]|7[0-7]|"   .
                    "8[236-8]|9[01])|"                                         .
                "4(?:0[2-5]|1[04-8]|2[2-4]|3[0-468]|4[0-3]|5[24]|6[0-9]|"      .
                    "7[2-6]|8[2457]|9[013])|"                                  .
                "5(?:0[0136]|1[1-8]|2[3-8]|3[2-578]|4[0-9]|5[6-8]|6[235]|"     .
                    "7[1-9]|8[2-4]|9[02-9])|"                                  .
                "6(?:0[0-245]|1[1-468]|22|3[1-7]|4[4-8]|5[2-9]|6[1-4]|"        .
                    "7[02-8]|8[2-5]|9[02-6])|"                                 .
                "7(?:0[2357]|1[03-9]|2[0-4]|4[2-9]|6[034]|7[2-7]|8[01])|"      .
                "8(?:0[2-9]|1[04-8]|2[1-35-8]|3[02-9]|5[02-5]|6[2-7]|"         .
                    "7[2-57]|83)|"                                             .
                "9(?:0[0-8]|1[1-9]|2[124-9]|3[02-9]|4[2-9]|5[0-9]|6[2-8]|"     .
                    "7[46-9]|8[0-46-9]|9[0-9]))"                               .
  
           "|7(?:0(?:0[0-467]|1[2-9]|2[36-9]|3[12]|5[06-8]|6[2-4]|7[4-8]|"     .
                    "8[2-4])|"                                                 .
                "1(?:0[4679]|1[0-6]|2[26-8]|3[02-8]|4[1-9]|5[1-9]|6[2-8]|"     .
                    "7[2-6]|8[02-9])|"                                         .
                "2(?:0[1-68]|1[2-5]|2[02-468]|3[1-35]|4[0-79]|5[02]|6[05]|"    .
                    "7[026-8])|"                                               .
                "3(?:0[2-467]|1[02-57]|2[03-6])|"                              .
                "4(?:0[2-578]|1[1-9]|2[1-8]|3[0-8]|4[02-8]|5[0-9]|6[02-4]|"    .
                    "7[237]|8[24]|9[2-4])|"                                    .
                "5(?:0[02-5]|1[2-7]|2[2-7]|3[02-7]|4[2356]|5[0-46-9]|"         .
                    "6[023])|"                                                 .
                "6(?:0[2-68]|10)|"                                             .
                "7(?:10|4[1-8]))"                                              .
  
           "|8(?:0(?:0[0-68]|1[0-256]|2[0-467]|3[0-46-9]|4[0-24-9]|"           .
                    "5[0-357-9]|6[013-68]|7[0145]|8[015-8]|9[0-3689])|"        .
                "1(?:0[2-9]|1[2-578]|2[1-7]|3[02-6]|4[23]|5[2-8]|6[24-6]|"     .
                    "7[2-5]|8[0-57]|9[2-7])|"                                  .
                "2(?:0[0-578]|1[02-9]|2[2-68]|3[1-689]|4[0-35-8]|5[2-59]|"     .
                    "6[0-9]|7[2-4]|8[05])|"                                    .
                "3(?:0[1-9]|1[0-2457]|2[025]|3[0-25]|4[02-5]|5[2-7]|6[023]|"   .
                    "7[0-246])|"                                               .
                "4(?:0[0-24-689]|1[0-68]|2[1-8]|4[247]|5[0-57-9]|6[0-8]|"      .
                    "7[124-9]|8[2-46-9]|9[2-9])|"                              .
                "5(?:0[0-35-8]|1[024]|2[02-6]|3[025-7]|4[02-8]|5[2-68]|"       .
                    "6[014-6]|7[02-7]|8[0-9]|9[02-9])|"                        .
                "6(?:0[02-8]|1[02-8]|2[0-7]|3[02-9]|4[056])|"                  .
                "7(?:0[02-46-8]|1[2-8]|2[235-7]|3[02-57-9]|40|5[0-9]|"         .
                    "6[25-7]|7[2-57]|8[2-4])|"                                 .
                "8(?:0[0-8]|1[02356]|2[045]|3[2-6]|4[0-79]|5[2-8]|6[2-8]|"     .
                    "7[2-47-9]|8[0-9]|9[02-8])|"                               .
                "9(?:0[1-9]|1[0-9]|2[56]|3[2-4]|42|5[1-7]|6[24-7]|70))"        .
  
           "|9(?:0(?:0[0146-9]|1[0-6]|2[02-9]|3[02-8]|4[2-4]|5[02-8]|"         .
                    "6[2-4])|"                                                 .
                "1(?:0[0-578]|1[2-6]|2[235-7])|"                               .
                "2(?:0[013-5]|1[2-7]|2[035]|3[01]|4[02-9])|"                   .
                "3(?:0[014-68]|1[2-5]|2[0235-7])|"                             .
                "4(?:0[0-5]|1[0134]|2[2-8]|3[04-7]|4[2-5]|5[0-3]|6[2-9]|"      .
                    "7[0-35-9])|"                                              .
                "5(?:0[0-46-8]|1[02457]|2[3-7]|3[2-6]|4[235-8]|5[2-6]|"        .
                    "6[25]|73)|"                                               .
                "6(?:0[1246-8]|1[2-5]|2[0-2]|3[013]|4[23]|5[0-25-8]))"         .
      ")",
  
  
      #
      # Vatican City uses a single postal code, taken from the Italian
      # system for postal codes; and this code is shared with parts of Rome.
      #
      # Data from: http://download.geonames.org/export/zip/CH.zip
      #
     'Vatican City' => "(?k:00120)",
  
  );
  
  my %alternatives = (
      Australia    => [qw /Australian/],
      France       => [qw /French/],
      Germany      => [qw /German/],
  );
  
  
  while (my ($country, $zip) = each %zip) {
      my @names = ($country);
      push @names => @{$alternatives {$country}} if $alternatives {$country};
      foreach my $name (@names) {
          my $pat_name = $name eq "Denmark" && $] < 5.00503
                         ?   [zip => $name, qw /-country=/]
                         :   [zip => $name, qw /-prefix= -country=/];
          pattern name    => $pat_name,
                  create  => sub {
                      my $pt  = _t $_ [1] {-prefix};
  
                      my $cn  = _c $country => $_ [1] {-country};
                      my $pfx = "(?:(?k:$cn)-)";
  
                      "(?k:$pfx$pt$zip)";
                  },
                  ;
      }
  }
  
  
  # Postal codes of the form 'DDDD LL', with F, I, O, Q, U and Y not
  # used, SA, SD and SS unused combinations, and the first digit
  # cannot be 0. No specific meaning to the letters or digits.
  foreach my $country (qw /Netherlands Dutch/) {
      pattern name   => ['zip', $country => qw /-prefix= -country=/, "-sep= "],
              create => sub {
                  my $pt  = _t $_ [1] {-prefix};
  
                  # Unused letters: F, I, O, Q, U, Y.
                  # Unused combinations: SA, SD, SS.
                  my $num =  '[1-9][0-9]{3}';
                  my $let =  '[A-EGHJ-NPRTVWXZ][A-EGHJ-NPRSTVWXZ]|' .
                             'S[BCEGHJ-NPRTVWXZ]';
  
                  my $sep = __ $_ [1] {-sep};
                  my $cn  = _c Netherlands => $_ [1] {-country};
                  my $pfx = "(?:(?k:$cn)-)";
  
                  "(?k:$pfx$pt(?k:(?k:$num)(?k:$sep)(?k:$let)))";
              },
              ;
  }
  
  
  # Postal codes of the form 'DDDDD' or 'DDDDD-DDDD'. All digits are used,
  # none carry any specific meaning.
  pattern name    => [qw /zip US -prefix= -country= -extended= -sep=-/],
          create  => sub {
              my $pt  = _t $_ [1] {-prefix};
              my $et  = _t $_ [1] {-extended};
  
              my $sep = __ $_ [1] {-sep};
  
              my $cn  = _c USA => $_ [1] {-country};
              my $pfx = "(?:(?k:$cn)-)";
              # my $zip = "(?k:[0-9]{5})";
              # my $ext = "(?:(?k:$sep)(?k:[0-9]{4}))";
              my $zip = "(?k:(?k:[0-9]{3})(?k:[0-9]{2}))";
              my $ext = "(?:(?k:$sep)(?k:(?k:[0-9]{2})(?k:[0-9]{2})))";
  
              "(?k:$pfx$pt(?k:$zip$ext$et))";
          },
          ;
  
  
  
  
  #
  # Postal codes are four digits, but not all combinations are used.
  #
  # Valid codes from:
  #       https://postcode.auspost.com.au/free_display.html?id=1
  # 
  pattern name   => ['zip', 'Australia' => qw /-prefix= -country= -lax=/],
          create => sub {
              my $pt  = _t $_ [1] {-prefix};
              my $cn  = _c Australia => $_ [1] {-country};
              my $pfx = "(?:(?k:$cn)-)";
              my $lax = !defined $_ [1] {-lax} || $_ [1] {-lax};
              my $l0  = $lax ? "0?" : "0";   # Leading zero
  
              my $pat = "(?|" .
                 "(?|1(?:2(?:15|2[05]|3[05]|40)|"                               .
                        "3(?:00|35|40|5[05]|60)|"                               .
                        "4(?:35|45|5[05]|6[056]|7[05]|8[015]|9[059])|"          .
                        "5(?:15|6[05]|70|85|9[05])|"                            .
                        "6(?:3[05]|40|55|60|7[05]|8[05])|"                      .
                        "7(?:0[01]|1[05]|30|5[05]|65|90)|"                      .
                        "8(?:0[05]|11|25|35|51|60|7[15]|85|90))"                .
  
                   "|2(?:0(?:0[0-246-9]|1[0-25-9]|[2-4][0-9]|5[0279]|"          .
                            "6[0-9]|7[0-79]|8[0-9]|9[02-79])|"                  .
                        "1(?:[0-2][0-9]|3[0-8]|4[0-8]|5[0-9]|6[0-8]|"           .
                            "7[0-9]|9[0-9])|"                                   .
                        "2(?:0[03-9]|1[0-46-9]|2[0-9]|3[0-4]|5[016-9]|"         .
                            "6[0-57]|78|8[0-79]|9[0-9])|"                       .
                        "3(?:0[02-9]|1[0-24-9]|2[0-9]|3[03-9]|4[0-8]|"          .
                            "5[0-9]|6[0159]|7[0-29]|8[0-26-8]|9[05-9])|"        .
                        "4(?:0[0-689]|1[015]|2[0-9]|3[019]|4[013-9]|"           .
                            "5[02-6]|6[02-69]|[78][0-9]|90)|"                   .
                        "5(?:0[02568]|1[5-9]|2[025-9]|3[03-9]|4[015689]|"       .
                            "5[015-9]|6[03-9]|7[0-9]|8[0-8]|9[04])|"            .
                        "6(?:0[0-9]|1[0-24-9]|2[0-9]|3[0-3]|4[0-9]|"            .
                            "5[0-35689]|6[0135689]|7[1258]|8[01])|"             .
                        "7(?:0[0-35-8]|1[0-7]|2[0-25-79]|3[0-9]|4[57-9]|"       .
                            "5[0-46-9]|6[0-35-9]|7[03-9]|8[02-7]|9[0-57-9])|"   .
                        "8(?:0[03-9]|1[078]|2[0-9]|3[0-689]|4[02-9]|5[02]|"     .
                            "6[4-9]|7[013-9]|80|9[089])|"                       .
                        "9(?:0[0-6]|1[1-4]))"                                   .
         
                   "|3(?:0(?:0[0-468]|1[0-35689]|2[0-9]|3[0-46-9]|[45][0-9]|"   .
                            "6[0-8]|7[0-689]|8[1-57-9]|9[013-79])|"             .
                        "1(?:0[1-9]|1[13-6]|2[1-9]|[34][0-9]|5[0-689]|"         .
                            "[6-9][0-9])|"                                      .
                        "2(?:0[0-24-7]|1[1-9]|2[0-8]|3[0-9]|4[0-39]|5[014]|"    .
                            "6[04-9]|7[0-9]|8[0-79]|9[2-4])|"                   .
                        "3(?:0[0-59]|1[0-2457-9]|2[1-589]|3[0-578]|4[0-25]|"    .
                            "5[0-7]|6[0134]|7[013-57-9]|8[014578]|9[0-356])|"   .
                        "4(?:0[0-279]|1[2-589]|2[0347-9]|3[0-578]|4[0-246-8]|"  .
                            "5[0138]|6[0-57-9]|7[2578]|8[02357-9]|9[01468])|"   .
                        "5(?:0[0-25-79]|1[25-8]|2[0-3579]|3[0137]|4[02469]|"    .
                            "5[0-24-9]|6[1-8]|7[0-3569]|8[013-689]|9[014-79])|" .
                        "6(?:0[78]|1[0246-9]|2[0-49]|3[0-9]|4[0134679]|"        .
                            "5[89]|6[0-69]|7[0-35-8]|8[2357-9]|9[01457-9])|"    .
                        "7(?:0[01457-9]|1[1-57-9]|2[02-8]|3[0235-9]|4[014679]|" .
                            "5[0-9]|6[0-7]|7[057-9]|8[1-35-9]|9[1-35-79])|"     .
                        "8(?:0[02-9]|1[02-68]|2[0-5]|3[1-35]|4[0-247]|"         .
                            "5[0-46-9]|6[02459]|7[013-58]|8[025-9]|9[0-3568])|" .
                        "9(?:0[02-49]|1[0-35689]|2[0-35-9]|3[01346-9]|4[0-6]|"  .
                            "5[01346-9]|6[024-7]|7[15-9]|8[01478]|9[0-256]))"   .
  
                   "|4(?:0(?:0[0-9]|1[0-47-9]|2[0-259]|3[0-24-7]|5[13-59]|"     .
                            "6[014-9]|7[02-8])|"                                .
                        "1(?:0[1-9]|1[0-9]|2[0-57-9]|3[0-3]|5[1-9]|6[013-59]|"  .
                            "7[0-489]|8[34])|"                                  .
                        "2(?:0[57-9]|[12][0-9]|30|7[0-25]|8[057])|"             .
                        "3(?:0[013-79]|1[0-3]|4[0-7]|5[02-9]|6[0-5]|7[0-8]|"    .
                            "8[0-578]|90)|"                                     .
                        "4(?:0[0-8]|1[0-35-9]|2[0-8]|5[45]|6[12578]|"           .
                            "7[0-2457-9]|8[0-26-9]|9[0-46-8])|"                 .
                        "5(?:0[0-9]|1[0-24-9]|2[01]|[56][0-9]|7[0-5]|8[01])|"   .
                        "6(?:0[01568]|1[0-5]|2[015-7]|30|5[059]|6[02]|"         .
                            "7[01346-8]|80|9[4579])|"                           .
                        "7(?:0[0-79]|1[0-9]|2[0-8]|3[0-35-9]|4[0-6]|5[013467]|" .
                            "9[89])|"                                           .
                        "8(?:0[02-9]|1[0-9]|2[0-589]|30|49|5[024-9]|"           .
                            "6[01589]|7[0-9]|8[0-8]|9[0-25]))"                  .
  
                   "|5(?:0(?:0[016-9]|1[0-9]|2[0-5]|3[1-57-9]|4[0-9]|5[0-2]|"   .
                            "6[1-9]|7[0-6]|8[1-9]|9[0-8])|"                     .
                        "1(?:0[6-9]|1[0-8]|2[015-7]|3[1-46-9]|4[0-24]|"         .
                            "[56][0-9]|7[0-4])|"                                .
                        "2(?:0[1-4]|1[0-4]|2[0-3]|3[1-8]|4[0-5]|5[0-69]|"       .
                            "6[0-9]|7[0-35-9]|80|9[01])|"                       .
                        "3(?:0[1-46-9]|1[01]|2[0-2]|3[0-3]|4[0-6]|5[0-7]|"      .
                            "60|7[1-4]|81)|"                                    .
                        "4(?:0[01]|1[0-9]|2[0-2]|3[1-4]|40|5[1-5]|6[0-24]|"     .
                            "7[0-3]|8[0-35]|9[0135])|"                          .
                        "5(?:0[12]|10|2[0-3]|40|5[024-68]|60|7[0-35-7]|"        .
                            "8[0-3])|"                                          .
                        "6(?:0[0-9]|3[0-3]|4[0-2]|5[0-5]|6[01]|7[01]|80|90)|"   .
                        "7(?:0[01]|1[09]|2[02-5]|3[0-4])|"                      .
                        "9(?:42|50))"                                           .
  
                   "|6(?:0(?:0[013-9]|1[0-24-9]|2[0-9]|3[0-8]|4[1-4]|"          .
                            "[56][0-9]|7[0-46-9]|8[1-4]|90)|"                   .
                        "1(?:0[0-9]|1[0-2]|2[1-6]|4[7-9]|[56][0-9]|"            .
                            "7[0-6]|8[0-2])|"                                   .
                        "2(?:0[7-9]|1[013-58]|2[013-9]|3[0-36769]|4[034]|"      .
                            "5[1-68]|6[02]|7[15]|8[0-24-68]|90)|"               .
                        "3(?:0[24689]|1[1-35-8]|2[0-46-8]|3[0-35-8]|4[1368]|"   .
                            "5[0-35-9]|6[1357-9]|7[0235]|8[3-6]|9[0-8])|"       .
                        "4(?:0[13579]|1[0-589]|2[0-9]|3[0-46-8]|4[0235-8]|"     .
                            "5[02]|6[0-35-8]|7[0235-79]|8[0457-9]|90)|"         .
                        "5(?:0[1-79]|1[0-9]|2[1258]|3[0-25-7]|5[68]|"           .
                            "6[0246-9]|7[1245])|"                               .
                        "6(?:0[35689]|1[2-46]|2[03578]|3[0-2589]|4[026])|"      .
                        "7(?:0[157]|1[0-468]|2[0-2568]|3[13]|4[03]|5[1348]|"    .
                            "6[025]|70|9[89])|"                                 .
                        "8(?:3[17-9]|4[0-9]|50|65|72|92)|"                      .
                        "9(?:0[1-79]|1[0-9]|2[0-69]|3[1-69]|4[1-7]|5[1-9]|"     .
                            "6[013-9]|7[09]|8[1-9]|9[0-27]))"                   .
  
                   "|7(?:0(?:0[0-24-9]|1[0-25-9]|2[0-7]|30|5[0-5])|"            .
                        "1(?:09|1[23679]|20|39|40|5[015]|6[23]|7[0-9]|"         .
                            "8[02-7]|90)|"                                      .
                        "2(?:09|1[0-6]|4[89]|5[02-9]|6[0-578]|7[05-7]|9[0-2])|" .
                        "3(?:0[0-7]|1[056]|2[0-25]|3[01])|"                     .
                        "4(?:6[6-9]|70))"                                       .
  
                   "|8(?:0(?:0[1-9]|1[0-2]))"                                   .
  
                   "|9726"                                                      .
  
                   #
                   # Place this last, in case the leading 0 is optional; if
                   # not, matching against "2001" would find "200".
                   #
                   "|$l0(?:200|8(?:0[014]|1[0-5]|2[0-289]|3[0-24-9]|4[05-7]|"   .
                                 "5[0-4]|6[0-2]|7[0-5]|8[0156])|909)"           .
              "))";
  
              "(?k:$pfx$pt(?k:$pat))";
          }
          ;
      
  
  
  # pattern name   => [qw /zip British/, "-sep= "],
  #         create => sub {
  #             my $sep     = $_ [1] -> {-sep};
  # 
  #             my $london  = '(?:EC[1-4]|WC[12]|S?W1)[A-Z]';
  #             my $single  = '[BGLMS][0-9]{1,2}';
  #             my $double  = '[A-Z]{2}[0-9]{1,2}';
  # 
  #             my $left    = "(?:$london|$single|$double)";
  #             my $right   = '[0-9][ABD-HJLNP-UW-Z]{2}';
  # 
  #             "(?k:(?k:$left)(?k:$sep)(?k:$right))";
  #         },
  #         ;
  # 
  # pattern name   => [qw /zip Canadian/, "-sep= "],
  #         create => sub {
  #             my $sep     = $_ [1] -> {-sep};
  # 
  #             my $left    = '[A-Z][0-9][A-Z]';
  #             my $right   = '[0-9][A-Z][0-9]';
  # 
  #             "(?k:(?k:$left)(?k:$sep)(?k:$right))";
  #         },
  #         ;
  
  
  1;
  
  __END__
  
  =pod
  
  =head1 NAME
  
  Regexp::Common::zip -- provide regexes for postal codes.
  
  =head1 SYNOPSIS
  
      use Regexp::Common qw /zip/;
  
      while (<>) {
          /^$RE{zip}{Netherlands}$/   and  print "Dutch postal code\n";
      }
  
  
  =head1 DESCRIPTION
  
  Please consult the manual of L<Regexp::Common> for a general description
  of the works of this interface.
  
  Do not use this module directly, but load it via I<Regexp::Common>.
  
  This module offers patterns for zip or postal codes of many different
  countries. They all have the form C<$RE{zip}{Country}[{options}]>.
  
  The following common options are used:
  
  =head2 C<{-prefix=[yes|no|allow]}> and C<{-country=PAT}>.
  
  Postal codes can be prefixed with a country abbreviation. That is,
  a Dutch postal code of B<1234 AB> can also be written as B<NL-1234 AB>.
  By default, all the patterns will allow the prefixes. But this can be
  changed with the C<-prefix> option. With C<-prefix=yes>, the returned
  pattern requires a country prefix, while C<-prefix=no> disallows a
  prefix. Any argument that doesn't start with a C<y> or a C<n> allows a
  country prefix, but doesn't require them.
  
  The prefixes used are, unfortunately, not always the same. Officially,
  ISO country codes need to be used, but the usage of I<CEPT> codes (the
  same ones as used on cars) is common too. By default, each postal code
  will recognize a country prefix that's either the ISO standard or the
  CEPT code. That is, German postal codes may prefixed with either C<DE>
  or C<D>. The recognized prefix can be changed with the C<-country>
  option, which takes a (sub)pattern as argument. The arguments C<iso>
  and C<cept> are special, and indicate the language prefix should be the
  ISO country code, or the CEPT code.
  
  Examples:
   /$RE{zip}{Netherlands}/;
             # Matches '1234 AB' and 'NL-1234 AB'.
   /$RE{zip}{Netherlands}{-prefix => 'no'}/;
             # Matches '1234 AB' but not 'NL-1234 AB'.
   /$RE{zip}{Netherlands}{-prefix => 'yes'}/;
             # Matches 'NL-1234 AB' but not '1234 AB'.
  
   /$RE{zip}{Germany}/;
             # Matches 'DE-12345' and 'D-12345'.
   /$RE{zip}{Germany}{-country => 'iso'}/; 
             # Matches 'DE-12345' but not 'D-12345'.
   /$RE{zip}{Germany}{-country => 'cept'}/;
             # Matches 'D-12345' but not 'DE-12345'.
   /$RE{zip}{Germany}{-country => 'GER'}/;
             # Matches 'GER-12345'.
  
  =head2 C<{-sep=PAT}>
  
  Some countries have postal codes that consist of two parts. Typically
  there is an official way of separating those parts; but in practise
  people tend to use different separators. For instance, if the official
  way to separate parts is to use a space, it happens that the space is
  left off. The C<-sep> option can be given a pattern as argument which
  indicates what to use as a separator between the parts.
  
  Examples:
   /$RE{zip}{Netherlands}/;
             # Matches '1234 AB' but not '1234AB'.
   /$RE{zip}{Netherlands}{-sep => '\s*'}/;
             # Matches '1234 AB' and '1234AB'.
  
  =head2 C<$RE{zip}{Australia}{-lax}>
  
  Returns a pattern that recognizes Australian postal codes. Australian
  postal codes consist of four digits; the first two digits, which range
  from '10' to '97', indicate the state, although there are exceptions.
  Territories use '02' or '08' as starting digits. '0909' is the only 
  postal code starting with '09' - this is the postal code for the
  Northern Territory University). The (optional) country
  prefixes are I<AU> (ISO country code) and I<AUS> (CEPT code).
  
  It the past, it was claimed that for postal codes starting with a 0,
  the leading 0 may be omitted, and up to (and including) version
  2016060201, the leading 0 was optional. But there doesn't seem be
  solid evidence the leading 0 is optional. So, we now require there
  always to be four digit -- unless the C<< {-lax} >> option is given,
  then a possibly leading 0 is optional.
  
  Regexp::Common 2.107 and before used C<$RE{zip}{Australian}>. This is
  still supported.
  
  If C<{-keep}> is used, the following variables will be set:
  
  =over 4
  
  =item $1
  
  The entire postal code.
  
  =item $2
  
  The country code prefix.
  
  =item $3
  
  The postal code without the country prefix.
  
  =back
  
  As of version 2016060201, no C<< $4 >> or C<< $5 >> will be set.
  
  =head2 C<< $RE {zip} {Austria} >>
  
  Returns a pattern which recognizes Austrian postal codes. Austrian postal
  codes consists of 4 digits, but not all possibilities are used. This
  pattern matches the postal codes in use. The (optional) country prefixes
  are I<AT> (ISO country code) and I<AUT> (CEPT code).
  
  If C<< {-keep} >> is used, the following variables will be set:
  
  =over 4
  
  =item $1
  
  The entire postal code.
  
  =item $2
  
  The country code prefix.
  
  =item $3
  
  The postal code without the country code prefix.
  
  =back
  
  =head2 C<$RE{zip}{Belgium}>
  
  Returns a pattern than recognizes Belgian postal codes. Belgian postal
  codes consist of 4 digits, of which the first indicates the province.
  The (optional) country prefixes are I<BE> (ISO country code) and
  I<B> (CEPT code).
  
  If C<{-keep}> is used, the following variables will be set:
  
  =over 4
  
  =item $1
  
  The entire postal code.
  
  =item $2
  
  The country code prefix.
  
  =item $3
  
  The postal code without the country prefix.
  
  =back
  
  
  
  =head2 C<$RE{zip}{Denmark}>
  
  Returns a pattern that recognizes Danish postal codes. Danish postal
  codes consist of four numbers; the first digit indicates the
  distribution region, the second the distribution district. The
  (optional) country prefix is I<DK>, which is both the ISO country
  code and the CEPT code.
  
  If C<{-keep}> is used, the following variables will be set:
  
  =over 4
  
  =item $1
  
  The entire postal code.
  
  =item $2
  
  The country code prefix.
  
  =item $3
  
  The postal code without the country prefix.
  
  =back
  
  Danish postal codes will not start with 39. Postal codes of the form
  39XX are reserved from Greenland; the pattern for Danish postal codes
  will not recognize them.
  
  
  =head2 C<$RE{zip}{France}>
  
  Returns a pattern that recognizes French postal codes. French postal
  codes consist of five numbers; the first two numbers, which range
  from '01' to '98', indicate the department. The (optional) country
  prefixes are I<FR> (ISO country code) and I<F> (CEPT code).
  Regexp::Common 2.107 and before used C<$RE{zip}{French}>. This is
  still supported.
  
  Monaco uses postal codes which are part of the numbering system used
  by the French postal code system; their numbers start with 980. These
  numbers are C<< not >> recognized by this pattern.
  
  If C<{-keep}> is used, the following variables will be set:
  
  =over 4
  
  =item $1
  
  The entire postal code.
  
  =item $2
  
  The country code prefix.
  
  =item $3
  
  The postal code without the country prefix.
  
  =back
  
  =head2 C<$RE{zip}{Germany}>
  
  Returns a pattern that recognizes German postal codes. German postal
  codes consist of five numbers; the first two numbers indicating a
  wider postal area, the last three digits a postal district.
  The (optional) country prefixes are I<DE> (ISO country code) and
  I<D> (CEPT code).
  Regexp::Common 2.107 and before used C<$RE{zip}{German}>. This is
  still supported.
  
  If C<{-keep}> is used, the following variables will be set:
  
  =over 4
  
  =item $1
  
  The entire postal code.
  
  =item $2
  
  The country code prefix.
  
  =item $3
  
  The postal code without the country prefix.
  
  =back
  
  
  =head2 C<$RE{zip}{Greenland}>
  
  Returns a pattern that recognizes postal codes from Greenland.
  Greenland, uses the Danish postal codes system. Postal codes starting
  with 39 are reserved for Greenland, and all Greenlandic postal codes
  start with 39. Except the postal code for Santa. He uses 2412.
  
  The (optional) country prefix is I<GL>, which is use both as
  the ISO country code and the CEPT code. Earlier versions used
  I<DK> as the prefix.
  
  If C<{-keep}> is used, the following variables will be set:
  
  =over 4
  
  =item $1
  
  The entire postal code.
  
  =item $2
  
  The country code prefix.
  
  =item $3
  
  The postal code without the country prefix.
  
  =back
  
  =head2 C<$RE{zip}{Italy}>
  
  Returns a pattern recognizing Italian postal codes. Italian postal
  codes consist of 5 digits. The first digit indicates the region, the
  second the province. The third digit is odd for province capitals,
  and even for the province itself. The fourth digit indicates the
  route, and the fifth a place on the route (0 for small places, 
  alphabetically for the rest).
  
  Codes starting with 4789 are postal codes for San Marino; they are
  not recognized by the pattern. Use C<< $RE {zip} {'San Marino'} >>
  instead.
  
  The country prefix is either I<IT> (the ISO country code), or
  I<I> (the CEPT code).
  
  If C<{-keep}> is used, the following variables will be set:
  
  =over 4
  
  =item $1
  
  The entire postal code.
  
  =item $2
  
  The country code prefix.
  
  =item $3
  
  The postal code without the country prefix.
  
  =back
  
  =head2 C<< $RE {zip} {Liechtenstein} >>
  
  Returns a pattern which recognizes postal codes used in Liechtenstein.
  Liechtenstein uses postal codes from the Swiss postal code system.
  This system uses four digits. Postal codes which start with 94, and
  use 8 or 9 as a third digit are postal codes for Liechtenstein.
  
  If C<{-keep}> is used, the following variables will be set:
  
  =over 4
  
  =item $1
  
  The entire postal code.
  
  =item $2
  
  The country code prefix.
  
  =item $3
  
  The postal code without the country prefix.
  
  =back
  
  The ISO country prefix is I<< LI >>, the CEPT country prefix is I<< LIE >>.
  
  =head2 C<< $RE {zip {Monaco} >>
  
  Returns a pattern for postal codes used in Monaco. Monaco uses a range
  from the system used in France. They are 5 digits, starting with I<< 980 >>.
  The number I<< 98000 >> is used for physical addresses. Numbers ending
  in C<< 01 >> to C<< 99 >> are used for special deliveries.
  
  The ISO country code is I<< MC >>.
  
  If C<{-keep}> is used, the following variables will be set:
  
  =over 4
  
  =item $1
  
  The entire postal code.
  
  =item $2
  
  The country code prefix.
  
  =item $3
  
  The postal code without the country prefix.
  
  =back
  
  =head2 C<$RE{zip}{Netherlands}>
  
  Returns a pattern that recognizes Dutch postal codes. Dutch postal
  codes consist of 4 digits and 2 letters, separated by a space.
  The separator can be changed using the C<{-sep}> option, as discussed
  above. The (optional) country prefix is I<NL>, which is both the 
  ISO country code and the CEPT code. Regexp::Common 2.107 and earlier
  used C<$RE{zip}{Dutch}>. This is still supported.
  
  If C<{-keep}> is used, the following variables will be set:
  
  =over 4
  
  =item $1
  
  The entire postal code.
  
  =item $2
  
  The country code prefix.
  
  =item $3
  
  The postal code without the country prefix.
  
  =item $4
  
  The digits part of the postal code.
  
  =item $5
  
  The separator between the digits and the letters.
  
  =item $6 
  
  The letters part of the postal code.
  
  =back
  
  =head2 C<< $RE{zip}{Norway} >>
  
  Returns a pattern that recognizes Norwegian postal codes. Norwegian
  postal codes consist of four digits.
  
  The country prefix is either I<NO> (the ISO country code), or
  I<N> (the CEPT code).
  
  If C<{-keep}> is used, the following variables will be set:
  
  =over 4
  
  =item $1
  
  The entire postal code.
  
  =item $2
  
  The country code prefix.
  
  =item $3
  
  The postal code without the country prefix.
  
  =back
  
  =head2 C<< $RE {zip} {'San Marino'} >>
  
  Postal codes of San Marino use a slice from the Italian postal codes.
  Any code starting 4789, followed by another digit belongs to San Marino.
  
  The country prefix for San Marino is I<< SM >>.
  
  
  If C<{-keep}> is used, the following variables will be set:
  
  =over 4
  
  =item $1
  
  The entire postal code.
  
  =item $2
  
  The country code prefix.
  
  =item $3
  
  The postal code without the country prefix.
  
  =back
  
  
  =head2 C<< $RE{zip}{Spain} >>
  
  Returns a pattern that recognizes Spanish postal codes. Spanish postal
  codes consist of 5 digits. The first 2 indicate one of Spain's fifties
  provinces (in alphabetical order), starting with C<00>. The third digit
  indicates a main city or the main delivery rounds. The last two digits
  are the delivery area, secondary delivery route or a link to rural areas.
  
  The country prefix is either I<ES> (the ISO country code), or
  I<E> (the CEPT code).
  
  If C<{-keep}> is used, the following variables will be set:
  
  =over 4
  
  =item $1
  
  The entire postal code.
  
  =item $2
  
  The country code prefix.
  
  =item $3
  
  The postal code without the country prefix.
  
  =item $4
  
  The two digits indicating the province.
  
  =item $5
  
  The digit indicating the main city or main delivery route.
  
  =item $6
  
  The digits indicating the delivery area, secondary delivery route
  or a link to rural areas.
  
  =back
  
  =head2 C<< $RE {zip} {Switzerland} >>
  
  Returns a pattern that recognizes Swiss postal codes. Swiss postal
  codes consist of 4 digits, but not all combinations are used. Postal
  codes starting with 948 and 949 are for location in Liechtenstein,
  and will not be recognized by the pattern for Swiss postal codes.
  Use C<< $RE {zip} {Liechtenstein} >> for those.
  
  If C<{-keep}> is used, the following variables will be set:
  
  =over 4
  
  =item $1
  
  The entire postal code.
  
  =item $2
  
  The country code prefix.
  
  =item $3
  
  The postal code without the country prefix.
  
  =back
  
  The country prefix is I<CH>, for both the ISO and CEPT prefixes.
  
  
  
  =head2 C<< $RE{zip}{US}{-extended => [yes|no|allow]} >>
  
  Returns a pattern that recognizes US zip codes. US zip codes consist
  of 5 digits, with an optional 4 digit extension. By default, extensions
  are allowed, but not required. This can be influenced by the 
  C<-extended> option. If its argument starts with a C<y>,
  extensions are required; if the argument starts with a C<n>,
  extensions will not be recognized. If an extension is used, a dash
  is used to separate the main part from the extension, but this can
  be changed with the C<-sep> option.
  
  The country prefix is either I<US> (the ISO country code), or
  I<USA> (the CEPT code).
  
  If C<{-keep}> is being used, the following variables will be set:
  
  =over 4
  
  =item $1
  
  The entire postal code.
  
  =item $2
  
  The country code prefix.
  
  =item $3
  
  The postal code without the country prefix.
  
  =item $4
  
  The first 5 digits of the postal code.
  
  =item $5
  
  The first three digits of the postal code, indicating a sectional
  center or a large city. New in Regexp::Common 2.119.
  
  =item $6
  
  The last 2 digits of the 5 digit part of the postal code, indicating
  a post office facility or delivery area. New in Regexp::Common 2.119.
  
  =item $7
  
  The separator between the 5 digit part and the 4 digit part. Up to 
  Regexp::Common 2.118, this used to be $5.
  
  =item $8
  
  The 4 digit part of the postal code (if any). Up to Regexp::Common 2.118,
  this used to be $6.
  
  =item $9
  
  The first two digits of the 4 digit part of the postal code, indicating
  a sector, or several blocks. New in Regexp::Common 2.119.
  
  =item $10
  
  The last two digits of the 4 digit part of the postal code, indicating
  a segment or one side of a street. New in Regexp::Common 2.119.
  
  =back
  
  =head3 Questions
  
  =over 4
  
  =item
  
  Can the 5 digit part of the zip code (in theory) start with 000?
  
  =item
  
  Can the 5 digit part of the zip code (in theory) end with 00?
  
  =item
  
  Can the 4 digit part of the zip code (in theory) start with 00?
  
  =item
  
  Can the 4 digit part of the zip code (in theory) end with 00?
  
  =back
  
  =head2 C<< $RE {zip} {'Vatican City'} >>
  
  Vatican City uses a single postal code; taken from the Italian 
  system of postal codes, and sharing the single code with a part
  of Rome.
  
  If C<{-keep}> is used, the following variables will be set:
  
  =over 4
  
  =item $1
  
  The entire postal code.
  
  =item $2
  
  The country code prefix.
  
  =item $3
  
  The postal code without the country prefix.
  
  =back
  
  The country prefix for Vatican City is C<< VA >>.
  
  =head1 SEE ALSO
  
  L<Regexp::Common> for a general description of how to use this interface.
  
  =over 4
  
  =item L<http://www.columbia.edu/kermit/postal.html>
  
  Frank's compulsive guide to postal addresses.
  
  =item L<http://www.upu.int/post_code/en/addressing_formats_guide.shtml>
  
  Postal addressing systems.
  
  =item L<http://www.uni-koeln.de/~arcd2/33e.htm>
  
  Postal code information.
  
  =item L<http://www.grcdi.nl/linkspc.htm>
  
  Links to Postcode Pages.
  
  =item L<https://postcode.auspost.com.au/free_display.html?id=1>
  
  All Australian postal codes in use.
  
  =item L<http://hdusps.esecurecare.net/cgi-bin/hdusps.cfg/php/enduser/std_adp.php?p_faqid=1014>
  
  Information about US postal codes.
  
  =item L<http://en.wikipedia.org/wiki/Postal_code>
  
  =item L<http://download.geonames.org/export/zip/>
  
  Lots of zip files with active postal codes.
  
  =item L<http://postal-codes.findthedata.com/>
  
  Find postal codes.
  
  =back
  
  =head1 AUTHORS
  
  Damian Conway S<(I<damian@conway.org>)> and
  Abigail S<(I<regexp-common@abigail.be>)>.
  
  =head1 MAINTENANCE
  
  This package is maintained by Abigail S<(I<regexp-common@abigail.be>)>.
  
  =head1 BUGS AND IRRITATIONS
  
  Zip codes for most countries are missing.
  Send them in to I<regexp-common@abigail.be>.
  
  =head1 LICENSE and COPYRIGHT
  
  This software is Copyright (c) 2001 - 2017, Damian Conway and Abigail.
  
  This module is free software, and maybe used under any of the following
  licenses:
  
   1) The Perl Artistic License.     See the file COPYRIGHT.AL.
   2) The Perl Artistic License 2.0. See the file COPYRIGHT.AL2.
   3) The BSD License.               See the file COPYRIGHT.BSD.
   4) The MIT License.               See the file COPYRIGHT.MIT.
  
  =cut
REGEXP_COMMON_ZIP

$fatpacked{"Schedule/Cron.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'SCHEDULE_CRON';
  #!/usr/bin/perl -w
  
  =encoding utf8
  
  =head1 NAME
  
  Cron - cron-like scheduler for Perl subroutines
  
  =head1 SYNOPSIS
  
    use Schedule::Cron;
  
    # Subroutines to be called
    sub dispatcher { 
      print "ID:   ",shift,"\n"; 
      print "Args: ","@_","\n";
    }
  
    sub check_links { 
      # do something... 
    }
  
    # Create new object with default dispatcher
    my $cron = new Schedule::Cron(\&dispatcher);
  
    # Load a crontab file
    $cron->load_crontab("/var/spool/cron/perl");
  
    # Add dynamically  crontab entries
    $cron->add_entry("3 4  * * *",ROTATE => "apache","sendmail");
    $cron->add_entry("0 11 * * Mon-Fri",\&check_links);
  
    # Run scheduler 
    $cron->run(detach=>1);
                     
  
  =head1 DESCRIPTION
  
  This module provides a simple but complete cron like scheduler.  I.e this
  module can be used for periodically executing Perl subroutines.  The dates and
  parameters for the subroutines to be called are specified with a format known
  as crontab entry (see L<"METHODS">, C<add_entry()> and L<crontab(5)>)
  
  The philosophy behind C<Schedule::Cron> is to call subroutines periodically
  from within one single Perl program instead of letting C<cron> trigger several
  (possibly different) Perl scripts. Everything under one roof.  Furthermore,
  C<Schedule::Cron> provides mechanism to create crontab entries dynamically,
  which isn't that easy with C<cron>.
  
  C<Schedule::Cron> knows about all extensions (well, at least all extensions I'm
  aware of, i.e those of the so called "Vixie" cron) for crontab entries like
  ranges including 'steps', specification of month and days of the week by name,
  or coexistence of lists and ranges in the same field.  It even supports a bit
  more (like lists and ranges with symbolic names).
  
  =head1 METHODS
  
  =over 4
  
  =cut
  
  #'
  
  package Schedule::Cron;
  
  use Time::ParseDate;
  use Data::Dumper;
  
  use strict;
  use vars qw($VERSION  $DEBUG);
  use subs qw(dbg);
  
  my $HAS_POSIX;
  
  BEGIN {
    eval { 
      require POSIX;
      import POSIX ":sys_wait_h";
    };
    $HAS_POSIX = $@ ? 0 : 1;
  }
  
  
  $VERSION = "1.05";
  
  our $DEBUG = 0;
  my %STARTEDCHILD = ();
  
  my @WDAYS = qw(
                   Sunday
                   Monday
                   Tuesday
                   Wednesday
                   Thursday
                   Friday
                   Saturday
                   Sunday
                  );
  
  my @ALPHACONV = (
                   { },
                   { },
                   { },
                   { qw(jan 1 feb 2 mar 3 apr 4 may 5 jun 6 jul 7 aug 8
                        sep 9 oct 10 nov 11 dec 12) },
                   { qw(sun 0 mon 1 tue 2 wed 3 thu 4 fri 5 sat 6)},
                   {  }
                  );
  my @RANGES = ( 
                [ 0,59 ],
                [ 0,23 ],
                [ 0,31 ],
                [ 0,12 ],
                [ 0,7  ],
                [ 0,59 ]
               );
  
  my @LOWMAP = ( 
                {},
                {},
                { 0 => 1},
                { 0 => 1},
                { 7 => 0},
                {},
               );
  
  
  # Currently, there are two ways for reaping. One, which only waits explicitly
  # on PIDs it forked on its own, and one which waits on all PIDs (even on those
  # it doesn't forked itself). The later has been proved to work on Win32 with
  # the 64 threads limit (RT #56926), but not when one creates forks on ones
  # own. The specific reaper works for RT #55741.
  
  # It tend to use the specific one, if it also resolves RT #56926. Both are left
  # here for reference until a decision has been done for 1.01
  
  sub REAPER {
      &_reaper_all();
  }
  
  # Specific reaper
  sub _reaper_specific {
      local ($!,%!,$?);
      if ($HAS_POSIX)
      {
          foreach my $pid (keys %STARTEDCHILD) {
              if ($STARTEDCHILD{$pid}) {
                  my $res = $HAS_POSIX ? waitpid($pid, WNOHANG) : waitpid($pid,0);
                  if ($res > 0) {
                      # We reaped a truly running process
                      $STARTEDCHILD{$pid} = 0;
                      dbg "Reaped child $res" if $DEBUG;
                  }
              }
          }
      } 
      else
      {
          my $waitedpid = 0;
          while($waitedpid != -1) {
              $waitedpid = wait;
          }
      }
  }
  
  # Catch all reaper
  sub _reaper_all {
      #local ($!,%!,$?,${^CHILD_ERROR_NATIVE});
  
      # Localizing ${^CHILD_ERROR_NATIVE} breaks signalhander.t which checks that
      # chained SIGCHLD handlers are called. I don't know why, though, hence I
      # leave it out for now. See #69916 for some discussion why this handler
      # might be needed.
      local ($!,%!,$?);
      my $kid;
      do 
      {
          # Only on POSIX systems the wait will return immediately 
          # if there are no finished child processes. Simple 'wait'
          # waits blocking on childs.
          $kid = $HAS_POSIX ? waitpid(-1, WNOHANG) : wait;
          dbg "Kid: $kid" if $DEBUG;
          if ($kid != 0 && $kid != -1 && defined $STARTEDCHILD{$kid}) 
          {
              # We don't delete the hash entry here to avoid an issue
              # when modifying global hash from multiple threads
              $STARTEDCHILD{$kid} = 0;
              dbg "Reaped child $kid" if $DEBUG;
          }
      } while ($kid != 0 && $kid != -1);
  
      # Note to myself: Is the %STARTEDCHILD hash really necessary if we use -1
      # for waiting (i.e. for waiting on any child ?). In the current
      # implementation, %STARTEDCHILD is not used at all. It would be only 
      # needed if we iterate over it to wait on pids specifically.
  }
  
  # Cleaning is done in extra method called from the main 
  # process in order to avoid event handlers modifying this
  # global hash which can lead to memory errors.
  # See RT #55741 for more details on this.
  # This method is called in strategic places.
  sub _cleanup_process_list 
  {
      my ($self, $cfg) = @_;
      
      # Cleanup processes even on those systems, where the SIGCHLD is not 
      # propagated. Only do this for POSIX, otherwise this call would block 
      # until all child processes would have been finished.
      # See RT #56926 for more details.
  
      # Do not cleanup if nofork because jobs that fork will do their own reaping.
      &REAPER() if $HAS_POSIX && !$cfg->{nofork};
  
      # Delete entries from this global hash only from within the main
      # thread/process. Hence, this method must not be called from within 
      # a signalhandler    
      for my $k (keys %STARTEDCHILD) 
      {
          delete $STARTEDCHILD{$k} unless $STARTEDCHILD{$k};
      }
  }
  
  =item $cron = new Schedule::Cron($dispatcher,[extra args])
  
  Creates a new C<Cron> object.  C<$dispatcher> is a reference to a subroutine,
  which will be called by default.  C<$dispatcher> will be invoked with the
  arguments parameter provided in the crontab entry if no other subroutine is
  specified. This can be either a single argument containing the argument
  parameter literally has string (default behavior) or a list of arguments when
  using the C<eval> option described below.
  
  The date specifications must be either provided via a crontab like file or
  added explicitly with C<add_entry()> (L<"add_entry">).
  
  I<extra_args> can be a hash or hash reference for additional arguments.  The
  following parameters are recognized:
  
  =over
  
  =item file => <crontab>  
  
  
  Load the crontab entries from <crontab>
  
  =item eval =>  1
  
  Eval the argument parameter in a crontab entry before calling the subroutine
  (instead of literally calling the dispatcher with the argument parameter as
  string)
  
  =item nofork => 1
  
  Don't fork when starting the scheduler. Instead, the jobs are executed within
  current process. In your executed jobs, you have full access to the global
  variables of your script and hence might influence other jobs running at a
  different time. This behavior is fundamentally different to the 'fork' mode,
  where each jobs gets its own process and hence a B<copy> of the process space,
  independent of each other job and the main process. This is due to the nature
  of the  C<fork> system call. 
  
  =item nostatus =>  1
  
  Do not update status in $0.  Set this if you don't want ps to reveal the internals
  of your application, including job argument lists.  Default is 0 (update status).
  
  =item skip => 1
  
  Skip any pending jobs whose time has passed. This option is only useful in
  combination with C<nofork> where a job might block the execution of the
  following jobs for quite some time. By default, any pending job is executed
  even if its scheduled execution time has already passed. With this option set
  to true all pending which would have been started in the meantime are skipped. 
  
  =item catch => 1
  
  Catch any exception raised by a job. This is especially useful in combination with
  the C<nofork> option to avoid stopping the main process when a job raises an
  exception (dies).
  
  =item after_job => \&after_sub
  
  Call a subroutine after a job has been run. The first argument is the return
  value of the dispatched job, the reminding arguments are the arguments with
  which the dispatched job has been called.
  
  Example:
  
     my $cron = new Schedule::Cron(..., after_job => sub {
            my ($ret,@args) = @_;
            print "Return value: ",$ret," - job arguments: (",join ":",@args,")\n";
     });
  
  =item log => \&log_sub
  
  Install a logging subroutine. The given subroutine is called for several events
  during the lifetime of a job. This method is called with two arguments: A log
  level of 0 (info),1 (warning) or 2 (error) depending on the importance of the
  message and the message itself.
  
  For example, you could use I<Log4perl> (L<http://log4perl.sf.net>) for logging
  purposes for example like in the following code snippet:
  
     use Log::Log4perl;
     use Log::Log4perl::Level;
  
     my $log_method = sub {
        my ($level,$msg) = @_;
        my $DBG_MAP = { 0 => $INFO, 1 => $WARN, 2 => $ERROR };
  
        my $logger = Log::Log4perl->get_logger("My::Package");
        $logger->log($DBG_MAP->{$level},$msg);
     }
    
     my $cron = new Schedule::Cron(.... , log => $log_method);
  
  =item loglevel => <-1,0,1,2>
  
  Restricts logging to the specified severity level or below.  Use 0 to have all
  messages generated, 1 for only warnings and errors and 2 for errors only.
  Default is 0 (all messages).  A loglevel of -1 (debug) will include job
  argument lists (also in $0) in the job start message logged with a level of 0
  or above. You may have security concerns with this. Unless you are debugging,
  use 0 or higher. A value larger than 2 will disable logging completely.
  
  Although you can filter in your log routine, generating the messages can be
  expensive, for example if you pass arguments pointing to large hashes.  Specifying
  a loglevel avoids formatting data that your routine would discard.
  
  =item processprefix => <name>
  
  Cron::Schedule sets the process' name (i.e. C<$0>) to contain some informative
  messages like when the next job executes or with which arguments a job is
  called. By default, the prefix for this labels is C<Schedule::Cron>. With this
  option you can set it to something different. You can e.g. use C<$0> to include
  the original process name.  You can inhibit this with the C<nostatus> option, and
  prevent the argument display by setting C<loglevel> to zero or higher.
  
  =item processname => <name>
  
  Set the process name (i.e. C<$0>) to a literal string. Using this setting 
  overrides C<processprefix> and C<nostatus>.
  
  =item sleep => \&hook
  
  If specified, &hook will be called instead of sleep(), with the time to sleep
  in seconds as first argument and the Schedule::Cron object as second.  This hook
  allows you to use select() instead of sleep, so that you can handle IO, for
  example job requests from a network connection.
  
  e.g.
  
    $cron->run( { sleep => \&sleep_hook, nofork => 1 } );
  
    sub sleep_hook {
      my ($time, $cron) = @_;
  
      my ($rin, $win, $ein) = ('','','');
      my ($rout, $wout, $eout);
      vec($rin, fileno(STDIN), 1) = 1;
      my ($nfound, $ttg) = select($rout=$rin, $wout=$win, $eout=$ein, $time);
      if ($nfound) {
  	   handle_io($rout, $wout, $eout);
      }
      return;
  }
  
  =back
  
  =cut
  
  sub new 
  {
      my $class = shift;
      my $dispatcher = shift || die "No dispatching sub provided";
      die "Dispatcher not a ref to a subroutine" unless ref($dispatcher) eq "CODE";
      my $cfg = ref($_[0]) eq "HASH" ? $_[0] : {  @_ };
      $cfg->{processprefix} = "Schedule::Cron" unless $cfg->{processprefix};
      my $timeshift = $cfg->{timeshift} || 0;
      my $self = { 
                  cfg => $cfg,
                  dispatcher => $dispatcher,
                  timeshift => $timeshift,
                  queue => [ ],
                  map => { }
               };
      bless $self,(ref($class) || $class);
      
      $self->load_crontab if $cfg->{file};
      $self;
  }
  
  =item $cron->load_crontab($file)
  
  =item $cron->load_crontab(file=>$file,[eval=>1])
  
  Loads and parses the crontab file C<$file>. The entries found in this file will
  be B<added> to the current time table with C<$cron-E<gt>add_entry>.
  
  The format of the file consists of cron commands containing of lines with at
  least 5 columns, whereas the first 5 columns specify the date.  The rest of the
  line (i.e columns 6 and greater) contains the argument with which the
  dispatcher subroutine will be called.  By default, the dispatcher will be
  called with one single string argument containing the rest of the line
  literally.  Alternatively, if you call this method with the optional argument
  C<eval=E<gt>1> (you must then use the second format shown above), the rest of
  the line will be evaled before used as argument for the dispatcher.
  
  For the format of the first 5 columns, please see L<"add_entry">.
  
  Blank lines and lines starting with a C<#> will be ignored. 
  
  There's no way to specify another subroutine within the crontab file.  All
  calls will be made to the dispatcher provided at construction time.
  
  If    you   want    to    start   up    fresh,    you   should    call
  C<$cron-E<gt>clean_timetable()> before.
  
  Example of a crontab fiqw(le:)
  
     # The following line runs on every Monday at 2:34 am
     34 2 * * Mon  "make_stats"
     # The next line should be best read in with an eval=>1 argument
     *  * 1 1 *    { NEW_YEAR => '1',HEADACHE => 'on' }
  
  =cut
  
  #'
  
  sub load_crontab 
  {
    my $self = shift;
    my $cfg = shift;
  
    if ($cfg) 
    {
        if (@_) 
        {
            $cfg = ref($cfg) eq "HASH" ? $cfg : { $cfg,@_ };
        } 
        elsif (!ref($cfg)) 
        {
            my $new_cfg = { };
            $new_cfg->{file} = $cfg;
            $cfg = $new_cfg;
        }
    }
    
    my $file = $cfg->{file} || $self->{cfg}->{file} || die "No filename provided";
    my $eval = $cfg->{eval} || $self->{cfg}->{eval};
    
    open(F,$file) || die "Cannot open schedule $file : $!";
    my $line = 0;
    while (<F>) 
    {
        $line++;
        # Strip off trailing comments and ignore empty 
        # or pure comments lines:
        s/#.*$//;
        next if /^\s*$/;
        next if /^\s*#/;
        chomp;
        s/\s*(.*)\s*$/$1/;
        my ($min,$hour,$dmon,$month,$dweek,$rest) = split (/\s+/,$_,6);
        
        my $time = [ $min,$hour,$dmon,$month,$dweek ];
  
        # Try to check, whether an optional 6th column specifying seconds 
        # exists: 
        my $args;
        if ($rest)
        {
            my ($col6,$more_args) = split(/\s+/,$rest,2);
            if ($col6 =~ /^[\d\-\*\,\/]+$/)
            {
                push @$time,$col6;
                dbg "M: $more_args";
                $args = $more_args;
            }
            else
            {
                $args = $rest;
            }
        }
        $self->add_entry($time,{ 'args' => $args, 'eval' => $eval});
    }
    close F;
  }
  
  =item $cron->add_entry($timespec,[arguments])
  
  Adds a new entry to the list of scheduled cron jobs.
  
  B<Time and Date specification>
  
  C<$timespec> is the specification of the scheduled time in crontab format
  (L<crontab(5)>) which contains five mandatory time and date fields and an
  optional 6th column. C<$timespec> can be either a plain string, which contains
  a whitespace separated time and date specification.  Alternatively,
  C<$timespec> can be a reference to an array containing the five elements for
  the date fields.
  
  The time and date fields are (taken mostly from L<crontab(5)>, "Vixie" cron): 
  
     field          values
     =====          ======
     minute         0-59
     hour           0-23
     day of month   1-31 
     month          1-12 (or as names)
     day of week    0-7 (0 or 7 is Sunday, or as names)
     seconds        0-59 (optional)
  
   A field may be an asterisk (*), which always stands for
   ``first-last''.
  
   Ranges of numbers are  allowed.  Ranges are two numbers
   separated  with  a  hyphen.   The  specified  range  is
   inclusive.   For example, 8-11  for an  ``hours'' entry
   specifies execution at hours 8, 9, 10 and 11.
  
   Lists  are allowed.   A list  is a  set of  numbers (or
   ranges)  separated by  commas.   Examples: ``1,2,5,9'',
   ``0-4,8-12''.
  
   Step  values can  be used  in conjunction  with ranges.
   Following a range with ``/<number>'' specifies skips of
   the  numbers value  through the  range.   For example,
   ``0-23/2'' can  be used in  the hours field  to specify
   command execution every  other hour (the alternative in
   the V7 standard is ``0,2,4,6,8,10,12,14,16,18,20,22'').
   Steps are  also permitted after an asterisk,  so if you
   want to say ``every two hours'', just use ``*/2''.
  
   Names can also  be used for the ``month''  and ``day of
   week''  fields.  Use  the  first three  letters of  the
   particular day or month (case doesn't matter).
  
   Note: The day of a command's execution can be specified
         by two fields  -- day of month, and  day of week.
         If both fields are restricted (ie, aren't *), the
         command will be run when either field matches the
         current  time.  For  example, ``30  4 1,15  * 5''
         would cause a command to be run at 4:30 am on the
         1st and 15th of each month, plus every Friday
  
  Examples:
  
   "8  0 * * *"         ==> 8 minutes after midnight, every day
   "5 11 * * Sat,Sun"   ==> at 11:05 on each Saturday and Sunday
   "0-59/5 * * * *"     ==> every five minutes
   "42 12 3 Feb Sat"    ==> at 12:42 on 3rd of February and on 
                            each Saturday in February
   "32 11 * * * 0-30/2" ==> 11:32:00, 11:32:02, ... 11:32:30 every 
                            day
  
  In addition, ranges or lists of names are allowed. 
  
  An optional sixth column can be used to specify the seconds within the
  minute. If not present, it is implicitly set to "0".
  
  B<Command specification>
  
  The subroutine to be executed when the C<$timespec> matches can be
  specified in several ways.
  
  First, if the optional C<arguments> are lacking, the default dispatching
  subroutine provided at construction time will be called without arguments.
  
  If the second parameter to this method is a reference to a subroutine, this
  subroutine will be used instead of the dispatcher.
  
  Any additional parameters will be given as arguments to the subroutine to be
  executed.  You can also specify a reference to an array instead of a list of
  parameters.
  
  You can also use a named parameter list provided as an hashref. The named
  parameters recognized are:
  
  =over
  
  =item subroutine      
  
  =item sub 
  
  Reference to subroutine to be executed
  
  =item arguments
  
  =item args
  
  Reference to array containing arguments to be use when calling the subroutine
  
  =item eval
  
  If true, use the evaled string provided with the C<arguments> parameter.  The
  evaluation will take place immediately (not when the subroutine is going to be
  called)
  
  =back
  
  Examples:
  
     $cron->add_entry("* * * * *");
     $cron->add_entry("* * * * *","doit");
     $cron->add_entry("* * * * *",\&dispatch,"first",2,"third");
     $cron->add_entry("* * * * *",{'subroutine' => \&dispatch,
                                   'arguments'  => [ "first",2,"third" ]});
     $cron->add_entry("* * * * *",{'subroutine' => \&dispatch,
                                   'arguments'  => '[ "first",2,"third" ]',
                                   'eval'       => 1});
  
  =cut 
  
  sub add_entry 
  { 
      my $self = shift;
      my $time = shift;
      my $args = shift || []; 
      my $dispatch;
      
      #  dbg "Args: ",Dumper($time,$args);
      
      if (ref($args) eq "HASH") 
      {
          my $cfg = $args;
          $args = undef;
          $dispatch = $cfg->{subroutine} || $cfg->{sub};
          $args = $cfg->{arguments} || $cfg->{args} || [];
          if ($cfg->{eval} && $cfg) 
          {
              die "You have to provide a simple scalar if using eval" if (ref($args));
              my $orig_args = $args;
              dbg "Evaled args ",Dumper($args) if $DEBUG;
              $args = [ eval $args ];
              die "Cannot evaluate args (\"$orig_args\")"
                if $@;
          }
      } 
      elsif (ref($args) eq "CODE") 
      {
          $dispatch = $args;
          $args = shift || [];
      }
      if (ref($args) ne "ARRAY") 
      {
          $args = [ $args,@_ ];
      }
  
      $dispatch ||= $self->{dispatcher};
  
  
      my $time_array = ref($time) ? $time : [ split(/\s+/,$time) ];
      die "Invalid number of columns in time entry (5 or 6)\n"
        if ($#$time_array != 4 && $#$time_array !=5);
      $time = join ' ',@$time_array;
  
      #  dbg "Adding ",Dumper($time);
      push @{$self->{time_table}},
      {
       time => $time,
       dispatcher => $dispatch,
       args => $args
      };
      
      $self->{entries_changed} = 1;
      #  dbg "Added Args ",Dumper($self->{args});
      
      my $index = $#{$self->{time_table}};
      my $id = $args->[0];
      $self->{map}->{$id} = $index if $id;
      
      return $#{$self->{time_table}};
  }
  
  =item @entries = $cron->list_entries()
  
  Return a list of cron entries. Each entry is a hash reference of the following
  form:
  
    $entry = { 
               time => $timespec,
               dispatch => $dispatcher,
               args => $args_ref
             }
  
  Here C<$timespec> is the specified time in crontab format as provided to
  C<add_entry>, C<$dispatcher> is a reference to the dispatcher for this entry
  and C<$args_ref> is a reference to an array holding additional arguments (which
  can be an empty array reference). For further explanation of this arguments
  refer to the documentation of the method C<add_entry>.
  
  The order index of each entry can be used within C<update_entry>, C<get_entry>
  and C<delete_entry>. But be aware, when you are deleting an entry, that you
  have to re-fetch the list, since the order will have changed.
  
  Note that these entries are returned by value and were obtained from the
  internal list by a deep copy. I.e. you are free to modify it, but this won't
  influence the original entries. Instead use C<update_entry> if you need to
  modify an existing crontab entry.
  
  =cut
  
  sub list_entries
  {
      my ($self) = shift;
      
      my @ret;
      foreach my $entry (@{$self->{time_table}})
      {
          # Deep copy $entry
          push @ret,$self->_deep_copy_entry($entry);
      }
      return @ret;
  }
  
  
  =item $entry = $cron->get_entry($idx)
  
  Get a single entry. C<$entry> is either a hashref with the possible keys
  C<time>, C<dispatch> and C<args> (see C<list_entries()>) or undef if no entry
  with the given index C<$idx> exists.
  
  =cut
  
  sub get_entry
  {
      my ($self,$idx) = @_;
  
      my $entry = $self->{time_table}->[$idx];
      if ($entry)
      {
          return $self->_deep_copy_entry($entry);
      }
      else
      {
          return undef;
      }
  }
  
  =item $cron->delete_entry($idx)
  
  Delete the entry at index C<$idx>. Returns the deleted entry on success,
  C<undef> otherwise.
  
  =cut
  
  sub delete_entry
  {
      my ($self,$idx) = @_;
  
      if ($idx <= $#{$self->{time_table}})
      {
          $self->{entries_changed} = 1;
  
          # Remove entry from $self->{map} which 
          # remembers the index in the timetable by name (==id)
          # and update all larger indexes appropriately
          # Fix for #54692
          my $map = $self->{map};
          foreach my $key (keys %{$map}) {
              if ($map->{$key} > $idx) {
                  $map->{$key}--;
              } elsif ($map->{$key} == $idx) {
                  delete $map->{$key};
              }
          }
          return splice @{$self->{time_table}},$idx,1;
      }
      else
      {
          return undef;
      }
  }
  
  =item $cron->update_entry($idx,$entry)
  
  Updates the entry with index C<$idx>. C<$entry> is a hash ref as described in
  C<list_entries()> and must contain at least a value C<$entry-E<gt>{time}>. If no
  C<$entry-E<gt>{dispatcher}> is given, then the default dispatcher is used.  This
  method returns the old entry on success, C<undef> otherwise.
  
  =cut 
  
  sub update_entry
  {
      my ($self,$idx,$entry) = @_;
  
      die "No update entry given" unless $entry;
      die "No time specification given" unless $entry->{time};
      
      if ($idx <= $#{$self->{time_table}})
      {
          my $new_entry = $self->_deep_copy_entry($entry);
          $new_entry->{dispatcher} = $self->{dispatcher} 
            unless $new_entry->{dispatcher};
          $new_entry->{args} = []
            unless $new_entry->{args};
          return splice @{$self->{time_table}},$idx,1,$new_entry;
      }
      else
      {
          return undef;
      }
  }
  
  =item $cron->run([options])
  
  This method starts the scheduler.
  
  When called without options, this method will never return and executes the
  scheduled subroutine calls as needed.
  
  Alternatively, you can detach the main scheduler loop from the current process
  (daemon mode). In this case, the pid of the forked scheduler process will be
  returned.
  
  The C<options> parameter specifies the running mode of C<Schedule::Cron>.  It
  can be either a plain list which will be interpreted as a hash or it can be a
  reference to a hash. The following named parameters (keys of the provided hash)
  are recognized:
  
  =over
  
  =item detach    
  
  If set to a true value the scheduler process is detached from the current
  process (UNIX only).
  
  =item pid_file  
  
  If running in daemon mode, name the optional file, in which the process id of
  the scheduler process should be written. By default, no PID File will be
  created.
  
  =item nofork, skip, catch, log, loglevel, nostatus, sleep
  
  See C<new()> for a description of these configuration parameters, which can be
  provided here as well. Note, that the options given here overrides those of the
  constructor.
  
  =back
  
  
  Examples:
  
     # Start  scheduler, detach  from current  process and
     # write  the  PID  of  the forked  scheduler  to  the
     # specified file
     $cron->run(detach=>1,pid_file=>"/var/run/scheduler.pid");
  
     # Start scheduler and wait forever.
     $cron->run();
  
  =cut
  
  sub run 
  { 
      my $self = shift;
      my $cfg = ref($_[0]) eq "HASH" ? $_[0] : {  @_ };
      $cfg = { %{$self->{cfg}}, %$cfg }; # Merge in global config;
  
      my $log = $cfg->{log};
      my $loglevel = $cfg->{loglevel};
      $loglevel = 0 unless defined $loglevel;
      my $sleeper = $cfg->{sleep};
  
      $self->_rebuild_queue;
      delete $self->{entries_changed};
      die "Nothing in schedule queue" unless @{$self->{queue}};
      
      # Install reaper now.
      unless ($cfg->{nofork}) {
          my $old_child_handler = $SIG{'CHLD'};
          $SIG{'CHLD'} = sub {
              dbg "Calling reaper" if $DEBUG;
              &REAPER();
              if ($old_child_handler && ref $old_child_handler eq 'CODE')
              {
                  dbg "Calling old child handler" if $DEBUG;
                  #use B::Deparse ();
                  #my $deparse = B::Deparse->new;
                  #print 'sub ', $deparse->coderef2text($old_child_handler), "\n";
                  &$old_child_handler();
              }
          };
      }
      
      if (my $name = $cfg->{processname}) {
          $0 = $name
      }
  
      my $mainloop = sub { 
        MAIN:
          while (42)          
          {
              unless (@{$self->{queue}}) # Queue length
              { 
                  # Last job deleted itself, or we were run with no entries.
                  # We can't return, so throw an exception - perhaps someone will catch.
                  die "No more jobs to run\n";
              }
              my ($indexes,$time) = $self->_get_next_jobs();
              dbg "Jobs for $time : ",join(",",@$indexes) if $DEBUG;
              my $now = $self->_now();
              my $sleep = 0;
              if ($time < $now)
              {
                  if ($cfg->{skip})
                  {
                      for my $index (@$indexes) {
                          $log->(0,"Schedule::Cron - Skipping job $index")
                            if $log && $loglevel <= 0;
                          $self->_update_queue($index);
                      }
                      next;
                  }
                  # At least a safety airbag
                  $sleep = 1;
              }
              else
              {
                  $sleep = $time - $now;
              }
  
              unless ($cfg->{processname} || $cfg->{nostatus}) {
                  $0 = $self->_get_process_prefix()." MainLoop - next: ".scalar(localtime($time)); 
              }
  
              if (!$time) {
                  die "Internal: No time found, self: ",$self->{queue},"\n" unless $time;
              }
  
              dbg "R: sleep = $sleep | ",scalar(localtime($time))," (",scalar(localtime($now)),")" if $DEBUG;
  
              while ($sleep > 0) 
              {
                  if ($sleeper) 
                  {
                      $sleeper->($sleep,$self);
                      if ($self->{entries_changed})
                      {
                          $self->_rebuild_queue;
                          delete $self->{entries_changed};
                          redo MAIN;
                      }
                  } else {
                      sleep($sleep);
                  }
                  $sleep = $time - $self->_now();
              }
  
              for my $index (@$indexes) {                
                  $self->_execute($index,$cfg);
                  # If "skip" is set and the job takes longer than a second, then
                  # the remaining jobs are skipped.
                  last if $cfg->{skip} && $time < $self->_now();
              }
              $self->_cleanup_process_list($cfg);
  
              if ($self->{entries_changed}) {
                 dbg "rebuilding queue" if $DEBUG;
                 $self->_rebuild_queue;
                 delete $self->{entries_changed};
              } else {
                  for my $index (@$indexes) {
                      $self->_update_queue($index);
                  }
              }
          } 
      };
  
      if ($cfg->{detach}) 
      {
          defined(my $pid = fork) or die "Can't fork: $!";
          if ($pid) 
          {
              # Parent:
              if ($cfg->{pid_file}) 
              {
                  if (open(P,">".$cfg->{pid_file})) 
                  {
                      print P $pid,"\n";
                      close P;
                  } 
                  else 
                  {
                      warn "Warning: Cannot open ",$cfg->{pid_file}," : $!\n";
                  }
                  
              }
              return $pid;
          } 
          else 
          {
              # Child:
              # Try to detach from terminal:
              chdir '/';
              open STDIN, '/dev/null' or die "Can't read /dev/null: $!";
              open STDOUT, '>/dev/null' or die "Can't write to /dev/null: $!";
              
              eval { require POSIX; };
              if ($@) 
              {
                  #      if (1) {
                  if (open(T,"/dev/tty")) 
                  {
                      dbg "No setsid found, trying ioctl() (Error: $@)";
                      eval { require 'ioctl.ph'; };
                      if ($@) 
                      {
                          eval { require 'sys/ioctl.ph'; };
                          if ($@) 
                          {
                              die "No 'ioctl.ph'. Probably you have to run h2ph (Error: $@)";
                          }
                      }
                      my $notty = &TIOCNOTTY;
                      die "No TIOCNOTTY !" if $@ || !$notty;
                      ioctl(T,$notty,0) || die "Cannot issue ioctl(..,TIOCNOTTY) : $!";
                      close(T);
                  };
              } 
              else 
              {
                  &POSIX::setsid() || die "Can't start a new session: $!";
              }
              open STDERR, '>&STDOUT' or die "Can't dup stdout: $!";
              
              unless ($cfg->{processname} || $cfg->{nostatus}) {
                  $0 = $self->_get_process_prefix()." MainLoop"; 
              }
  
              &$mainloop();
          }
      } 
      else 
      {
          &$mainloop(); 
      }
  }
  
  
  =item $cron->clean_timetable()
  
  Remove all scheduled entries
  
  =cut
  
  sub clean_timetable 
  { 
      my $self = shift;
      $self->{entries_changed} = 1;
      $self->{time_table} = [];
  }
  
  
  =item $cron->check_entry($id)
  
  Check, whether the given ID is already registered in the timetable. 
  A ID is the first argument in the argument parameter of the 
  a crontab entry.
  
  Returns (one of) the index in the  timetable (can be 0, too) if the ID
  could be found or C<undef> otherwise.
  
  Example:
  
     $cron->add_entry("* * * * *","ROTATE");
     .
     .
     defined($cron->check_entry("ROTATE")) || die "No ROTATE entry !"
  
  =cut 
  
  sub check_entry 
  { 
      my $self = shift;
      my $id = shift;
      return $self->{map}->{$id};
  }
  
  
  =item $cron->get_next_execution_time($cron_entry,[$ref_time])
  
  Well, this is mostly an internal method, but it might be useful on 
  its own. 
  
  The purpose of this method is to calculate the next execution time
  from a specified crontab entry
  
  Parameters:
  
  =over
  
  =item $cron_entry  
  
  The crontab entry as specified in L<"add_entry">
  
  =item $ref_time    
  
  The reference time for which the next time should be searched which matches
  C<$cron_entry>. By default, take the current time
  
  =back
  
  This method returns the number of epoch-seconds of the next matched 
  date for C<$cron_entry>.
  
  Since I suspect, that this calculation of the next execution time might
  fail in some circumstances (bugs are lurking everywhere ;-) an
  additional interactive method C<bug()> is provided for checking
  crontab entries against your expected output. Refer to the
  top-level README for additional usage information for this method.
  
  =cut
  
  sub get_next_execution_time 
  { 
    my $self = shift;
    my $cron_entry = shift;
    my $time = shift;
    
    $cron_entry = [ split /\s+/,$cron_entry ] unless ref($cron_entry);
  
    # Expand and check entry:
    # =======================
    die "Exactly 5 or 6 columns has to be specified for a crontab entry ! (not ",
      scalar(@$cron_entry),")"
        if ($#$cron_entry != 4 && $#$cron_entry != 5);
    
    my @expanded;
    my $w;
    
    for my $i (0..$#$cron_entry) 
    {
        my @e = split /,/,$cron_entry->[$i];
        my @res;
        my $t;
        while (defined($t = shift @e)) {
            # Subst "*/5" -> "0-59/5"
            $t =~ s|^\*(/.+)$|$RANGES[$i][0]."-".$RANGES[$i][1].$1|e; 
            
            if ($t =~ m|^([^-]+)-([^-/]+)(/(.*))?$|) 
            {
                my ($low,$high,$step) = ($1,$2,$4);
                $step = 1 unless $step;
                if ($low !~ /^(\d+)/) 
                {
                    $low = $ALPHACONV[$i]{lc $low};
                }
                if ($high !~ /^(\d+)/) 
                {
                    $high = $ALPHACONV[$i]{lc $high};
                }
                if (! defined($low) || !defined($high) ||  $low > $high || $step !~ /^\d+$/) 
                {
                    die "Invalid cronentry '",$cron_entry->[$i],"'";
                }
                my $j;
                for ($j = $low; $j <= $high; $j += $step) 
                {
                    push @e,$j;
                }
            } 
            else 
            {
                $t = $ALPHACONV[$i]{lc $t} if $t !~ /^(\d+|\*)$/;
                $t = $LOWMAP[$i]{$t} if( defined $t && exists($LOWMAP[$i]{$t}) );
                
                die "Invalid cronentry '",$cron_entry->[$i],"'" 
                  if (!defined($t) || ($t ne '*' && ($t < $RANGES[$i][0] || $t > $RANGES[$i][1])));
                push @res,$t;
            }
        }
        push @expanded, ($#res == 0 && $res[0] eq '*') ? [ "*" ] : [ sort {$a <=> $b} @res];
    }
    
    # Check for strange bug
    $self->_verify_expanded_cron_entry($cron_entry,\@expanded);
  
    # Calculating time:
    # =================
    my $now = $time || time;
  
    if ($expanded[2]->[0] ne '*' && $expanded[4]->[0] ne '*') 
    {
        # Special check for which time is lower (Month-day or Week-day spec):
        my @bak = @{$expanded[4]};
        $expanded[4] = [ '*' ];
        my $t1 = $self->_calc_time($now,\@expanded);
        $expanded[4] = \@bak;
        $expanded[2] = [ '*' ];
        my $t2 = $self->_calc_time($now,\@expanded);
        dbg "MDay : ",scalar(localtime($t1))," -- WDay : ",scalar(localtime($t2)) if $DEBUG;
        return $t1 < $t2 ? $t1 : $t2;
    } 
    else 
    {
        # No conflicts possible:
        return $self->_calc_time($now,\@expanded);
    }
  }
  
  =item $cron->set_timeshift($ts)
  
  Modify global time shift for all timetable. The timeshift is subbed from localtime
  to calculate next execution time for all scheduled jobs.
  
  ts parameter must be in seconds. Default value is 0. Negative values are allowed to
  shift time in the past.
  
  Returns actual timeshift in seconds.
  
  Example:
  
     $cron->set_timeshift(120);
  
     Will delay all jobs 2 minutes in the future.
  
  =cut
  
  sub set_timeshift
  {
      my $self = shift;
      my $value = shift || 0;
  
      $self->{timeshift} = $value;
      return $self->{timeshift};
  }
  
  # ==================================================
  # PRIVATE METHODS:
  # ==================================================
  
  # Build up executing queue and delete any
  # existing entries
  sub _rebuild_queue 
  { 
      my $self = shift;
      $self->{queue} = [ ];
      #dbg "TT: ",$#{$self->{time_table}};
      for my $id (0..$#{$self->{time_table}}) 
      {
          $self->_update_queue($id);
      }
  }
  
  # deeply copy an entry in the time table
  sub _deep_copy_entry
  {
      my ($self,$entry) = @_;
  
      my $args = [ @{$entry->{args}} ];
      my $copied_entry = { %$entry };
      $copied_entry->{args} = $args;
      return $copied_entry;
  }
  
  # Return an array with an arrayref of entry index and the time which should be
  # executed now
  sub _get_next_jobs {
      my $self = shift;
      my ($index,$time) = @{shift @{$self->{queue}}};
      my $indexes = [ $index ];
      while (@{$self->{queue}} && $self->{queue}->[0]->[1] == $time) {
          my $index = @{shift @{$self->{queue}}}[0];
          push @$indexes,$index;
      }
      return $indexes,$time;
  }
  
  # Execute a subroutine whose time has come
  sub _execute 
  { 
    my $self = shift;
    my $index = shift;
    my $cfg = shift || $self->{cfg};
    my $entry = $self->get_entry($index) 
      || die "Internal: No entry with index $index found in ",Dumper([$self->list_entries()]);
  
    my $pid;
  
  
    my $log = $cfg->{log};
    my $loglevel = $cfg->{loglevel} || 0;
  
    unless ($cfg->{nofork})
    {
        if ($pid = fork)
        {
            # Parent
            $log->(0,"Schedule::Cron - Forking child PID $pid") if $log && $loglevel <= 0;
            # Register PID
            $STARTEDCHILD{$pid} = 1;
            return;
        } 
    }
    
    # Child
    my $dispatch = $entry->{dispatcher};
    die "No subroutine provided with $dispatch" 
      unless ref($dispatch) eq "CODE";
    my $args = $entry->{args};
    
    my @args = ();
    if (defined($args) && defined($args->[0])) 
    {
        push @args,@$args;
    }
  
  
    if ($log && $loglevel <= 0 || !$cfg->{nofork} && !$cfg->{processname} && !$cfg->{nostatus}) {
        my $args_label = (@args && $loglevel <= -1) ? " with (".join(",",$self->_format_args(@args)).")" : "";
        $0 = $self->_get_process_prefix()." Dispatched job $index$args_label"
          unless $cfg->{nofork} || $cfg->{processname} || $cfg->{nostatus};
        $log->(0,"Schedule::Cron - Starting job $index$args_label")
          if $log && $loglevel <= 0;
    }
    my $dispatch_result;
    if ($cfg->{catch})
    {
        # Evaluate dispatcher
        eval
        {
            $dispatch_result = &$dispatch(@args);
        };
        if ($@)
        {
            $log->(2,"Schedule::Cron - Error within job $index: $@")
              if $log && $loglevel <= 2;
        }
    }
    else
    {
        # Let dispatcher die if needed.
        $dispatch_result = &$dispatch(@args);
    }
    
    if($cfg->{after_job}) {
        my $job = $cfg->{after_job};
        if (ref($job) eq "CODE") {
            eval
            {
                &$job($dispatch_result,@args);
            };
            if ($@)
            {
                $log->(2,"Schedule::Cron - Error while calling after_job callback with retval = $dispatch_result: $@")
                  if $log && $loglevel <= 2;
            }
        } else {
            $log->(2,"Schedule::Cron - Invalid after_job callback, it's not a code ref (but ",$job,")")
              if $log && $loglevel <= 2;
        }
    }
  
    $log->(0,"Schedule::Cron - Finished job $index") if $log && $loglevel <= 0;
    exit unless $cfg->{nofork};
  }
  
  # Update the scheduler queue with a new entry
  sub _update_queue 
  { 
      my $self = shift;
      my $index = shift;
      my $entry = $self->get_entry($index);
      
      my $new_time = $self->get_next_execution_time($entry->{time});
      # Check, whether next execution time is *smaller* than the current time.
      # This can happen during DST backflip:
      my $now = $self->_now();
      if ($new_time <= $now) {
          dbg "Adjusting time calculation because of DST back flip (new_time - now = ",$new_time - $now,")" if $DEBUG;
          # We are adding hours as long as our target time is in the future
          while ($new_time <= $now) {
              $new_time += 3600;
          }
      }
  
      dbg "Updating Queue: ",scalar(localtime($new_time)) if $DEBUG;
      $self->{queue} = [ sort { $a->[1] <=> $b->[1] } @{$self->{queue}},[$index,$new_time] ];
      #dbg "Queue now: ",Dumper($self->{queue});
  }
  
  
  # Out "now" which can be shifted if as argument
  sub _now { 
      my $self = shift;
      return time + $self->{timeshift};
  }
  
  # The heart of the module.
  # calculate the next concrete date
  # for execution from a crontab entry
  sub _calc_time 
  { 
      my $self = shift;
      my $now = shift;
      my $expanded = shift;
  
      my $offset = ($expanded->[5] ? 1 : 60) + $self->{timeshift};
      my ($now_sec,$now_min,$now_hour,$now_mday,$now_mon,$now_wday,$now_year) = 
        (localtime($now+$offset))[0,1,2,3,4,6,5];
      $now_mon++; 
      $now_year += 1900;
  
      # Notes on variables set:
      # $now_... : the current date, fixed at call time
      # $dest_...: date used for backtracking. At the end, it contains
      #            the desired lowest matching date
  
      my ($dest_mon,$dest_mday,$dest_wday,$dest_hour,$dest_min,$dest_sec,$dest_year) = 
        ($now_mon,$now_mday,$now_wday,$now_hour,$now_min,$now_sec,$now_year);
  
      # dbg Dumper($expanded);
  
      # Airbag...
      while ($dest_year <= $now_year + 1) 
      { 
          dbg "Parsing $dest_hour:$dest_min:$dest_sec $dest_year/$dest_mon/$dest_mday" if $DEBUG;
          
          # Check month:
          if ($expanded->[3]->[0] ne '*') 
          {
              unless (defined ($dest_mon = $self->_get_nearest($dest_mon,$expanded->[3]))) 
              {
                  $dest_mon = $expanded->[3]->[0];
                  $dest_year++;
              } 
          } 
    
          # Check for day of month:
          if ($expanded->[2]->[0] ne '*') 
          {           
              if ($dest_mon != $now_mon) 
              {      
                  $dest_mday = $expanded->[2]->[0];
              } 
              else 
              {
                  unless (defined ($dest_mday = $self->_get_nearest($dest_mday,$expanded->[2]))) 
                  {
                      # Next day matched is within the next month. ==> redo it
                      $dest_mday = $expanded->[2]->[0];
                      $dest_mon++;
                      if ($dest_mon > 12) 
                      {
                          $dest_mon = 1;
                          $dest_year++;
                      }
                      dbg "Backtrack mday: $dest_mday/$dest_mon/$dest_year" if $DEBUG;
                      next;
                  }
              }
          } 
          else 
          {
              $dest_mday = ($dest_mon == $now_mon ? $dest_mday : 1);
          }
    
          # Check for day of week:
          if ($expanded->[4]->[0] ne '*') 
          {
              $dest_wday = $self->_get_nearest($dest_wday,$expanded->[4]);
              $dest_wday = $expanded->[4]->[0] unless $dest_wday;
      
              my ($mon,$mday,$year);
              #      dbg "M: $dest_mon MD: $dest_mday WD: $dest_wday Y:$dest_year";
              $dest_mday = 1 if $dest_mon != $now_mon;
              my $t = parsedate(sprintf("%4.4d/%2.2d/%2.2d",$dest_year,$dest_mon,$dest_mday));
              ($mon,$mday,$year) =  
                (localtime(parsedate("$WDAYS[$dest_wday]",PREFER_FUTURE=>1,NOW=>$t-1)))[4,3,5]; 
              $mon++;
              $year += 1900;
              
              dbg "Calculated $mday/$mon/$year for weekday ",$WDAYS[$dest_wday] if $DEBUG;
              if ($mon != $dest_mon || $year != $dest_year) {
                  dbg "backtracking" if $DEBUG;
                  $dest_mon = $mon;
                  $dest_year = $year;
                  $dest_mday = 1;
                  $dest_wday = (localtime(parsedate(sprintf("%4.4d/%2.2d/%2.2d",
                                                            $dest_year,$dest_mon,$dest_mday))))[6];
                  next;
              }
              
              $dest_mday = $mday;
          } 
          else 
          {
              unless ($dest_mday) 
              {
                  $dest_mday = ($dest_mon == $now_mon ? $dest_mday : 1);
              }
          }
  
    
          # Check for hour
          if ($expanded->[1]->[0] ne '*') 
          {
              if ($dest_mday != $now_mday || $dest_mon != $now_mon || $dest_year != $now_year) 
              {
                  $dest_hour = $expanded->[1]->[0];
              } 
              else 
              {
                  #dbg "Checking for next hour $dest_hour";
                  unless (defined ($dest_hour = $self->_get_nearest($dest_hour,$expanded->[1]))) 
                  {
                      # Hour to match is at the next day ==> redo it
                      $dest_hour = $expanded->[1]->[0];
                      my $t = parsedate(sprintf("%2.2d:%2.2d:%2.2d %4.4d/%2.2d/%2.2d",
                                                $dest_hour,$dest_min,$dest_sec,$dest_year,$dest_mon,$dest_mday));
                      ($dest_mday,$dest_mon,$dest_year,$dest_wday) = 
                        (localtime(parsedate("+ 1 day",NOW=>$t)))[3,4,5,6];
                      $dest_mon++; 
                      $dest_year += 1900;
                      next; 
                  }
              }
          } 
          else 
          {
              $dest_hour = ($dest_mday == $now_mday ? $dest_hour : 0);
          }
          # Check for minute
          if ($expanded->[0]->[0] ne '*') 
          {
              if ($dest_hour != $now_hour || $dest_mday != $now_mday || $dest_mon != $dest_mon || $dest_year != $now_year) 
              {
                  $dest_min = $expanded->[0]->[0];
              } 
              else 
              {
                  unless (defined ($dest_min = $self->_get_nearest($dest_min,$expanded->[0]))) 
                  {
                      # Minute to match is at the next hour ==> redo it
                      $dest_min = $expanded->[0]->[0];
                      my $t = parsedate(sprintf("%2.2d:%2.2d:%2.2d %4.4d/%2.2d/%2.2d",
                                                $dest_hour,$dest_min,$dest_sec,$dest_year,$dest_mon,$dest_mday));
                      ($dest_hour,$dest_mday,$dest_mon,$dest_year,$dest_wday) = 
                        (localtime(parsedate(" + 1 hour",NOW=>$t)))  [2,3,4,5,6];
                      $dest_mon++;
                      $dest_year += 1900;
                      next;
                  }
              }
          } 
          else 
          {
              if ($dest_hour != $now_hour ||
                  $dest_mday != $now_mday ||
                  $dest_year != $now_year) {
                  $dest_min = 0;
              } 
          }
          # Check for seconds
          if ($expanded->[5])
          {
              if ($expanded->[5]->[0] ne '*')
              {
                  if ($dest_min != $now_min) 
                  {
                      $dest_sec = $expanded->[5]->[0];
                  } 
                  else 
                  {
                      unless (defined ($dest_sec = $self->_get_nearest($dest_sec,$expanded->[5]))) 
                      {
                          # Second to match is at the next minute ==> redo it
                          $dest_sec = $expanded->[5]->[0];
                          my $t = parsedate(sprintf("%2.2d:%2.2d:%2.2d %4.4d/%2.2d/%2.2d",
                                                    $dest_hour,$dest_min,$dest_sec,
                                                    $dest_year,$dest_mon,$dest_mday));
                          ($dest_min,$dest_hour,$dest_mday,$dest_mon,$dest_year,$dest_wday) = 
                            (localtime(parsedate(" + 1 minute",NOW=>$t)))  [1,2,3,4,5,6];
                          $dest_mon++;
                          $dest_year += 1900;
                          next;
                      }
                  }
              } 
              else 
              {
                  $dest_sec = ($dest_min == $now_min ? $dest_sec : 0);
              }
          }
          else
          {
              $dest_sec = 0;
          }
          
          # We did it !!
          my $date = sprintf("%2.2d:%2.2d:%2.2d %4.4d/%2.2d/%2.2d",
                             $dest_hour,$dest_min,$dest_sec,$dest_year,$dest_mon,$dest_mday);
          dbg "Next execution time: $date ",$WDAYS[$dest_wday] if $DEBUG;
          my $result = parsedate($date, VALIDATE => 1);
          # Check for a valid date
          if ($result)
          {
              # Valid date... return it!
              return $result;
          }
          else
          {
              # Invalid date i.e. (02/30/2008). Retry it with another, possibly
              # valid date            
              my $t = parsedate($date); # print scalar(localtime($t)),"\n";
              ($dest_hour,$dest_mday,$dest_mon,$dest_year,$dest_wday) =
                (localtime(parsedate(" + 1 second",NOW=>$t)))  [2,3,4,5,6];
              $dest_mon++;
              $dest_year += 1900;
              next;
          }
      }
  
      # Die with an error because we couldn't find a next execution entry
      my $dumper = new Data::Dumper($expanded);
      $dumper->Terse(1);
      $dumper->Indent(0);
  
      die "No suitable next execution time found for ",$dumper->Dump(),", now == ",scalar(localtime($now)),"\n";
  }
  
  # get next entry in list or 
  # undef if is the highest entry found
  sub _get_nearest 
  { 
    my $self = shift;
    my $x = shift;
    my $to_check = shift;
    foreach my $i (0 .. $#$to_check) 
    {
        if ($$to_check[$i] >= $x) 
        {
            return $$to_check[$i] ;
        }
    }
    return undef;
  }
  
  
  # prepare a list of object for pretty printing e.g. in the process list
  sub _format_args {
      my $self = shift;
      my @args = @_;
      my $dumper = new Data::Dumper(\@args);
      $dumper->Terse(1);
      $dumper->Maxdepth(2);
      $dumper->Indent(0);
      return $dumper->Dump();
  }
  
  # get the prefix to use when setting $0
  sub _get_process_prefix { 
      my $self = shift;
      my $prefix = $self->{cfg}->{processprefix} || "Schedule::Cron";
      return $prefix;
  }
  
  # our very own debugging routine
  # ('guess everybody has its own style ;-)
  # Callers check $DEBUG on the critical path to save the computes
  # used to produce expensive arguments.  Omitting those would be
  # functionally correct, but rather wasteful.
  sub dbg  
  {
    if ($DEBUG) 
    {
        my $args = join('',@_) || "";
        my $caller = (caller(1))[0];
        my $line = (caller(0))[2];
        $caller ||= $0;
        if (length $caller > 22) 
        {
            $caller = substr($caller,0,10)."..".substr($caller,-10,10);
        }
        print STDERR sprintf ("%02d:%02d:%02d [%22.22s %4.4s]  %s\n",
                              (localtime)[2,1,0],$caller,$line,$args);
    }
  }
  
  # Helper method for reporting bugs concerning calculation
  # of execution bug:
  *bug = \&report_exectime_bug;   # Shortcut
  sub report_exectime_bug 
  {
    my $self = shift;
    my $endless = shift;
    my $time = time;
    my $inp;
    my $now = $self->_time_as_string($time);
    my $email;
  
    do 
    {
        while (1) 
        {
            $inp = $self->_get_input("Reference time\n(default: $now)  : ");
            if ($inp) 
            {
                parsedate($inp) || (print "Couldn't parse \"$inp\"\n",next);
                $now = $inp;
            }
            last;
        }
        my $now_time = parsedate($now);
      
        my ($next_time,$next);
        my @entries;
        while (1) 
        {
            $inp = $self->_get_input("Crontab time (5 columns)            : ");
            @entries = split (/\s+/,$inp);
            if (@entries != 5) 
            {
                print "Invalid crontab entry \"$inp\"\n";
                next;
            }
            eval 
            { 
                local $SIG{ALRM} = sub {  die "TIMEOUT" };
                alarm(60);
                $next_time = Schedule::Cron->get_next_execution_time(\@entries,$now_time);
                alarm(0);
            };
            if ($@) 
            {
                alarm(0);
                if ($@ eq "TIMEOUT") 
                {
                    $next_time = -1;
                } else 
                {
                    print "Invalid crontab entry \"$inp\" ($@)\n";
                    next;
                }
            }
          
            if ($next_time > 0) 
            {
                $next = $self->_time_as_string($next_time);
            } else 
            {
                $next = "Run into infinite loop !!";
            }
            last;
        }
      
        my ($expected,$expected_time);
        while (1) 
        {
            $inp = $self->_get_input("Expected time                       : ");
            unless ($expected_time = parsedate($inp)) 
            {
                print "Couldn't parse \"$inp\"\n";
                next;
            } 
            $expected = $self->_time_as_string($expected_time);
            last;
        }
      
        # Print out bug report:
        if ($expected eq $next) 
        {
            print "\nHmm, seems that everything's ok, or ?\n\n";
            print "Calculated time: ",$next,"\n";
            print "Expected time  : ",$expected,"\n";
        } else 
        {
            print <<EOT;
  Congratulation, you hit a bug. 
  
  EOT
            $email = $self->_get_input("Your E-Mail Address (if available)  : ") 
              unless defined($email);
            $email = "" unless defined($email);
        
            print "\n","=" x 80,"\n";
            print <<EOT;
  Please report the following lines
  to roland\@cpan.org
  
  EOT
            print "# ","-" x 78,"\n";
            print "Reftime: ",$now,"\n";
            print "# Reported by : ",$email,"\n" if $email;
            printf "%8s %8s %8s %8s %8s         %s\n",@entries,$expected;
            print "# Calculated  : \n";
            printf "# %8s %8s %8s %8s %8s         %s\n",@entries,$next;
            unless ($endless) 
            {
                require Config;
                my $vers = `uname -r 2>/dev/null` || $Config::Config{'osvers'} ;
                chomp $vers;
                my $osname = `uname -s 2>/dev/null` || $Config::Config{'osname'};
                chomp $osname;
                print "# OS: $osname ($vers)\n";
                print "# Perl-Version: $]\n";
                print "# Time::ParseDate-Version: ",$Time::ParseDate::VERSION,"\n";
            }
            print "# ","-" x 78,"\n";
        }
      
        print "\n","=" x 80,"\n";
    } while ($endless);
  }
  
  my ($input_initialized,$term);
  sub _get_input 
  { 
    my $self = shift;
    my $prompt = shift;
    use vars qw($term);
  
    unless (defined($input_initialized)) 
    {
        eval { require Term::ReadLine; };
      
        $input_initialized = $@ ? 0 : 1;
        if ($input_initialized) 
        {
            $term = new Term::ReadLine;
            $term->ornaments(0);
        }
    }
    
    unless ($input_initialized) 
    {
        print $prompt;
        my $inp = <STDIN>;
        chomp $inp;
        return $inp;
    } 
    else 
    {
        chomp $prompt;
        my @prompt = split /\n/s,$prompt;
        if ($#prompt > 0)
        {
            print join "\n",@prompt[0..$#prompt-1],"\n";
        }
        my $inp = $term->readline($prompt[$#prompt]);
        return $inp;
    }
  }
  
  sub _time_as_string 
  { 
    my $self = shift;
    my $time = shift; 
  
    my ($min,$hour,$mday,$month,$year,$wday) = (localtime($time))[1..6];
    $month++;
    $year += 1900;
    $wday = $WDAYS[$wday];
    return sprintf("%2.2d:%2.2d %2.2d/%2.2d/%4.4d %s",
                   $hour,$min,$mday,$month,$year,$wday);
  }
  
  
  # As reported by RT Ticket #24712 sometimes, 
  # the expanded version of the cron entry is flaky.
  # However, this occurs only very rarely and randomly. 
  # So, we need to provide good diagnostics when this 
  # happens
  sub _verify_expanded_cron_entry {
      my $self = shift;
      my $original = shift;
      my $entry = shift;
      die "Internal: Not an array ref. Orig: ",Dumper($original), ", expanded: ",Dumper($entry)," (self = ",Dumper($self),")"
        unless ref($entry) eq "ARRAY";
      
      for my $i (0 .. $#{$entry}) {
          die "Internal: Part $i of entry is not an array ref. Original: ",
            Dumper($original),", expanded: ",Dumper($entry)," (self=",Dumper($self),")",
              unless ref($entry->[$i]) eq "ARRAY";
      }    
  }
  
  =back
  
  =head1 DST ISSUES
  
  Daylight saving occurs typically twice a year: In the first switch, one hour is
  skipped. Any job which triggers in this skipped hour will be fired in the
  next hour. So, when the DST switch goes from 2:00 to 3:00 a job which is
  scheduled for 2:43 will be executed at 3:43.
  
  For the reverse backwards switch later in the year, the behavior is
  undefined. Two possible behaviors can occur: For jobs triggered in short
  intervals, where the next execution time would fire in the extra hour as well,
  the job could be executed again or skipped in this extra hour. Currently,
  running C<Schedule::Cron> in C<MET> would skip the extra job, in C<PST8PDT> it
  would execute a second time. The reason is the way how L<Time::ParseDate>
  calculates epoch times for dates given like C<02:50:00 2009/10/25>. Should it
  return the seconds since 1970 for this time happening 'first', or for this time
  in the extra hour ? As it turns out, L<Time::ParseDate> returns the epoch time
  of the first occurrence for C<PST8PDT> and for C<MET> it returns the second
  occurrence. Unfortunately, there is no way to specify I<which> entry
  L<Time::ParseDate> should pick (until now). Of course, after all, this is
  obviously not L<Time::ParseDate>'s fault, since a simple date specification
  within the DST back-switch period B<is> ambiguous. However, it would be nice if
  the parsing behavior of L<Time::ParseDate> would be consistent across time
  zones (a ticket has be raised for fixing this). Then L<Schedule::Cron>'s
  behavior within a DST backward switch would be consistent as well.
  
  Since changing the internal algorithm which worked now for over ten years would
  be too risky and I don't see any simple solution for this right now, it is
  likely that this I<undefined> behavior will exist for some time. Maybe some
  hero is coming along and will fix this, but this is probably not me ;-)
  
  Sorry for that.
  
  =head1 AUTHORS
  
  Roland Huß <roland@consol.de>
  
  Currently maintained by Nicholas Hubbard <nicholashubbard@posteo.net>
  
  =head1 CONTRIBUTORS
  
  =over 4
  
  =item *
  
  Alexandr Ciornii <alexchorny@gmail.com>
  
  =item *
  
  Andrew Danforth
  
  =item *
  
  Andy Ford
  
  =item *
  
  Bray Jones
  
  =item *
  
  Clinton Gormley
  
  =item *
  
  Eric Wilhelm
  
  =item *
  
  Frank Mayer
  
  =item *
  
  Jamie McCarthy
  
  =item *
  
  Loic Paillotin
  
  =item *
  
  Nicholas Hubbard <nicholashubbard@posteo.net>
  
  =item *
  
  Peter Vary
  
  =item *
  
  Philippe Verdret
  
  =back
  
  =head1 COPYRIGHT AND LICENSE
  
  Copyright (c) 1999-2013 Roland Huß.
  
  Copyright (c) 2022-2023 Nicholas Hubbard.
  
  This library is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself.
  
  =cut
  
  1;
SCHEDULE_CRON

$fatpacked{"Time/CTime.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TIME_CTIME';
  package Time::CTime;
  
  
  require 5.000;
  
  use Time::Timezone;
  use Time::CTime;
  require Exporter;
  @ISA = qw(Exporter);
  @EXPORT = qw(ctime asctime strftime);
  @EXPORT_OK = qw(asctime_n ctime_n @DoW @MoY @DayOfWeek @MonthOfYear);
  
  use strict;
  
  # constants
  use vars qw(@DoW @DayOfWeek @MoY @MonthOfYear %strftime_conversion $VERSION);
  use vars qw($template $sec $min $hour $mday $mon $year $wday $yday $isdst);
  
  $VERSION = 2011.0505;
  
  CONFIG: {
      @DoW = 	   qw(Sun Mon Tue Wed Thu Fri Sat);
      @DayOfWeek =   qw(Sunday Monday Tuesday Wednesday Thursday Friday Saturday);
      @MoY = 	   qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
      @MonthOfYear = qw(January February March April May June 
  		      July August September October November December);
    
      %strftime_conversion = (
  	'%',	sub { '%' },
  	'a',	sub { $DoW[$wday] },
  	'A',	sub { $DayOfWeek[$wday] },
  	'b',	sub { $MoY[$mon] },
  	'B',	sub { $MonthOfYear[$mon] },
  	'c',	sub { asctime_n($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst, "") },
  	'd',	sub { sprintf("%02d", $mday); },
  	'D',	sub { sprintf("%02d/%02d/%02d", $mon+1, $mday, $year%100) },
  	'e',	sub { sprintf("%2d", $mday); },
  	'f',	sub { fracprintf ("%3.3f", $sec); },
  	'F',	sub { fracprintf ("%6.6f", $sec); },
  	'h',	sub { $MoY[$mon] },
  	'H',	sub { sprintf("%02d", $hour) },
  	'I',	sub { sprintf("%02d", $hour % 12 || 12) },
  	'j',	sub { sprintf("%03d", $yday + 1) },
  	'k',	sub { sprintf("%2d", $hour); },
  	'l',	sub { sprintf("%2d", $hour % 12 || 12) },
  	'm',	sub { sprintf("%02d", $mon+1); },
  	'M',	sub { sprintf("%02d", $min) },
  	'n',	sub { "\n" },
  	'o',	sub { sprintf("%d%s", $mday, (($mday < 20 && $mday > 3) ? 'th' : ($mday%10 == 1 ? "st" : ($mday%10 == 2 ? "nd" : ($mday%10 == 3 ? "rd" : "th"))))) },
  	'p',	sub { $hour > 11 ? "PM" : "AM" },
  	'r',	sub { sprintf("%02d:%02d:%02d %s", $hour % 12 || 12, $min, $sec, $hour > 11 ? 'PM' : 'AM') },
  	'R',	sub { sprintf("%02d:%02d", $hour, $min) },
  	'S',	sub { sprintf("%02d", $sec) },
  	't',	sub { "\t" },
  	'T',	sub { sprintf("%02d:%02d:%02d", $hour, $min, $sec) },
  	'U',	sub { wkyr(0, $wday, $yday) },
  	'v',	sub { sprintf("%2d-%s-%4d", $mday, $MoY[$mon], $year+1900) },
  	'w',	sub { $wday },
  	'W',	sub { wkyr(1, $wday, $yday) },
  	'y',	sub { sprintf("%02d",$year%100) },
  	'Y',	sub { $year + 1900 },
  	'x',	sub { sprintf("%02d/%02d/%02d", $mon + 1, $mday, $year%100) },
  	'X',	sub { sprintf("%02d:%02d:%02d", $hour, $min, $sec) },
  	'Z',	sub { &tz2zone(undef,undef,$isdst) }
  	# z sprintf("%+03d%02d", $offset / 3600, ($offset % 3600)/60);
      );
  
  
  }
  
  sub fracprintf {
      my($t,$s) = @_;
      my($p) = sprintf($t, $s-int($s));
      $p=~s/^0+//;
      $p;
  }
  
  sub asctime_n {
      my($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst, $TZname) = @_;
      ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst, $TZname) = localtime($sec) unless defined $min;
      $year += 1900;
      $TZname .= ' ' 
  	if $TZname;
      sprintf("%s %s %2d %2d:%02d:%02d %s%4d",
  	  $DoW[$wday], $MoY[$mon], $mday, $hour, $min, $sec, $TZname, $year);
  }
  
  sub asctime
  {
      return asctime_n(@_)."\n";
  }
  
  # is this formula right?
  sub wkyr {
      my($wstart, $wday, $yday) = @_;
      $wday = ($wday + 7 - $wstart) % 7;
      return int(($yday - $wday + 13) / 7 - 1);
  }
  
  # ctime($time)
  
  sub ctime {
      my($time) = @_;
      asctime(localtime($time), &tz2zone(undef,$time));
  }
  
  sub ctime_n {
      my($time) = @_;
      asctime_n(localtime($time), &tz2zone(undef,$time));
  }
  
  # strftime($template, @time_struct)
  #
  # Does not support locales
  
  sub strftime {			
      local ($template, $sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) = @_;
  
      undef $@;
      $template =~ s/%([%aAbBcdDefFhHIjklmMnopQrRStTUvwWxXyYZ])/&{$Time::CTime::strftime_conversion{$1}}()/egs;
      die $@ if $@;
      return $template;
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Time::CTime -- format times ala POSIX asctime
  
  =head1 SYNOPSIS
  
  	use Time::CTime
   	print ctime(time);
  	print asctime(localtime(time));
  	print strftime(template, localtime(time)); 
  
  =head2 strftime conversions
  
  	%%	PERCENT
  	%a	day of the week abbr
  	%A	day of the week
  	%b	month abbr
  	%B 	month
  	%c 	ctime format: Sat Nov 19 21:05:57 1994
  	%d 	DD
  	%D 	MM/DD/YY
  	%e 	numeric day of the month
  	%f 	floating point seconds (milliseconds): .314
  	%F 	floating point seconds (microseconds): .314159
  	%h 	month abbr
  	%H 	hour, 24 hour clock, leading 0's)
  	%I 	hour, 12 hour clock, leading 0's)
  	%j 	day of the year
  	%k 	hour
  	%l 	hour, 12 hour clock
  	%m 	month number, starting with 1, leading 0's
  	%M 	minute, leading 0's
  	%n 	NEWLINE
  	%o	ornate day of month -- "1st", "2nd", "25th", etc.
  	%p 	AM or PM 
  	%r 	time format: 09:05:57 PM
  	%R 	time format: 21:05
  	%S 	seconds, leading 0's
  	%t 	TAB
  	%T 	time format: 21:05:57
  	%U 	week number, Sunday as first day of week
  	%v	DD-Mon-Year
  	%w 	day of the week, numerically, Sunday == 0
  	%W 	week number, Monday as first day of week
  	%x 	date format: 11/19/94
  	%X 	time format: 21:05:57
  	%y	year (2 digits)
  	%Y	year (4 digits)
  	%Z 	timezone in ascii. eg: PST
  
  =head1 DESCRIPTION
  
  This module provides routines to format dates.  They correspond 
  to the libc routines.  &strftime() supports a pretty good set of
  conversions -- more than most C libraries.
   
  strftime supports a pretty good set of conversions.  
  
  The POSIX module has very similar functionality.  You should consider
  using it instead if you do not have allergic reactions to system 
  libraries.
  
  =head1 GENESIS
  
  Written by David Muir Sharnoff <muir@idiom.org>.
  
  The starting point for this package was a posting by 
  Paul Foley <paul@ascent.com> 
  
  =head1 LICENSE
  
  Copyright (C) 1996-2010 David Muir Sharnoff.  
  Copyright (C) 2011 Google, Inc.  
  License hereby
  granted for anyone to use, modify or redistribute this module at
  their own risk.  Please feed useful changes back to cpan@dave.sharnoff.org.
  
TIME_CTIME

$fatpacked{"Time/DaysInMonth.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TIME_DAYSINMONTH';
  package Time::DaysInMonth;
  
  use Carp;
  
  require 5.000;
  
  @ISA = qw(Exporter);
  @EXPORT = qw(days_in is_leap);
  @EXPORT_OK = qw(%mltable);
  
  use strict;
  
  use vars qw($VERSION %mltable);
  
  $VERSION = 99.1117;
  
  CONFIG:	{
  	%mltable = qw(
  		 1	31
  		 3	31
  		 4	30
  		 5	31
  		 6	30
  		 7	31
  		 8	31
  		 9	30
  		10	31
  		11	30
  		12	31);
  }
  
  sub days_in
  {
  	# Month is 1..12
  	my ($year, $month) = @_;
  	return $mltable{$month+0} unless $month == 2;
  	return 28 unless &is_leap($year);
  	return 29;
  }
  
  sub is_leap
  {
  	my ($year) = @_;
  	return 0 unless $year % 4 == 0;
  	return 1 unless $year % 100 == 0;
  	return 0 unless $year % 400 == 0;
  	return 1;
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Time::DaysInMonth -- simply report the number of days in a month
  
  =head1 SYNOPSIS
  
  	use Time::DaysInMonth;
  	$days = days_in($year, $month_1_to_12);
  	$leapyear = is_leap($year);
  
  =head1 DESCRIPTION
  
  DaysInMonth is simply a package to report the number of days in
  a month.  That's all it does.  Really!
  
  =head1 AUTHOR
  
  David Muir Sharnoff <muir@idiom.org>
  
  =head1 BUGS
  
  This only deals with the "modern" calendar.  Look elsewhere for 
  historical time and date support.
  
  =head1 LICENSE
  
  Copyright (C) 1996-1999 David Muir Sharnoff.  License hereby
  granted for anyone to use, modify or redistribute this module at
  their own risk.  Please feed useful changes back to muir@idiom.org.
  
TIME_DAYSINMONTH

$fatpacked{"Time/JulianDay.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TIME_JULIANDAY';
  package Time::JulianDay;
  
  require 5.000;
  
  use Carp;
  use Time::Timezone;
  
  @ISA = qw(Exporter);
  @EXPORT = qw(julian_day inverse_julian_day day_of_week 
  	jd_secondsgm jd_secondslocal 
  	jd_timegm jd_timelocal 
  	gm_julian_day local_julian_day 
  	);
  @EXPORT_OK = qw($brit_jd);
  
  use strict;
  use integer;
  
  # constants
  use vars qw($brit_jd $jd_epoch $jd_epoch_remainder $VERSION);
  
  $VERSION = 2011.0505;
  
  # calculate the julian day, given $year, $month and $day
  sub julian_day
  {
      my($year, $month, $day) = @_;
      my($tmp);
  
      use Carp;
  #    confess() unless defined $day;
  
      $tmp = $day - 32075
        + 1461 * ( $year + 4800 - ( 14 - $month ) / 12 )/4
        + 367 * ( $month - 2 + ( ( 14 - $month ) / 12 ) * 12 ) / 12
        - 3 * ( ( $year + 4900 - ( 14 - $month ) / 12 ) / 100 ) / 4
        ;
  
      return($tmp);
  
  }
  
  sub gm_julian_day
  {
      my($secs) = @_;
      my($sec, $min, $hour, $mon, $year, $day, $month);
      ($sec, $min, $hour, $day, $mon, $year) = gmtime($secs);
      $month = $mon + 1;
      $year += 1900;
      return julian_day($year, $month, $day)
  }
  
  sub local_julian_day
  {
      my($secs) = @_;
      my($sec, $min, $hour, $mon, $year, $day, $month);
      ($sec, $min, $hour, $day, $mon, $year) = localtime($secs);
      $month = $mon + 1;
      $year += 1900;
      return julian_day($year, $month, $day)
  }
  
  sub day_of_week
  {
  	my ($jd) = @_;
          return (($jd + 1) % 7);       # calculate weekday (0=Sun,6=Sat)
  }
  
  
  # The following defines the first day that the Gregorian calendar was used
  # in the British Empire (Sep 14, 1752).  The previous day was Sep 2, 1752
  # by the Julian Calendar.  The year began at March 25th before this date.
  
  $brit_jd = 2361222;
  
  # Usage:  ($year,$month,$day) = &inverse_julian_day($julian_day)
  sub inverse_julian_day
  {
          my($jd) = @_;
          my($jdate_tmp);
          my($m,$d,$y);
  
          carp("warning: julian date $jd pre-dates British use of Gregorian calendar\n")
                  if ($jd < $brit_jd);
  
          $jdate_tmp = $jd - 1721119;
          $y = (4 * $jdate_tmp - 1)/146097;
          $jdate_tmp = 4 * $jdate_tmp - 1 - 146097 * $y;
          $d = $jdate_tmp/4;
          $jdate_tmp = (4 * $d + 3)/1461;
          $d = 4 * $d + 3 - 1461 * $jdate_tmp;
          $d = ($d + 4)/4;
          $m = (5 * $d - 3)/153;
          $d = 5 * $d - 3 - 153 * $m;
          $d = ($d + 5) / 5;
          $y = 100 * $y + $jdate_tmp;
          if($m < 10) {
                  $m += 3;
          } else {
                  $m -= 9;
                  ++$y;
          }
          return ($y, $m, $d);
  }
  
  {
  	my($sec, $min, $hour, $day, $mon, $year) = gmtime(0);
  	$year += 1900;
  	if ($year == 1970 && $mon == 0 && $day == 1) {
  		# standard unix time format
  		$jd_epoch = 2440588;
  	} else {
  		$jd_epoch = julian_day($year, $mon+1, $day);
  	}
  	$jd_epoch_remainder = $hour*3600 + $min*60 + $sec;
  }
  
  sub jd_secondsgm
  {
  	my($jd, $hr, $min, $sec) = @_;
  
  	my($r) =  (($jd - $jd_epoch) * 86400 
  		+ $hr * 3600 + $min * 60 
  		- $jd_epoch_remainder);
  
  	no integer;
  	return ($r + $sec);
  	use integer;
  }
  
  sub jd_secondslocal
  {
  	my($jd, $hr, $min, $sec) = @_;
  	my $jds = jd_secondsgm($jd, $hr, $min, $sec);
  	return $jds - tz_local_offset($jds);
  }
  
  # this uses a 0-11 month to correctly reverse localtime()
  sub jd_timelocal
  {
  	my ($sec,$min,$hours,$mday,$mon,$year) = @_;
  	$year += 1900 unless $year > 1000;
  	my $jd = julian_day($year, $mon+1, $mday);
  	my $jds = jd_secondsgm($jd, $hours, $min, $sec);
  	return $jds - tz_local_offset($jds);
  }
  
  # this uses a 0-11 month to correctly reverse gmtime()
  sub jd_timegm
  {
  	my ($sec,$min,$hours,$mday,$mon,$year) = @_;
  	$year += 1900 unless $year > 1000;
  	my $jd = julian_day($year, $mon+1, $mday);
  	return jd_secondsgm($jd, $hours, $min, $sec);
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Time::JulianDay -- Julian calendar manipulations
  
  =head1 SYNOPSIS
  
  	use Time::JulianDay
  
  	$jd = julian_day($year, $month_1_to_12, $day)
  	$jd = local_julian_day($seconds_since_1970);
  	$jd = gm_julian_day($seconds_since_1970);
  	($year, $month_1_to_12, $day) = inverse_julian_day($jd)
  	$dow = day_of_week($jd) 
  
  	print (Sun,Mon,Tue,Wed,Thu,Fri,Sat)[$dow];
  
  	$seconds_since_jan_1_1970 = jd_secondslocal($jd, $hour, $min, $sec)
  	$seconds_since_jan_1_1970 = jd_secondsgm($jd, $hour, $min, $sec)
  	$seconds_since_jan_1_1970 = jd_timelocal($sec,$min,$hours,$mday,$month_0_to_11,$year)
  	$seconds_since_jan_1_1970 = jd_timegm($sec,$min,$hours,$mday,$month_0_to_11,$year)
  
  =head1 DESCRIPTION
  
  JulianDay is a package that manipulates dates as number of days since 
  some time a long time ago.  It's easy to add and subtract time
  using julian days...  
  
  The day_of_week returned by day_of_week() is 0 for Sunday, and 6 for
  Saturday and everything else is in between.
  
  =head1 ERRATA
  
  Time::JulianDay is not a correct implementation.  There are two
  problems.  The first problem is that Time::JulianDay only works
  with integers.  Julian Day can be fractional to represent time
  within a day.  If you call inverse_julian_day() with a non-integer
  time, it will often give you an incorrect result.
  
  The second problem is that Julian Days start at noon rather than
  midnight.  The julian_day() function returns results that are too
  large by 0.5.
  
  What to do about these problems is currently open for debate.  I'm
  tempted to leave the current functions alone and add a second set
  with more accurate behavior.
  
  There is another implementation in Astro::Time that may be more accurate.
  
  =head1 GENESIS
  
  Written by David Muir Sharnoff <cpan@dave.sharnoff.org> with help from
  previous work by 
  Kurt Jaeger aka PI <zrzr0111@helpdesk.rus.uni-stuttgart.de>
   	based on postings from: Ian Miller <ian_m@cix.compulink.co.uk>;
  Gary Puckering <garyp%cognos.uucp@uunet.uu.net>
  	based on Collected Algorithms of the ACM ?;
  and the unknown-to-me author of Time::Local.
  
  =head1 LICENSE
  
  Copyright (C) 1996-1999 David Muir Sharnoff.  License hereby
  granted for anyone to use, modify or redistribute this module at
  their own risk.  Please feed useful changes back to cpan@dave.sharnoff.org.
  
TIME_JULIANDAY

$fatpacked{"Time/ParseDate.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TIME_PARSEDATE';
  package Time::ParseDate;
  
  require 5.000;
  
  use Carp;
  use Time::Timezone;
  use Time::JulianDay;
  require Exporter;
  @ISA = qw(Exporter);
  @EXPORT = qw(parsedate);
  @EXPORT_OK = qw(pd_raw %mtable %umult %wdays);
  
  use strict;
  #use diagnostics;
  
  # constants
  use vars qw(%mtable %umult %wdays $VERSION);
  
  $VERSION = 2015.1030;
  
  # globals
  use vars qw($debug); 
  
  # dynamically-scoped
  use vars qw($parse);
  
  my %mtable;
  my %umult;
  my %wdays;
  my $y2k;
  
  CONFIG:	{
  
  	%mtable = qw(
  		Jan 1	Jan. 1	January 1
  		Feb 2	Feb. 2	February 2
  		Mar 3	Mar. 3	March 3
  		Apr 4	Apr. 4	April 4
  		May 5 
  		Jun 6	Jun. 6	June 6 
  		Jul 7	Jul. 7	July 7 
  		Aug 8	Aug. 8	August 8 
  		Sep 9	Sep. 9	September 9 Sept 9
  		Oct 10	Oct. 10	October 10 
  		Nov 11	Nov. 11	November 11 
  		Dec 12	Dec. 12	December 12 );
  	%umult = qw(
  		sec 1 second 1
  		min 60 minute 60
  		hour 3600
  		day 86400
  		week 604800 
  		fortnight 1209600);
  	%wdays = qw(
  		sun 0 sunday 0
  		mon 1 monday 1
  		tue 2 tuesday 2
  		wed 3 wednesday 3
  		thu 4 thursday 4
  		fri 5 friday 5
  		sat 6 saturday 6
  		);
  
  	$y2k = 946684800; # turn of the century
  }
  
  my $break = qr{(?:\s+|\Z|\b(?![-:.,/]\d))};
  
  sub parsedate
  {
  	my ($t, %options) = @_;
  
  	my ($y, $m, $d);	# year, month - 1..12, day
  	my ($H, $M, $S);	# hour, minute, second
  	my $tz;		 	# timezone
  	my $tzo;		# timezone offset
  	my ($rd, $rs);		# relative days, relative seconds
  
  	my $rel; 		# time&|date is relative
  
  	my $isspec;
  	my $now = defined($options{NOW}) ? $options{NOW} : time;
  	my $passes = 0;
  	my $uk = defined($options{UK}) ? $options{UK} : 0;
  
  	local $parse = '';  # will be dynamically scoped.
  
  	if ($t =~ s#^   ([ \d]\d) 
  			/ (Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec)
  			/ (\d\d\d\d)
  			: (\d\d)
  			: (\d\d)
  			: (\d\d)
  			(?:
  			 [ ]
  			 ([-+] \d\d\d\d)
  			  (?: \("?(?:(?:[A-Z]{1,4}[TCW56])|IDLE)\))?
  			 )?
  			 $break
  			##xi) { #"emacs
  		# [ \d]/Mon/yyyy:hh:mm:ss [-+]\d\d\d\d
  		# This is the format for www server logging.
  
  		($d, $m, $y, $H, $M, $S, $tzo) = ($1, $mtable{"\u\L$2"}, $3, $4, $5, $6, $7 ? &mkoff($7) : ($tzo || undef));
  		$parse .= " ".__LINE__ if $debug;
  	} elsif ($t =~ s#^(\d\d)/(\d\d)/(\d\d)\.(\d\d)\:(\d\d)($break)##) {
  		# yy/mm/dd.hh:mm
  		# I support this format because it's used by wbak/rbak
  		# on Apollo Domain OS.  Silly, but historical.
  
  		($y, $m, $d, $H, $M, $S) = ($1, $2, $3, $4, $5, 0);
  		$parse .= " ".__LINE__ if $debug;
  	} else {
  		while(1) {
  			if (! defined $m and ! defined $rd and ! defined $y
  				and ! ($passes == 0 and $options{'TIMEFIRST'}))
  			{
  				# no month defined.
  				if (&parse_date_only(\$t, \$y, \$m, \$d, $uk)) {
  					$parse .= " ".__LINE__ if $debug;
  					next;
  				}
  			}
  			if (! defined $H and ! defined $rs) {
  				if (&parse_time_only(\$t, \$H, \$M, \$S, 
  					\$tz, %options)) 
  				{
  					$parse .= " ".__LINE__ if $debug;
  					next;
  				}
  			}
  			next if $passes == 0 and $options{'TIMEFIRST'};
  			if (! defined $y) {
  				if (&parse_year_only(\$t, \$y, $now, %options)) {
  					$parse .= " ".__LINE__ if $debug;
  					next;
  				}
  			}
  			if (! defined $tz and ! defined $tzo and ! defined $rs 
  				and (defined $m or defined $H)) 
  			{
  				if (&parse_tz_only(\$t, \$tz, \$tzo)) {
  					$parse .= " ".__LINE__ if $debug;
  					next;
  				}
  			}
  			if (! defined $H and ! defined $rs) {
  				if (&parse_time_offset(\$t, \$rs, %options)) {
  					$rel = 1;
  					$parse .= " ".__LINE__ if $debug;
  					next;
  				}
  			}
  			if (! defined $m and ! defined $rd and ! defined $y) {
  				if (&parse_date_offset(\$t, $now, \$y, 
  					\$m, \$d, \$rd, \$rs, %options)) 
  				{
  					$rel = 1;
  					$parse .= " ".__LINE__ if $debug;
  					next;
  				}
  			}
  			if (defined $M or defined $rd) {
  				if ($t =~ s/^\s*(?:at|\@|\+)($break)//x) {
  					$rel = 1;
  					$parse .= " ".__LINE__ if $debug;
  					next;
  				}
  			}
  			last;
  		} continue {
  			$passes++;
  			&debug_display($tz, $tzo, $H, $M, $S, $m, $d, $y, $rs, $rd, $rel, $passes, $parse, $t) if $debug;
  
  		}
  
  		if ($passes == 0) {
  			print "nothing matched\n" if $debug;
  			return (undef, "no match on time/date") 
  				if wantarray();
  			return undef;
  		}
  	}
  
  	&debug_display($tz, $tzo, $H, $M, $S, $m, $d, $y, $rs, $rd, $rel, $passes, $parse, $t) if $debug;
  
  	$t =~ s/^\s+//;
  
  	if ($t ne '') {
  		# we didn't manage to eat the string
  		print "NOT WHOLE\n" if $debug;
  		if ($options{WHOLE}) {
  			return (undef, "characters left over after parse")
  				if wantarray();
  			return undef 
  		}
  	}
  
  	# define a date if there isn't one already
  
  	if (! defined $y and ! defined $m and ! defined $rd) {
  		print "no date defined, trying to find one." if $debug;
  		if (defined $rs or defined $H) {
  			# we do have a time.
  			if ($options{DATE_REQUIRED}) {
  				return (undef, "no date specified")
  					if wantarray();
  				return undef;
  			}
  			if (defined $rs) {
  				print "simple offset: $rs\n" if $debug;
  				my $rv = $now + $rs;
  				return ($rv, $t) if wantarray();
  				return $rv;
  			}
  			$rd = 0;
  		} else {
  			print "no time either!\n" if $debug;
  			return (undef, "no time specified")
  				if wantarray();
  			return undef;
  		}
  	}
  
  	if ($options{TIME_REQUIRED} && ! defined($rs) 
  		&& ! defined($H) && ! defined($rd))
  	{
  		return (undef, "no time found")
  			if wantarray();
  		return undef;
  	}
  
  	my $secs;
  	my $jd;
  
  	if (defined $rd) {
  		if (defined $rs || ! (defined($H) || defined($M) || defined($S))) {
  			print "fully relative\n" if $debug;
  			my ($j, $in, $it);
  			my $definedrs = defined($rs) ? $rs : 0;
  			my ($isdst_now, $isdst_then);
  			my $r = $now + $rd * 86400 + $definedrs;
  			#
  			# It's possible that there was a timezone shift 
  			# during the time specified.  If so, keep the
  			# hours the "same".
  			#
  			$isdst_now = (localtime($r))[8];
  			$isdst_then = (localtime($now))[8];
  			if (($isdst_now == $isdst_then) || $options{GMT})
  			{
  				return ($r, $t) if wantarray();
  				return $r 
  			}
  				
  			print "localtime changed DST during time period!\n" if $debug;
  		}
  
  		print "relative date\n" if $debug;
  		$jd = $options{GMT}
  			? gm_julian_day($now)
  			: local_julian_day($now);
  		print "jd($now) = $jd\n" if $debug;
  		$jd += $rd;
  	} else {
  		unless (defined $y) {
  			if ($options{PREFER_PAST}) {
  				my ($day, $mon011);
  				($day, $mon011, $y) = (&righttime($now))[3,4,5];
  
  				print "calc year -past $day-$d $mon011-$m $y\n" if $debug;
  				$y -= 1 if ($mon011+1 < $m) || 
  					(($mon011+1 == $m) && ($day < $d));
  			} elsif ($options{PREFER_FUTURE}) {
  				print "calc year -future\n" if $debug;
  				my ($day, $mon011);
  				($day, $mon011, $y) = (&righttime($now))[3,4,5];
  				$y += 1 if ($mon011 >= $m) || 
  					(($mon011+1 == $m) && ($day > $d));
  			} else {
  				print "calc year -this\n" if $debug;
  				$y = (localtime($now))[5];
  			}
  			$y += 1900;
  		}
  
  		$y = expand_two_digit_year($y, $now, %options)
  			if $y < 100;
  
  		if ($options{VALIDATE}) {
  			require Time::DaysInMonth;
  			my $dim = Time::DaysInMonth::days_in($y, $m);
  			if ($y < 1000 or $m < 1 or $d < 1 
  				or $y > 9999 or $m > 12 or $d > $dim)
  			{
  				return (undef, "illegal YMD: $y, $m, $d")
  					if wantarray();
  				return undef;
  			}
  		}
  		$jd = julian_day($y, $m, $d);
  		print "jd($y, $m, $d) = $jd\n" if $debug;
  	}
  
  	# put time into HMS
  
  	if (! defined($H)) {
  		if (defined($rd) || defined($rs)) {
  			($S, $M, $H) = &righttime($now, %options);
  			print "HMS set to $H $M $S\n" if $debug;
  		} 
  	}
  
  	my $carry;
  
  	print "before ", (defined($rs) ? "$rs" : ""),
  		    " $jd $H $M $S\n" 
  		if $debug;
  	#
  	# add in relative seconds.  Do it this way because we want to
  	# preserve the localtime across DST changes.
  	#
  
  	$S = 0 unless $S; # -w
  	$M = 0 unless $M; # -w
  	$H = 0 unless $H; # -w
  
  	if ($options{VALIDATE} and
  		($S < 0 or $M < 0 or $H < 0 or $S > 59 or $M > 59 or $H > 23)) 
  	{
  		return (undef, "illegal HMS: $H, $M, $S") if wantarray();
  		return undef;
  	}
  
  	$S += $rs if defined $rs;
  	$carry = int($S / 60) - ($S < 0 && $S % 60 && 1);
  	$S -= $carry * 60;
  	$M += $carry;
  	$carry = int($M / 60) - ($M < 0 && $M % 60 && 1);
  	$M %= 60;
  	$H += $carry;
  	$carry = int($H / 24) - ($H < 0 && $H % 24 && 1);
  	$H %= 24;
  	$jd += $carry;
  
  	print "after rs  $jd $H $M $S\n" if $debug;
  
  	$secs = jd_secondsgm($jd, $H, $M, $S);
  	print "jd_secondsgm($jd, $H, $M, $S) = $secs\n" if $debug;
  
  	# 
  	# If we see something link 3pm CST then and we want to end
  	# up with a GMT seconds, then we convert the 3pm to GMT and
  	# subtract in the offset for CST.  We subtract because we
  	# are converting from CST to GMT.
  	#
  	my $tzadj;
  	if ($tz) {
  		$tzadj = tz_offset($tz, $secs);
  		if (defined $tzadj) {
  			print "adjusting secs for $tz: $tzadj\n" if $debug;
  			$tzadj = tz_offset($tz, $secs-$tzadj);
  			$secs -= $tzadj;
  		} else {
  			print "unknown timezone: $tz\n" if $debug;
  			undef $secs;
  			undef $t;
  		}
  	} elsif (defined $tzo) {
  		print "adjusting time for offset: $tzo\n" if $debug;
  		$secs -= $tzo;
  	} else {
  		unless ($options{GMT}) {
  			if ($options{ZONE}) {
  				$tzadj = tz_offset($options{ZONE}, $secs) || 0;
  				$tzadj = tz_offset($options{ZONE}, $secs-$tzadj);
  				unless (defined($tzadj)) {
  					return (undef, "could not convert '$options{ZONE}' to time offset")
  						if wantarray();
  					return undef;
  				}
  				print "adjusting secs for $options{ZONE}: $tzadj\n" if $debug;
  				$secs -= $tzadj;
  			} else {
  				$tzadj = tz_local_offset($secs);
  				print "adjusting secs for local offset: $tzadj\n" if $debug;
  				# 
  				# Just in case we are very close to a time
  				# change...
  				#
  				$tzadj = tz_local_offset($secs-$tzadj);
  				$secs -= $tzadj;
  			}
  		}
  	}
  
  	print "returning $secs.\n" if $debug;
  
  	return ($secs, $t) if wantarray();
  	return $secs;
  }
  
  
  sub mkoff
  {
  	my($offset) = @_;
  
  	if (defined $offset and $offset =~ s#^([-+])(\d\d):?(\d\d)$##) {
  		return ($1 eq '+' ? 
  			  3600 * $2  + 60 * $3
  			: -3600 * $2 + -60 * $3 );
  	}
  	return undef;
  }
  
  sub parse_tz_only
  {
  	my($tr, $tz, $tzo) = @_;
  
  	$$tr =~ s#^\s+##;
  	my $o;
  
  	if ($$tr =~ s#^
  			([-+]\d\d:?\d\d)
  			\s+
  			\(
  				"?
  				(?:
  					(?:
  						[A-Z]{1,4}[TCW56]
  					)
  					|
  					IDLE
  				)
  			\)
  			$break
  			##x) { #"emacs
  		$$tzo = &mkoff($1);
  		printf "matched at %d.\n", __LINE__ if $debug;
  		return 1;
  	} elsif ($$tr =~ s#^GMT\s*([-+]\d{1,2})($break)##x) {
  		$o = $1;
  		if ($o < 24 and $o !~ /^0/) {
  			# probably hours.
  			printf "adjusted at %d. ($o 00)\n", __LINE__ if $debug;
  			$o = "${o}00";
  		}
  		$o =~ s/\b(\d\d\d)/0$1/;
  		$$tzo = &mkoff($o);
  		printf "matched at %d. ($$tzo, $o)\n", __LINE__ if $debug;
  		return 1;
  	} elsif ($$tr =~ s#^(?:GMT\s*)?([-+]\d\d:?\d\d)($break)##x) {
  		$o = $1;
  		$$tzo = &mkoff($o);
  		printf "matched at %d.\n", __LINE__ if $debug;
  		return 1;
  	} elsif ($$tr =~ s#^"?((?:[A-Z]{1,4}[TCW56])|IDLE)$break##x) { #"
  		$$tz = $1;
  		$$tz .= " DST" 
  			if $$tz eq 'MET' && $$tr =~ s#^DST$break##x;
  		printf "matched at %d: '$$tz'.\n", __LINE__ if $debug;
  		return 1;
  	}
  	return 0;
  }
  
  sub parse_date_only
  {
  	my ($tr, $yr, $mr, $dr, $uk) = @_;
  
  	$$tr =~ s#^\s+##;
  
  	if ($$tr =~ s#^(\d\d\d\d)([-./])(\d\d?)\2(\d\d?)(T|$break)##) {
  		# yyyy/mm/dd
  
  		($$yr, $$mr, $$dr) = ($1, $3, $4);
  		printf "matched at %d.\n", __LINE__ if $debug;
  		return 1;
  	} elsif ($$tr =~ s#^(\d\d?)([-./])(\d\d?)\2(\d\d\d\d?)($break)##) {
  		# mm/dd/yyyy - is this safe?  No.
  		# -- or dd/mm/yyyy! If $1>12, then it's unambiguous.
  		# Otherwise check option UK for UK style date.
  		if ($uk || $1>12) {
  		  ($$yr, $$mr, $$dr) = ($4, $3, $1);
  		} else {
  		  ($$yr, $$mr, $$dr) = ($4, $1, $3);
  		}
  		printf "matched at %d.\n", __LINE__ if $debug;
  		return 1;
  	} elsif ($$tr =~ s#^(\d\d\d\d)/(\d\d?)$break##x) {
  		# yyyy/mm
  
  		($$yr, $$mr, $$dr) = ($1, $2, 1);
  		printf "matched at %d.\n", __LINE__ if $debug;
  		return 1;
  	} elsif ($$tr =~ s#^(?xi)
  			(?:
  				(?:Mon|Monday|Tue|Tuesday|Wed|Wednesday|
  					Thu|Thursday|Fri|Friday|
  					Sat|Saturday|Sun|Sunday),?
  				\s+
  			)?
  			(\d\d?)
  			(\s+ | - | \. | /)
  			(Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec)\.?
  			(?:
  				\2
  				(\d\d (?:\d\d)? )
  			)?
  			$break
  			##) {
  		# [Dow,] dd Mon [yy[yy]]
  		($$yr, $$mr, $$dr) = ($4, $mtable{"\u\L$3"}, $1);
  
  		printf "%d: %s - %s - %s\n", __LINE__, $1, $2, $3 if $debug;
  		print "y undef\n" if ($debug && ! defined($$yr));
  		return 1;
  	} elsif ($$tr =~ s#^(?xi)
  			(?:
  				(?:Mon|Monday|Tue|Tuesday|Wed|Wednesday|
  					Thu|Thursday|Fri|Friday|
  					Sat|Saturday|Sun|Sunday),?
  				\s+
  			)?
  			(Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec)\.?
  			((\s)+ | - | \. | /)
  				
  			(\d\d?)
  			,?
  			(?:
  				(?: \2|\3+)
  				(\d\d (?: \d\d)?)
  			)?
  			$break
  			##) {
  		# [Dow,] Mon dd [yyyy]
  		# [Dow,] Mon d, [yy]
  		($$yr, $$mr, $$dr) = ($5, $mtable{"\u\L$1"}, $4);
  		printf "%d: %s - %s - %s\n", __LINE__, $1, $2, $4 if $debug;
  		print "y undef\n" if ($debug && ! defined($$yr));
  		return 1;
  	} elsif ($$tr =~ s#^(?xi)
  			(January|Jan\.?|February|Feb\.?|March|Mar\.?|April|Apr\.?|May|
  			    June|Jun\.?|July|Jul\.?|August|Aug\.?|September|Sep\.?|
  			    October|Oct\.?|November|Nov\.?|December|Dec\.?)
  			\s+
  			(\d+)
  			(?:st|nd|rd|th)?
  			\,?
  			(?: 
  				\s+
  				(?:
  					(\d\d\d\d)
  					|(?:\' (\d\d))
  				)
  			)?
  			$break
  			##) {
  		# Month day{st,nd,rd,th}, 'yy
  		# Month day{st,nd,rd,th}, year
  		# Month day, year
  		# Mon. day, year
  		($$yr, $$mr, $$dr) = ($3 || $4, $mtable{"\u\L$1"}, $2);
  		printf "%d: %s - %s - %s - %s\n", __LINE__, $1, $2, $3, $4 if $debug;
  		print "y undef\n" if ($debug && ! defined($$yr));
  		printf "matched at %d.\n", __LINE__ if $debug;
  		return 1;
  	} elsif ($$tr =~ s#^(\d\d?)([-/.])(\d\d?)\2(\d\d?)($break)##x) {
  		if ($1 > 31 || (!$uk && $1 > 12 && $4 < 32)) {
  			# yy/mm/dd
  			($$yr, $$mr, $$dr) = ($1, $3, $4);
  		} elsif ($1 > 12 || $uk) {
  			# dd/mm/yy
  			($$yr, $$mr, $$dr) = ($4, $3, $1);
  		} else {
  			# mm/dd/yy
  			($$yr, $$mr, $$dr) = ($4, $1, $3);
  		}
  		printf "matched at %d.\n", __LINE__ if $debug;
  		return 1;
  	} elsif ($$tr =~ s#^(\d\d?)/(\d\d?)($break)##x) {
  		if ($1 > 31 || (!$uk && $1 > 12)) {
  			# yy/mm
  			($$yr, $$mr, $$dr) = ($1, $2, 1);
  		} elsif ($2 > 31 || ($uk && $2 > 12)) {
  			# mm/yy
  			($$yr, $$mr, $$dr) = ($2, $1, 1);
  		} elsif ($1 > 12 || $uk) {
  			# dd/mm
  			($$mr, $$dr) = ($2, $1);
  		} else {
  			# mm/dd
  			($$mr, $$dr) = ($1, $2);
  		}
  		printf "matched at %d.\n", __LINE__ if $debug;
  		return 1;
  	} elsif ($$tr =~ s#^(\d\d)(\d\d)(\d\d)($break)##x) {
  		if ($1 > 31 || (!$uk && $1 > 12)) {
  			# YYMMDD
  			($$yr, $$mr, $$dr) = ($1, $2, $3);
  		} elsif ($1 > 12 || $uk) {
  			# DDMMYY
  			($$yr, $$mr, $$dr) = ($3, $2, $1);
  		} else {
  			# MMDDYY
  			($$yr, $$mr, $$dr) = ($3, $1, $2);
  		}
  		printf "matched at %d.\n", __LINE__ if $debug;
  		return 1;
  	} elsif ($$tr =~ s#^(?xi)
  			(\d{1,2})
  			(\s+ | - | \. | /)
  			(January|Jan\.?|February|Feb\.?|March|Mar\.?|April|Apr\.?|May|
  			    June|Jun\.?|July|Jul\.?|August|Aug\.?|September|Sep\.?|
  			    October|Oct\.?|November|Nov\.?|December|Dec\.?)
  			(?:
  				\2
  				(
  					\d\d
  					(?:\d\d)?
  				)
  			)
  			$break
  			##) {
  		# dd Month [yr]
  		($$yr, $$mr, $$dr) = ($4, $mtable{"\u\L$3"}, $1);
  		printf "matched at %d.\n", __LINE__ if $debug;
  		return 1;
  	} elsif ($$tr =~ s#^(?xi)
  			(\d+)
  			(?:st|nd|rd|th)?
  			\s+
  			(January|Jan\.?|February|Feb\.?|March|Mar\.?|April|Apr\.?|May|
  			    June|Jun\.?|July|Jul\.?|August|Aug\.?|September|Sep\.?|
  			    October|Oct\.?|November|Nov\.?|December|Dec\.?)
  			(?: 
  				\,?
  				\s+
  				(\d\d\d\d)
  			)?
  			$break
  			##) {
  		# day{st,nd,rd,th}, Month year
  		($$yr, $$mr, $$dr) = ($3, $mtable{"\u\L$2"}, $1);
  		printf "%d: %s - %s - %s - %s\n", __LINE__, $1, $2, $3, $4 if $debug;
  		print "y undef\n" if ($debug && ! defined($$yr));
  		printf "matched at %d.\n", __LINE__ if $debug;
  		return 1;
  	}
  	return 0;
  }
  
  sub parse_time_only
  {
  	my ($tr, $hr, $mr, $sr, $tzr, %options) = @_;
  
  	$$tr =~ s#^\s+##;
  
  	if ($$tr =~ s!^(?x)
  			(?:
  				(?:
  					([012]\d)		(?# $1)
  					(?:
  						([0-5]\d) 	(?# $2)
  						(?:
  						    ([0-5]\d)	(?# $3)
  						)?
  					)
  					\s*
  					([apAP][mM])?  		(?# $4)
  				) | (?:
  					(\d{1,2}) 		(?# $5)
  					(?:
  						\:
  						(\d\d)		(?# $6)
  						(?:
  							\:
  							(\d\d)	(?# $7)
  								(
  									(?# don't barf on database sub-second timings)
  									[:.,]
  									\d+
  								)?	(?# $8)
  						)?
  					)
  					\s*
  					([apAP][mM])?		(?# $9)
  				) | (?:
  					(\d{1,2})		(?# $10)
  					([apAP][mM])		(?# ${11})
  				)
  			)
  			(?:
  				\s+
  				"?
  				(				(?# ${12})
  					(?: [A-Z]{1,4}[TCW56] )
  					|
  					IDLE
  				)	
  			)?
  			$break
  			!!) { #"emacs
  		# HH[[:]MM[:SS]]meridian [zone] 
  		my $ampm;
  		$$hr = $1 || $5 || $10 || 0; # 10 is undef, but 5 is defined..
  		$$mr = $2 || $6 || 0;
  		$$sr = $3 || $7 || 0;
  		if (defined($8) && exists($options{SUBSECOND}) && $options{SUBSECOND}) {
  			my($frac) = $8;
  			substr($frac,0,1) = '.';
  			$$sr += $frac;
  		}
  		print "S = $$sr\n" if $debug;
  		$ampm = $4 || $9 || $11 || '';
  		$$tzr = $12;
  		$$hr += 12 if $ampm and "\U$ampm" eq "PM" && $$hr != 12;
  		$$hr = 0 if $$hr == 12 && "\U$ampm" eq "AM";
  		printf "matched at %d, rem = %s.\n", __LINE__, $$tr if $debug;
  		return 1;
  	} elsif ($$tr =~ s#^noon$break##ix) {
  		# noon
  		($$hr, $$mr, $$sr) = (12, 0, 0);
  		printf "matched at %d.\n", __LINE__ if $debug;
  		return 1;
  	} elsif ($$tr =~ s#^midnight$break##ix) {
  		# midnight
  		($$hr, $$mr, $$sr) = (0, 0, 0);
  		printf "matched at %d.\n", __LINE__ if $debug;
  		return 1;
  	}
  	return 0;
  }
  
  sub parse_time_offset
  {
  	my ($tr, $rsr, %options) = @_;
  
  	$$tr =~ s/^\s+//;
  
  	return 0 if $options{NO_RELATIVE};
  
  	if ($$tr =~ s{^(?xi)					
  			(?:
  				(-)				(?# 1)
  				|
  				[+]
  			)?
  			\s*
  			(?:
  				(\d+(?:\.\d+)?) 		(?# 2)
  				| 		
  				(?:(\d+)\s+(\d+)/(\d+))		(?# 3 4/5)
  			)
  			\s*
  			(sec|second|min|minute|hour)s?		(?# 6)
  			(
  				\s+
  				ago				(?# 7)
  			)?
  			$break
  			}{}) {
  		# count units
  		$$rsr = 0 unless defined $$rsr;
  		return 0 if defined($5) && $5 == 0;
  		my $num = defined($2)
  			? $2
  			: $3 + $4/$5;
  		$num = -$num if $1;
  		$$rsr += $umult{"\L$6"} * $num;
  
  		$$rsr = -$$rsr if $7 ||
  			$$tr =~ /\b(day|mon|month|year)s?\s*ago\b/;
  		printf "matched at %d.\n", __LINE__ if $debug;
  		return 1;
  	} 
  	return 0;
  }
  
  #
  # What to you do with a date that has a two-digit year?
  # There's not much that can be done except make a guess.
  #
  # Some example situations to handle:
  #
  #	now		year 
  #
  #	1999		01
  #	1999		71
  #	2010		71
  #	2110		09
  #
  
  sub expand_two_digit_year
  {
  	my ($yr, $now, %options) = @_;
  
  	return $yr if $yr > 100;
  
  	my ($y) = (&righttime($now, %options))[5];
  	$y += 1900;
  	my $century = int($y / 100) * 100;
  	my $within = $y % 100;
  
  	my $r = $yr + $century;
  
  	if ($options{PREFER_PAST}) {
  		if ($yr > $within) {
  			$r = $yr + $century - 100;
  		}
  	} elsif ($options{PREFER_FUTURE}) {
  		# being strict here would be silly
  		if ($yr < $within-20) {
  			# it's 2019 and the date is '08'
  			$r = $yr + $century + 100;
  		}
  	} elsif ($options{UNAMBIGUOUS}) {
  		# we really shouldn't guess
  		return undef;
  	} else {
  		# prefer the current century in most cases
  
  		if ($within > 80 && $within - $yr > 60) {
  			$r = $yr + $century + 100;
  		}
  
  		if ($within < 30 && $yr - $within > 59) {
  			$r = $yr + $century - 100;
  		}
  	}
  	print "two digit year '$yr' expanded into $r\n" if $debug;
  	return $r;
  }
  
  
  sub calc 
  {
  	my ($rsr, $yr, $mr, $dr, $rdr, $now, $units, $count, %options) = @_;
  
  	confess unless $units;
  	$units = "\L$units";
  	print "calc based on $units\n" if $debug;
  
  	if ($units eq 'day') {
  		$$rdr = $count;
  	} elsif ($units eq 'week') {
  		$$rdr = $count * 7;
  	} elsif ($umult{$units}) {
  		$$rsr = $count * $umult{$units};
  	} elsif ($units eq 'mon' || $units eq 'month') {
  		($$yr, $$mr, $$dr) = &monthoff($now, $count, %options);
  		$$rsr = 0 unless $$rsr;
  	} elsif ($units eq 'year') {
  		($$yr, $$mr, $$dr) = &monthoff($now, $count * 12, %options);
  		$$rsr = 0 unless $$rsr;
  	} else {
  		carp "interal error";
  	}
  	print "calced rsr $$rsr rdr $$rdr, yr $$yr mr $$mr dr $$dr.\n" if $debug;
  }
  
  sub monthoff
  {
  	my ($now, $months, %options) = @_;
  
  	# months are 0..11
  	my ($d, $m11, $y) = (&righttime($now, %options)) [ 3,4,5 ] ;
  
  	$y += 1900;
  
  	print "m11 = $m11 + $months, y = $y\n" if $debug;
  
  	$m11 += $months;
  
  	print "m11 = $m11, y = $y\n" if $debug;
  	if ($m11 > 11 || $m11 < 0) {
  		$y -= 1 if $m11 < 0 && ($m11 % 12 != 0);
  		$y += int($m11/12);
  
  		# this is required to work around a bug in perl 5.003
  		no integer;
  		$m11 %= 12;
  	}
  	print "m11 = $m11, y = $y\n" if $debug;
  
  	# 
  	# What is "1 month from January 31st?"  
  	# I think the answer is February 28th most years.
  	#
  	# Similarly, what is one year from February 29th, 1980?
  	# I think it's February 28th, 1981.
  	#
  	# If you disagree, change the following code.
  	#
  	if ($d > 30 or ($d > 28 && $m11 == 1)) {
  		require Time::DaysInMonth;
  		my $dim = Time::DaysInMonth::days_in($y, $m11+1);
  		print "dim($y,$m11+1)= $dim\n" if $debug;
  		$d = $dim if $d > $dim;
  	}
  	return ($y, $m11+1, $d);
  }
  
  sub righttime
  {
  	my ($time, %options) = @_;
  	if ($options{GMT}) {
  		return gmtime($time);
  	} else {
  		return localtime($time);
  	}
  }
  
  sub parse_year_only
  {
  	my ($tr, $yr, $now, %options) = @_;
  
  	$$tr =~ s#^\s+##;
  
  	if ($$tr =~ s#^(\d\d\d\d)$break##) {
  		$$yr = $1;
  		printf "matched at %d.\n", __LINE__ if $debug;
  		return 1;
  	} elsif ($$tr =~ s#\'(\d\d)$break##) {
  		$$yr = expand_two_digit_year($1, $now, %options);
  		printf "matched at %d.\n", __LINE__ if $debug;
  		return 1;
  	}
  	return 0;
  }
  
  sub parse_date_offset
  {
  	my ($tr, $now, $yr, $mr, $dr, $rdr, $rsr, %options) = @_;
  
  	return 0 if $options{NO_RELATIVE};
  
  	# now - current seconds_since_epoch
  	# yr - year return
  	# mr - month return
  	# dr - day return
  	# rdr - relative day return
  	# rsr - relative second return
  
  	my $j;
  	my $wday = (&righttime($now, %options))[6];
  
  	$$tr =~ s#^\s+##;
  
  	if ($$tr =~ s#^(?xi)
  			\s*
  			(\d+)
  			\s*
  			(day|week|month|year)s?
  			(
  				\s+
  				ago
  			)?
  			$break
  			##) {
  		my $amt = $1 + 0;
  		my $units = $2;
  		$amt = -$amt if $3 ||
  			$$tr =~ m#\b(sec|second|min|minute|hour)s?\s*ago\b#;
  		&calc($rsr, $yr, $mr, $dr, $rdr, $now, $units, 
  			$amt, %options);
  		printf "matched at %d.\n", __LINE__ if $debug;
  		return 1;
  	} elsif ($$tr =~ s#^(?xi)
  			(?:
  				(?:
  					now
  					\s+
  				)?
  				(\+ | \-)
  				\s*
  			)?
  			(\d+)
  			\s*
  			(day|week|month|year)s?
  			$break
  			##) {
  		my $one = $1 || '';
  		my $two = $2 || '';
  		my $amt = "$one$two"+0;
  		&calc($rsr, $yr, $mr, $dr, $rdr, $now, $3, 
  			$amt, %options);
  		printf "matched at %d.\n", __LINE__ if $debug;
  		return 1;
  	} elsif ($$tr =~ s#^(?xi)
  			(Mon|Tue|Wed|Thu|Fri|Sat|Sun|Monday|Tuesday
  				|Wednesday|Thursday|Friday|Saturday|Sunday)
  			\s+
  			after
  			\s+
  			next
  			$break
  			##) {
  		# Dow "after next"
  		$$rdr = $wdays{"\L$1"} - $wday + ( $wdays{"\L$1"} > $wday ? 7 : 14);
  		printf "matched at %d.\n", __LINE__ if $debug;
  		return 1;
  	} elsif ($$tr =~ s#^(?xi)
  			(Mon|Tue|Wed|Thu|Fri|Sat|Sun|Monday|Tuesday
  				|Wednesday|Thursday|Friday|Saturday|Sunday)
  			\s+
  			before
  			\s+
  			last
  			$break
  			##) {
  		# Dow "before last"
  		$$rdr = $wdays{"\L$1"} - $wday - ( $wdays{"\L$1"} < $wday ? 7 : 14);
  		printf "matched at %d.\n", __LINE__ if $debug;
  		return 1;
  	} elsif ($$tr =~ s#^(?xi)
  			next\s+
  			(Mon|Tue|Wed|Thu|Fri|Sat|Sun|Monday|Tuesday
  				|Wednesday|Thursday|Friday|Saturday|Sunday)
  			$break
  			##) {
  		# "next" Dow
  		$$rdr = $wdays{"\L$1"} - $wday 
  				+ ( $wdays{"\L$1"} > $wday ? 0 : 7);
  		printf "matched at %d.\n", __LINE__ if $debug;
  		return 1;
  	} elsif ($$tr =~ s#^(?xi)
  			last\s+
  			(Mon|Tue|Wed|Thu|Fri|Sat|Sun|Monday|Tuesday
  				|Wednesday|Thursday|Friday|Saturday|Sunday)
  			$break##) {
  		# "last" Dow
  		printf "c %d - %d + ( %d < %d ? 0 : -7 \n", $wdays{"\L$1"},  $wday,  $wdays{"\L$1"}, $wday if $debug;
  		$$rdr = $wdays{"\L$1"} - $wday + ( $wdays{"\L$1"} < $wday ? 0 : -7);
  		printf "matched at %d.\n", __LINE__ if $debug;
  		return 1;
  	} elsif ($options{PREFER_PAST} and $$tr =~ s#^(?xi)
  			(Mon|Tue|Wed|Thu|Fri|Sat|Sun|Monday|Tuesday
  				|Wednesday|Thursday|Friday|Saturday|Sunday)
  			$break##) {
  		# Dow
  		printf "c %d - %d + ( %d < %d ? 0 : -7 \n", $wdays{"\L$1"},  $wday,  $wdays{"\L$1"}, $wday if $debug;
  		$$rdr = $wdays{"\L$1"} - $wday + ( $wdays{"\L$1"} < $wday ? 0 : -7);
  		printf "matched at %d.\n", __LINE__ if $debug;
  		return 1;
  	} elsif ($options{PREFER_FUTURE} and $$tr =~ s#^(?xi)
  			(Mon|Tue|Wed|Thu|Fri|Sat|Sun|Monday|Tuesday
  				|Wednesday|Thursday|Friday|Saturday|Sunday)
  			$break
  			##) {
  		# Dow
  		$$rdr = $wdays{"\L$1"} - $wday 
  				+ ( $wdays{"\L$1"} > $wday ? 0 : 7);
  		printf "matched at %d.\n", __LINE__ if $debug;
  		return 1;
  	} elsif ($$tr =~ s#^today$break##xi) {
  		# today
  		$$rdr = 0;
  		printf "matched at %d.\n", __LINE__ if $debug;
  		return 1;
  	} elsif ($$tr =~ s#^tomorrow$break##xi) {
  		$$rdr = 1;
  		printf "matched at %d.\n", __LINE__ if $debug;
  		return 1;
  	} elsif ($$tr =~ s#^yesterday$break##xi) {
  		$$rdr = -1;
  		printf "matched at %d.\n", __LINE__ if $debug;
  		return 1;
  	} elsif ($$tr =~ s#^last\s+(week|month|year)$break##xi) {
  		&calc($rsr, $yr, $mr, $dr, $rdr, $now, $1, -1, %options);
  		printf "matched at %d.\n", __LINE__ if $debug;
  		return 1;
  	} elsif ($$tr =~ s#^next\s+(week|month|year)$break##xi) {
  		&calc($rsr, $yr, $mr, $dr, $rdr, $now, $1, 1, %options);
  		printf "matched at %d.\n", __LINE__ if $debug;
  		return 1;
  	} elsif ($$tr =~ s#^now $break##x) {
  		$$rdr = 0;
  		return 1;
  	}
  	return 0;
  }
  
  sub debug_display
  {
  	my ($tz, $tzo, $H, $M, $S, $m, $d, $y, $rs, $rd, $rel, $passes, $parse, $t) = @_;
  	print "---------<<\n";
  	print defined($tz) ? "tz: $tz.\n" : "no tz\n";
  	print defined($tzo) ? "tzo: $tzo.\n" : "no tzo\n";
  	print "HMS: ";
  	print defined($H) ? "$H, " : "no H, ";
  	print defined($M) ? "$M, " : "no M, ";
  	print defined($S) ? "$S\n" : "no S.\n";
  	print "mdy: ";
  	print defined($m) ? "$m, " : "no m, ";
  	print defined($d) ? "$d, " : "no d, ";
  	print defined($y) ? "$y\n" : "no y.\n";
  	print defined($rs) ? "rs: $rs.\n" : "no rs\n";
  	print defined($rd) ? "rd: $rd.\n" : "no rd\n";
  	print $rel ? "relative\n" : "not relative\n";
  	print "passes: $passes\n";
  	print "parse:$parse\n";
  	print "t: $t.\n";
  	print "--------->>\n";
  }
  1;
  
  __END__
  
  =head1 NAME
  
  Time::ParseDate -- date parsing both relative and absolute
  
  =head1 SYNOPSIS
  
  	use Time::ParseDate;
  	$seconds_since_jan1_1970 = parsedate("12/11/94 2pm", NO_RELATIVE => 1)
  	$seconds_since_jan1_1970 = parsedate("12/11/94 2pm", %options)
  
  =head1 OPTIONS
  
  Date parsing can also use options.  The options are as follows:
  
  	FUZZY	-> it's okay not to parse the entire date string
  	NOW	-> the "current" time for relative times (defaults to time())
  	ZONE	-> local timezone (defaults to $ENV{TZ})
  	WHOLE	-> the whole input string must be parsed
  	GMT	-> input time is assumed to be GMT, not localtime
  	UK	-> prefer UK style dates (dd/mm over mm/dd)
  	DATE_REQUIRED -> do not default the date
  	TIME_REQUIRED -> do not default the time
  	NO_RELATIVE -> input time is not relative to NOW
  	TIMEFIRST -> try parsing time before date [not default]
  	PREFER_PAST -> when year or day of week is ambiguous, assume past
  	PREFER_FUTURE -> when year or day of week is ambiguous, assume future
  	SUBSECOND -> parse fraction seconds
  	VALIDATE -> only accept normal values for HHMMSS, YYMMDD.  Otherwise
  		days like -1 might give the last day of the previous month.
  
  =head1 DATE FORMATS RECOGNIZED
  
  =head2 Absolute date formats
  
  	Dow, dd Mon yy
  	Dow, dd Mon yyyy
  	Dow, dd Mon
  	dd Mon yy
  	dd Mon yyyy
  	Month day{st,nd,rd,th}, year
  	Month day{st,nd,rd,th}
  	Mon dd yyyy
  	yyyy/mm/dd
  	yyyy-mm-dd	(usually the best date specification syntax)
  	yyyy/mm
  	mm/dd/yy
  	mm/dd/yyyy
  	mm/yy
  	yy/mm      (only if year > 12, or > 31 if UK)
  	yy/mm/dd   (only if year > 12 and day < 32, or year > 31 if UK)
  	dd/mm/yy   (only if UK, or an invalid mm/dd/yy or yy/mm/dd)
  	dd/mm/yyyy (only if UK, or an invalid mm/dd/yyyy)
  	dd/mm      (only if UK, or an invalid mm/dd)
  
  =head2 Relative date formats:
  
  	count "days"
  	count "weeks"
  	count "months"
  	count "years"
  	Dow "after next"
  	Dow "before last"
  	Dow 			(requires PREFER_PAST or PREFER_FUTURE)
  	"next" Dow
  	"tomorrow"
  	"today"
  	"yesterday"
  	"last" dow
  	"last week"
  	"now"
  	"now" "+" count units
  	"now" "-" count units
  	"+" count units		
  	"-" count units
  	count units "ago"
  
  =head2 Absolute time formats:
  
  	hh:mm:ss[.ddd] 
  	hh:mm 
  	hh:mm[AP]M
  	hh[AP]M
  	hhmmss[[AP]M] 
  	"noon"
  	"midnight"
  
  =head2 Relative time formats:
  
  	count "minutes"		(count can be franctional "1.5" or "1 1/2")
  	count "seconds"
  	count "hours"
  	"+" count units
  	"+" count
  	"-" count units
  	"-" count
  	count units "ago"
  
  =head2 Timezone formats:
  
  	[+-]dddd
  	GMT[+-]d+
  	[+-]dddd (TZN)
  	TZN
  
  =head2 Special formats:
  
  	[ d]d/Mon/yyyy:hh:mm:ss [[+-]dddd]
  	yy/mm/dd.hh:mm
  
  =head1 DESCRIPTION
  
  This module recognizes the above date/time formats.   Usually a
  date and a time are specified.  There are numerous options for 
  controlling what is recognized and what is not.
  
  The return code is always the time in seconds since January 1st, 1970
  or undef if it was unable to parse the time.
  
  If a timezone is specified it must be after the time.  Year specifications
  can be tacked onto the end of absolute times.
  
  If C<parsedate()> is called from array context, then it will return two
  elements.  On successful parses, it will return the seconds and what 
  remains of its input string.  On unsuccessful parses, it will return
  C<undef> and an error string.
  
  =head1 EXAMPLES
  
  	$seconds = parsedate("Mon Jan  2 04:24:27 1995");
  	$seconds = parsedate("Tue Apr 4 00:22:12 PDT 1995");
  	$seconds = parsedate("04.04.95 00:22", ZONE => PDT);
  	$seconds = parsedate("Jan 1 1999 11:23:34.578", SUBSECOND => 1);
  	$seconds = parsedate("122212 950404", ZONE => PDT, TIMEFIRST => 1);
  	$seconds = parsedate("+3 secs", NOW => 796978800);
  	$seconds = parsedate("2 months", NOW => 796720932);
  	$seconds = parsedate("last Tuesday");
  	$seconds = parsedate("Sunday before last");
  
  	($seconds, $remaining) = parsedate("today is the day");
  	($seconds, $error) = parsedate("today is", WHOLE=>1);
  
  =head1 LICENSE
  
  Copyright (C) 1996-2010 David Muir Sharnoff.  
  Copyright (C) 2011 Google, Inc.  
  License hereby
  granted for anyone to use, modify or redistribute this module at
  their own risk.  Please feed useful changes back to cpan@dave.sharnoff.org.
  
TIME_PARSEDATE

$fatpacked{"Time/Timezone.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TIME_TIMEZONE';
  package Time::Timezone;
  
  require 5.002;
  
  require Exporter;
  @ISA = qw(Exporter);
  @EXPORT = qw(tz2zone tz_local_offset tz_offset tz_name);
  @EXPORT_OK = qw();
  
  use Carp;
  use strict;
  
  # Parts stolen from code by Paul Foley <paul@ascent.com>
  
  use vars qw($VERSION);
  
  $VERSION = 2015.0925;
  
  sub tz2zone
  {
  	my($TZ, $time, $isdst) = @_;
  
  	use vars qw(%tzn_cache);
  
  	$TZ = defined($ENV{'TZ'}) ? ( $ENV{'TZ'} ? $ENV{'TZ'} : 'GMT' ) : ''
  	    unless $TZ;
  
  	# Hack to deal with 'PST8PDT' format of TZ
  	# Note that this can't deal with all the esoteric forms, but it
  	# does recognize the most common: [:]STDoff[DST[off][,rule]]
  
  	if (! defined $isdst) {
  		my $j;
  		$time = time() unless defined $time;
  		($j, $j, $j, $j, $j, $j, $j, $j, $isdst) = localtime($time);
  	}
  
  	if (defined $tzn_cache{$TZ}->[$isdst]) {
  		return $tzn_cache{$TZ}->[$isdst];
  	}
        
  	if ($TZ =~ /^
  		    ( [^:\d+\-,] {3,} )
  		    ( [+-] ?
  		      \d {1,2}
  		      ( : \d {1,2} ) {0,2} 
  		    )
  		    ( [^\d+\-,] {3,} )?
  		    /x
  	    ) {
  		$TZ = $isdst ? $4 : $1;
  		$tzn_cache{$TZ} = [ $1, $4 ];
  	} else {
  		$tzn_cache{$TZ} = [ $TZ, $TZ ];
  	}
  	return $TZ;
  }
  
  sub tz_local_offset
  {
  	my ($time) = @_;
  
  	$time = time() unless defined $time;
  
      return &calc_off($time);
  }
  
  sub calc_off
  {
  	my ($time) = @_;
  
  	my (@l) = localtime($time);
  	my (@g) = gmtime($time);
  
  	my $off;
  
  	$off =	   $l[0] - $g[0]
  		+ ($l[1] - $g[1]) * 60
  		+ ($l[2] - $g[2]) * 3600;
  
  	# subscript 7 is yday.
  
  	if ($l[7] == $g[7]) {
  		# done
  	} elsif ($l[7] == $g[7] + 1) {
  		$off += 86400;
  	} elsif ($l[7] == $g[7] - 1) {
  		$off -= 86400;
  	} elsif ($l[7] < $g[7]) {
  		# crossed over a year boundary!
  		# localtime is beginning of year, gmt is end
  		# therefore local is ahead
  		$off += 86400;
  	} else {
  		$off -= 86400;
  	}
  
  	return $off;
  }
  
  # constants
  # The rest of the file originally comes from Graham Barr <bodg@tiuk.ti.com> 
  #
  # Some references:
  #  http://www.weltzeituhr.com/laender/zeitzonen_e.shtml
  #  http://www.worldtimezone.com/wtz-names/timezonenames.html
  #  http://www.timegenie.com/timezones.php
  
  CONFIG: {
  	use vars qw(%dstZone %zoneOff %dstZoneOff %Zone);
  
  	%dstZone = (
  	    "brst" =>	-2*3600,	 # Brazil Summer Time (East Daylight)
  	    "adt"  =>	-3*3600,	 # Atlantic Daylight   
  	    "edt"  =>	-4*3600,	 # Eastern Daylight
  	    "cdt"  =>	-5*3600,	 # Central Daylight
  	    "mdt"  =>	-6*3600,	 # Mountain Daylight
  	    "pdt"  =>	-7*3600,	 # Pacific Daylight
  	    "ydt"  =>	-8*3600,	 # Yukon Daylight
  	    "hdt"  =>	-9*3600,	 # Hawaii Daylight
  	    "bst"  =>	+1*3600,	 # British Summer   
  	    "mest" =>	+2*3600,	 # Middle European Summer   
  	    "met dst" => +2*3600,	 # Middle European Summer   
  	    "sst"  =>	+2*3600,	 # Swedish Summer
  	    "fst"  =>	+2*3600,	 # French Summer
  	    "eest" =>	+3*3600,	 # Eastern European Summer
  	    "cest" =>	+2*3600,	 # Central European Daylight
  	    "wadt" =>	+8*3600,	 # West Australian Daylight
  	    "kdt"  =>  +10*3600,	 # Korean Daylight
  	#   "cadt" =>  +10*3600+1800,	 # Central Australian Daylight
  	    "eadt" =>  +11*3600,	 # Eastern Australian Daylight
  	    "nzdt" =>  +13*3600,	 # New Zealand Daylight	  
  	);
  
  	# not included due to ambiguity:
  	#	IST     Indian Standard Time            +5.5
  	#		Ireland Standard Time           0
  	#		Israel Standard Time            +2
  	#	IDT     Ireland Daylight Time           +1
  	#		Israel Daylight Time            +3
  	#	AMST    Amazon Standard Time /          -3
  	#		Armenia Standard Time           +8
  	#	BST	Brazil Standard			-3
  
  	%Zone = (
  	    "gmt"	=>   0,		 # Greenwich Mean
  	    "ut"	=>   0,		 # Universal (Coordinated)
  	    "utc"	=>   0,
  	    "wet"	=>   0,		 # Western European
  	    "wat"	=>  -1*3600,	 # West Africa
  	    "azost"	=>  -1*3600,	 # Azores Standard Time
  	    "cvt"	=>  -1*3600,	 # Cape Verde Time
  	    "at"	=>  -2*3600,	 # Azores
  	    "fnt"	=>  -2*3600,	 # Brazil Time (Extreme East - Fernando Noronha)
  	    "ndt" 	=>  -2*3600-1800,# Newfoundland Daylight   
  	    "art"	=>  -3*3600,	 # Argentina Time
  	# For completeness.  BST is also British Summer, and GST is also Guam Standard.
  	#   "gst"	=>  -3*3600,	 # Greenland Standard
  	    "nft"	=>  -3*3600-1800,# Newfoundland
  	#   "nst"	=>  -3*3600-1800,# Newfoundland Standard
  	    "mnt"	=>  -4*3600,	 # Brazil Time (West Standard - Manaus)
  	    "ewt"	=>  -4*3600,	 # U.S. Eastern War Time
  	    "ast"	=>  -4*3600,	 # Atlantic Standard
  	    "bot"	=>  -4*3600,	 # Bolivia Time
  	    "vet"	=>  -4*3600,	 # Venezuela Time
  	    "est"	=>  -5*3600,	 # Eastern Standard
  	    "cot"	=>  -5*3600,	 # Colombia Time
  	    "act"	=>  -5*3600,	 # Brazil Time (Extreme West - Acre)
  	    "pet"	=>  -5*3600,	 # Peru Time
  	    "cst"	=>  -6*3600,	 # Central Standard
  	    "cest"	=>  +2*3600,	 # Central European Summer
  	    "mst"	=>  -7*3600,	 # Mountain Standard
  	    "pst"	=>  -8*3600,	 # Pacific Standard
  	    "yst"	=>  -9*3600,	 # Yukon Standard
  	    "hst"	=> -10*3600,	 # Hawaii Standard
  	    "cat"	=> -10*3600,	 # Central Alaska
  	    "ahst"	=> -10*3600,	 # Alaska-Hawaii Standard
  	    "taht"	=> -10*3600,	 # Tahiti Time
  	    "nt"	=> -11*3600,	 # Nome
  	    "idlw"	=> -12*3600,	 # International Date Line West
  	    "cet"	=>  +1*3600,	 # Central European
  	    "mez"	=>  +1*3600,	 # Central European (German)
  	    "met"	=>  +1*3600,	 # Middle European
  	    "mewt"	=>  +1*3600,	 # Middle European Winter
  	    "swt"	=>  +1*3600,	 # Swedish Winter
  	    "set"	=>  +1*3600,	 # Seychelles
  	    "fwt"	=>  +1*3600,	 # French Winter
  	    "west"	=>  +1*3600,	 # Western Europe Summer Time
  	    "eet"	=>  +2*3600,	 # Eastern Europe, USSR Zone 1
  	    "ukr"	=>  +2*3600,	 # Ukraine
  	    "sast"	=>  +2*3600,	 # South Africa Standard Time
  	    "bt"	=>  +3*3600,	 # Baghdad, USSR Zone 2
  	    "eat"	=>  +3*3600,	 # East Africa Time
  	#   "it"	=>  +3*3600+1800,# Iran
  	    "irst"	=>  +3*3600+1800,# Iran Standard Time
  	    "zp4"	=>  +4*3600,	 # USSR Zone 3
  	    "msd"	=>  +4*3600,	 # Moscow Daylight Time
  	    "sct"	=>  +4*3600,	 # Seychelles Time
  	    "zp5"	=>  +5*3600,	 # USSR Zone 4
  	    "azst"	=>  +5*3600,	 # Azerbaijan Summer Time
  	    "mvt"	=>  +5*3600,	 # Maldives Time
  	    "uzt"	=>  +5*3600,	 # Uzbekistan Time
  	    "ist"	=>  +5*3600+1800,# Indian Standard
  	    "zp6"	=>  +6*3600,	 # USSR Zone 5
  	    "lkt"	=>  +6*3600,	 # Sri Lanka Time
  	    "pkst"	=>  +6*3600,	 # Pakistan Summer Time
  	    "yekst"	=>  +6*3600,	 # Yekaterinburg Summer Time
  	# For completeness.  NST is also Newfoundland Stanard, and SST is also Swedish Summer.
  	#   "nst"	=>  +6*3600+1800,# North Sumatra
  	#   "sst"	=>  +7*3600,	 # South Sumatra, USSR Zone 6
  	    "wast"	=>  +7*3600,	 # West Australian Standard
  	    "ict"	=>  +7*3600,	 # Indochina Time
  	    "wit"	=>  +7*3600,	 # Western Indonesia Time
  	#   "jt"	=>  +7*3600+1800,# Java (3pm in Cronusland!)
  	    "cct"	=>  +8*3600,	 # China Coast, USSR Zone 7
  	    "wst"	=>  +8*3600,	 # West Australian Standard
  	    "hkt"	=>  +8*3600,	 # Hong Kong
  	    "bnt"	=>  +8*3600,	 # Brunei Darussalam Time
  	    "cit"	=>  +8*3600,	 # Central Indonesia Time
  	    "myt"	=>  +8*3600,	 # Malaysia Time
  	    "pht"	=>  +8*3600,	 # Philippines Time
  	    "sgt"	=>  +8*3600,	 # Singapore Time
  	    "jst"	=>  +9*3600,	 # Japan Standard, USSR Zone 8
  	    "kst"	=>  +9*3600,	 # Korean Standard
  	#   "cast"	=>  +9*3600+1800,# Central Australian Standard
  	    "east"	=> +10*3600,	 # Eastern Australian Standard
  	    "gst"	=> +10*3600,	 # Guam Standard, USSR Zone 9
  	    "nct"	=> +11*3600,	 # New Caledonia Time
  	    "nzt"	=> +12*3600,	 # New Zealand
  	    "nzst"	=> +12*3600,	 # New Zealand Standard
  	    "fjt"	=> +12*3600,	 # Fiji Time
  	    "idle"	=> +12*3600,	 # International Date Line East
  	);
  
  	%zoneOff = reverse(%Zone);
  	%dstZoneOff = reverse(%dstZone);
  
  	# Preferences
  
  	$zoneOff{0}	  = 'gmt';
  	$dstZoneOff{3600} = 'bst';
  
  }
  
  sub tz_offset
  {
  	my ($zone, $time) = @_;
  
  	return &tz_local_offset() unless($zone);
  
  	$time = time() unless defined $time;
  	my(@l) = localtime($time);
  	my $dst = $l[8];
  
  	$zone = lc $zone;
  
  	if ($zone =~ /^([\-\+]\d{3,4})$/) {
  		my $sign = $1 < 0 ? -1 : 1 ;
  		my $v = abs(0 + $1);
  		return $sign * 60 * (int($v / 100) * 60 + ($v % 100));
  	} elsif (exists $dstZone{$zone} && ($dst || !exists $Zone{$zone})) {
  		return $dstZone{$zone};
  	} elsif(exists $Zone{$zone}) {
  		return $Zone{$zone};
  	}
  	undef;
  }
  
  sub tz_name
  {
  	my ($off, $time) = @_;
  
  	$time = time() unless defined $time;
  	my(@l) = localtime($time);
  	my $dst = $l[8];
  
  	if (exists $dstZoneOff{$off} && ($dst || !exists $zoneOff{$off})) {
  		return $dstZoneOff{$off};
  	} elsif (exists $zoneOff{$off}) {
  		return $zoneOff{$off};
  	}
  	sprintf("%+05d", int($off / 60) * 100 + $off % 60);
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Time::Timezone -- miscellaneous timezone manipulations routines
  
  =head1 SYNOPSIS
  
  	use Time::Timezone;
  	print tz2zone();
  	print tz2zone($ENV{'TZ'});
  	print tz2zone($ENV{'TZ'}, time());
  	print tz2zone($ENV{'TZ'}, undef, $isdst);
  	$offset = tz_local_offset();
  	$offset = tz_offset($TZ);
  
  =head1 DESCRIPTION
  
  This is a collection of miscellaneous timezone manipulation routines.
  
  C<tz2zone()> parses the TZ environment variable and returns a timezone
  string suitable for inclusion in L<date>-like output.  It optionally takes
  a timezone string, a time, and a is-dst flag.
  
  C<tz_local_offset()> determines the offset from GMT time in seconds.  It
  only does the calculation once.
  
  C<tz_offset()> determines the offset from GMT in seconds of a specified
  timezone.  
  
  C<tz_name()> determines the name of the timezone based on its offset
  
  =head1 AUTHORS
  
  Graham Barr <bodg@tiuk.ti.com>
  David Muir Sharnoff <muir@idiom.org>
  Paul Foley <paul@ascent.com>
  
  =head1 LICENSE
  
  David Muir Sharnoff disclaims any copyright and puts his contribution
  to this module in the public domain.
  
TIME_TIMEZONE

s/^  //mg for values %fatpacked;

my $class = 'FatPacked::'.(0+\%fatpacked);
no strict 'refs';
*{"${class}::files"} = sub { keys %{$_[0]} };

if ($] < 5.008) {
  *{"${class}::INC"} = sub {
    if (my $fat = $_[0]{$_[1]}) {
      my $pos = 0;
      my $last = length $fat;
      return (sub {
        return 0 if $pos == $last;
        my $next = (1 + index $fat, "\n", $pos) || $last;
        $_ .= substr $fat, $pos, $next - $pos;
        $pos = $next;
        return 1;
      });
    }
  };
}

else {
  *{"${class}::INC"} = sub {
    if (my $fat = $_[0]{$_[1]}) {
      open my $fh, '<', \$fat
        or die "FatPacker error loading $_[1] (could be a perl installation issue?)";
      return $fh;
    }
    return;
  };
}

unshift @INC, bless \%fatpacked, $class;
  } # END OF FATPACK CODE


#  Author:    Nicholas Hubbard
#  Copyright: Nicholas Hubbard
#  License:   GPL_3
#  WWW:       https://github.com/NicholasBHubbard/Yabsm

#  The toplevel script (and manual) of Yabsm.

use strict;
use warnings;
use v5.34.0;

use App::Yabsm;

App::Yabsm::main(@ARGV) unless caller;

__END__

=pod

=head1 Name

Yabsm - yet another btrfs snapshot manager

=head1 What is Yabsm?

Yabsm is a btrfs snapshot and backup management system that provides the
following features:

=over 4

=item *

Takes read only snapshots and performs both remote and local incremental backups.

=item *

Separates snapshots and backups into I<5minute>, I<hourly>, I<daily>, I<weekly>,
and I<monthly> timeframe categories.

=item *

Provides a simple query language for locating snapshots and backups.

=back

=head1 Usage

Yabsm provides 3 commands: L<config|/"Configuration Querying">,
L<find|/"Finding Snapshots">, and L<daemon|/"The Yabsm Daemon">

    usage: yabsm [--help] [--version] [<COMMAND> <ARGS>]

    commands:

      <config|c> [--help] [check ?file] [ssh-check <SSH_BACKUP>] [ssh-key]
                 [yabsm-user-home] [yabsm_dir] [subvols] [snaps] [ssh_backups]
                 [local_backups] [backups]

      <find|f>   [--help] [<SNAP|SSH_BACKUP|LOCAL_BACKUP> <QUERY>]

      <daemon|d> [--help] [start] [stop] [restart] [status] [init]

=head1 Snapshots vs Backups

Before we go on, let's clear up the difference between a snapshot and a backup.

A L<snapshot|https://btrfs.wiki.kernel.org/index.php/SysadminGuide#Snapshots> is
a read-only nested subvolume created with a C<btrfs subvolume snapshot -r>
command. B<SNAPSHOTS ARE NOT RELIABLE AS A BACKUP MECHANISM>!. If a subvolume is
corrupted then all the snapshots of that subvolume may also be corrupted.

A backup is an L<incremental
backup|https://btrfs.wiki.kernel.org/index.php/Incremental_Backup> sent to some
location via Btrfs's
L<send/receive|https://btrfs.readthedocs.io/en/latest/Send-receive.html>
commands. A backup will not be corrupted if the subvolume being backed up is
corrupted.

=head1 The Yabsm Daemon

    usage: yabsm <daemon|d> [--help] [start] [stop] [restart] [status] [init]

Snapshots and backups are performed by the Yabsm daemon. The Yabsm daemon must be
started as root so it can initialize its runtime environment, which includes
creating a locked user named I<yabsm> (and a group named I<yabsm>) that the
daemon will run as. You can initialize the daemon's runtime environment without
actually starting the daemon by running C<yabsm daemon init>.

When the daemon starts, it reads the C</etc/yabsm.conf> file that specifies its
L<configuration|/"Configuration"> to determine when to schedule the snapshots and
backups and how to perform them. If the Yabsm daemon is already running and you
make a configuration change, you must run C<yabsm daemon restart> to apply the
changes.

=head3 Initialize Daemon Runtime Environment

You can use the command C<yabsm daemon init> to initialize the daemon's runtime
environment without actually starting the daemon. Running this command creates
the I<yabsm> user and group, gives the I<yabsm> user sudo access to btrfs-progs,
creates I<yabsms> SSH keys, and creates the directories needed for performing all
the I<snaps>, I<ssh_backups>, and I<local_backups> defined in C</etc/yabsm.conf>.

=head3 Daemon Logging

The Yabsm daemon logs all of its errors to C</var/log/yabsm>. If, for example,
you have an I<ssh_backup> that is not being performed, the first thing you should
do is check the log file.

=head1 Configuration

The Yabsm daemon is configured via the C</etc/yabsm.conf> file.

You can run the command C<yabsm config check> to check the correctness of your
config and output useful error messages if there are any problems.

=head3 Configuration Grammar

First things first: you must specify a C<yabsm_dir> that Yabsm will use for
storing snapshots and as a cache for holding data needed for performing snapshots
and backups. Most commonly this directory is set to C</.snapshots/yabsm>. Yabsm
will take this directory literally so you almost certainly want the path to end
in C</yabsm>. If this directory does not exist, the Yabsm daemon will create it
automatically when it starts.

There are 4 different configuration objects: I<subvols>, I<snaps>,
I<ssh_backups>, and I<local_backups>. The general form of each configuration
object is:

    type name {
        key=val
        ...
    }

All configuration objects share a namespace, so you must make sure they all have
unique names. You can define as many configuration objects as you want.

=head4 Subvols

A subvol is the simplest configuration object and is used to give a name to a
L<btrfs subvolume|https://btrfs.wiki.kernel.org/index.php/SysadminGuide#Subvolumes>
on your system. A subvol definition accepts one field named C<mountpoint> which
takes a value that is a path to a subvolume.

    subvol home_subvol {
        mountpoint=/home
    }

=head4 Timeframes

We need to understand timeframes before we can understand I<snaps>,
I<ssh_backups>, and I<local_backups>. There are 5 timeframes: I<5minute>,
I<hourly>, I<daily>, I<weekly>, and I<monthly>.

I<Snaps>, I<ssh_backups>, and I<local_backups> are performed in one or more
timeframes. For example, a I<ssh_backup> may be configured to take backups in the
I<hourly> and I<weekly> categories, which means that we want to backup every hour
and once a week.

The following table describes in plain English what each timeframe means:

    5minute -> Every 5 minutes.
    hourly  -> At the beginning of every hour.
    daily   -> Every day at one or more times of the day.
    weekly  -> Once a week on a specific weekday at a specific time.
    monthly -> Once a month on a specific day at a specific time.

To specify the timeframes you want, you set the value of C<timeframes> to a comma
separated list of timeframe values. For example, this is how you specify that you
want every timeframe:

    timeframes=5minute,hourly,daily,weekly,monthly

Each timeframe you specify adds new required settings for the configuration
object. Here is a table that shows the timeframe settings:

    5minute -> 5minute_keep
    hourly  -> hourly_keep
    daily   -> daily_keep,   daily_times
    weekly  -> weekly_keep,  weekly_time,  weekly_day
    monthly -> monthly_keep, monthly_time, monthly_day

Any C<*_keep> setting defines how many snapshots/backups you want to keep at one
time for the configuration object. A common configuration is to keep 48 hourly
snapshots so you can go back 2 days in one-hour increments.

The I<daily> timeframe requires a C<daily_times> setting, which takes a comma
separated list of C<hh:mm> times. Yabsm will perform the snapshot/backup every
day at all the given times.

The I<weekly> timeframe requires a C<weekly_day> setting that takes a day of week
string such as I<monday>, I<thursday>, or I<saturday> and a I<weekly_time>
setting that takes a I<hh:mm> time. The weekly snapshot/backup will be performed
on the given day of the week at the given time.

The I<monthly> timeframe requires a C<monthly_day> setting that takes an integer
between 1-31 and a C<monthly_time> setting that takes a I<hh:mm> time. The
monthly snapshot/backup will be performed on the given day of the month at the
given time.

=head4 Snaps

A I<snap> represents a snapshot configuration for some I<subvol>. Here is an
example of a I<snap> that snapshots C<home_subvol> twice a day.

    snap home_subvol_snap {
        subvol=home_subvol
        timeframes=daily
        daily_keep=62 # two months
        daily_times=13:40,23:59
    }

=head4 SSH Backups

A I<ssh_backup> represents a backup configuration that sends snapshots over a
network via SSH. See this example of a I<ssh_backup> that backs up C<home_subvol>
to C<larry@192.168.1.73:/backups/yabsm/laptop_home> every night at midnight:

    ssh_backup home_subvol_larry_server {
        subvol=home_subvol
        ssh_dest=larry@192.168.1.73
        dir=/backups/yabsm/laptop_home
        timeframes=daily
        daily_keep=31
        daily_times=23:59
    }

The difficult part of configuring a I<ssh_backup> is making sure the SSH server
is properly configured. You can test that a I<ssh_backup> is able to be performed
by running C<yabsm config ssh-check E<lt>SSH_BACKUPE<gt>>. For a I<ssh_backup> to
be able to be performed the following conditions must be satisfied:

=over 4

=item *

The host's I<yabsm> user can sign into the SSH destination (I<ssh_dest>) using
key based authentication. To achieve this you must add the I<yabsm> users SSH key
(available via C<# yabsm ssh print-key>) to the server user's
C<$HOME/.ssh/authorized_keys> file.

=item *

The remote backup directory (I<dir>) is an existing directory residing on a btrfs
filesystem that the remote user has read and write permissions to.

=item *

The SSH user has root access to btrfs-progs via sudo. To do this you can add a
file containing a string like C<larry ALL=(root) NOPASSWD: /sbin/btrfs> to
a file in C</etc/sudoers.d/>.

=back

=head4 Local Backups

A I<local_backup> represents a backup configuration that sends snapshots to a
partition mounted on the host OS. This is useful for sending snapshots to an
external hard drive plugged into your computer.

Here is an example I<local_backup> that backs up C<home_subvol> every hour, and
once a week.

    local_backup home_subvol_easystore {
        subvol=home_subvol
        dir=/mnt/easystore/backups/yabsm/home_subvol
        timeframes=hourly,weekly
        hourly_keep=48
        weekly_keep=56
        weekly_day=sunday
        weekly_time=23:59
    }

The backup directory (C<dir>) must be an existing directory residing on a btrfs
filesystem that the I<yabsm> user has read permission on.

=head1 Configuration Querying

Yabsm comes with a C<config> command that allows you to check and query your
configuration.

    usage: yabsm <config|c> [--help] [check ?file] [ssh-check <SSH_BACKUP>]
                            [ssh-key] [yabsm-user-home] [yabsm_dir] [subvols]
                            [snaps] [ssh_backups] [local_backups] [backups]

The C<check ?file> subcommand checks that C<?file> is a valid Yabsm configuration
file and if not prints useful error messages. If the C<?file> argument is omitted
it defaults to C</etc/yabsm.conf>.

The C<ssh-check E<lt>SSH_BACKUPE<gt>> subcommand checks that C<E<lt>SSH_BACKUPE<gt>> can be
performed and if not prints useful error messages. See the section
L<SSH Backups|/"SSH Backups"> for an explanation on the configuration required
for performing an I<ssh_backup>.

The C<ssh-key> subcommand prints the I<yabsm> user's public SSH key.

All of the other subcommands query for information derived from your
 C</etc/yabsm.conf>:

    subvols         -> The names of all subvols.
    snaps           -> The names of all snaps.
    ssh_backups     -> The names of all ssh_backups.
    local_backups   -> The names of all local_backups.
    backups         -> The names of all ssh_backups and local_backups.
    yabsm_dir       -> The directory used as the yabsm_dir.
    yabsm_user_home -> The 'yabsm' users home directory.

=head1 Finding Snapshots

Now that we know how to configure Yabsm to take snapshots, we are going to want
to locate those snapshots. Yabsm comes with a command C<find> that allows you to
locate snapshots and backups using a simple query language. Here is the usage
string for the C<find> command.

    usage: yabsm <find|f> [--help] [<SNAP|SSH_BACKUP|LOCAL_BACKUP> <QUERY>]

Here are a few examples:

    $ yabsm find home_snap back-2-mins
    $ yabsm f root_ssh_backup 'after b-2-m'
    $ yabsm f home_local_backup 10:45

The first argument is the name of any I<snap>, I<ssh_backup>, or I<local_backup>.
Because these configuration entities share the same namespace there is no risk of
ambiguity.

The second argument is a snapshot location query. There are 7 types of queries:

    all                 -> Every snapshot sorted newest to oldest
    newest              -> The most recent snapshot/backup.
    oldest              -> The oldest snapshot/backup.
    after   TIME        -> All the snapshot/backups that are newer than TIME.
    before  TIME        -> All the snapshot/backups that are older than TIME.
    between TIME1 TIME2 -> All the snapshot/backups that were taken between TIME1 and TIME2.
    TIME                -> The snapshot/backup that was taken closest to TIME.

=head2 Time Abbreviations

In the list above the C<TIME> variables stand for a I<time abbreviation>.

There are two different kinds of I<time abbreviations>: I<relative times> and
I<immediate times>.

=head3 Relative Times

A relative time comes in the form C<back-AMOUNT-UNIT>, where C<back> can be
abbreviated to C<b>, C<AMOUNT> is a positive integer, and C<UNIT> is either
C<minutes>, C<hours>, or C<days>. Each C<UNIT> can be abbreviated:

    minutes -> mins, m
    hours   -> hrs, h
    days    -> d

Here are some English descriptions of I<relative times>.

    back-5-h  -> 5 hours ago
    b-10-m    -> 10 minutes ago
    b-24-days -> 24 days ago

=head3 Immediate Times

An I<immediate_time> is an abbreviation for a time/date denoted by C<yr_mon_day_hr:min>.

There are 7 I<immediate_time> forms, the following table gives an example of each
form:

    yr_mon_day_hr:min -> 2020_5_13_23:59
    yr_mon_day        -> 2020_12_25
    mon_day_hr:min    -> 12_25_8:30
    mon_day_hr        -> 12_25_8
    mon_day           -> 12_25
    hr:min            -> 23:59

The I<immediate_time> abbreviation rules are simple. If the C<yr>, C<mon>, or
C<day> is omitted then the current year, month, or day is assumed. If the C<hr>
or C<min> is omitted then they are assumed to be 0. Therefore C<2020_12_25> is
always the same as C<2020_12_25_00:00>. If the current day is I<2020/12/25>, then
C<23:59> is the same as C<2020_12_25_23:59>.

=head1 Getting Support

Do not hesitate to open an issue at
L<https://github.com/NicholasBHubbard/Yabsm/issues>! To help get support, you may
want to include the output of the following commands in your issue:

    $ yabsm config check
    $ yabsm config ssh-check <SSH_BACKUP>
    $ cat /var/log/yabsm

=head1 Developers

The developers manual can be viewed at: https://metacpan.org/pod/App::Yabsm.

=head1 Author

Nicholas Hubbard <nicholashubbard@posteo.net>

=head1 Copyright

Copyright (c) 2022-2023 by Nicholas Hubbard (nicholashubbard@posteo.net)

=head1 License

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 3 of the License, or (at your option) any later
version.

This program is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
PARTICULAR PURPOSE. See the GNU General Public License for more details.

You should have received a copy of the GNU General Public License along with
App-Yabsm. If not, see http://www.gnu.org/licenses/.

=cut
