Guidelines for the Generation of Message IDs and Similar Unique Identifiers

メールに振られる Message-ID のガイドライン。どれだけ普及してるかは調べなかった。
Guidelines for the Generation of Message IDs and Similar Unique Identifiers

素振りのつもりで実装してみたけど、途中で挫折。

理由はなんかどう動くかよく分かんなくなっちゃったから。

そんなときこそ TDD 重要。

sub test {
  print message_id_based_on_hosts_fqdn();
  print message_id_based_on_email_address("yuji-okazawa@teraintl.co.jp", ["crypt", "md5", "sha1"]);
  print message_id_based_on_login_name_and_fqdn(["crypt", "md5", "sha1"]);
}

my $OBSOLETE_MODE = "1";

sub message_id_based_on_hosts_fqdn {
  my $result = "";
  my $fqdn = _fqdn();
  if ($fqdn) {
    $result = sprintf("%s@%s", _unique(), $fqdn);
  }
  return $result;
}

sub message_id_based_on_email_address {
  my ($addr_spec, $array_ref) = @_;
  my $result = "";
  
  my ($local_part) = ($addr_spec =~ m/^([^@]+)@.*$/);
  my ($hash_name, $hash_value) = _hash($array_ref, $local_part);
  if ($hash_name && $hash_value) {
    $result = sprintf("%s%%%s%%%s", _unique(), $hash_name, $addr_spec);
  } else {
    $result = sprintf("%s%%%s", _unique(), $addr_spec);
  }
  return $result;
}

sub message_id_based_on_login_name_and_fqdn {
  my ($array_ref) = @_;
  my $login = (getpwuid($<))[0] || $<;
  my $fqdn = _fqdn();
  my $result = "";
  if ($fqdn) {
    my ($hash_name, $hash_value) = _hash($array_ref, $login);
    if ($hash_name && $hash_value) {
      $result = sprintf("%s%%%s%%%s@%s", _unique(), $hash_name, $login, $fqdn);
    } else {
      $result = sprintf("%s%%%s@%s", _unique(), $login, $fqdn);
    }
  }
  return $result;
}

sub _unique {
  my $seconds = eval {
    use Time::Hires qw(time);
    return time();
  };
  
  if ($@) {
    $seconds = time();
  }
  
  return join(
    map {_base_n_encode(80, $_)} (time(), $$), ".");
}

sub _base_n_encode {
  my ($n, $v) = @_;
  my @unique_chars = ("A".."Z", "a".."z", "1".."9"
                   , "\!", "\#", "\$", "\&", "\'", "*", "+", "-"
                   , "/", "=", "?", "^", "_", "`", "{", "|"
                   , "}", "~");

  my @bits = split(//, unpack("B*", pack("H*", $v)));
  my $bit_width = 0;
  for (my $i = 0; ($i < 32) && ($bit_width == 0); $i++) {
    if ($v <= (2**$i)) {
      $bit_width = ($i - 1);
    }
  }
  
  my $result = "";
  for (my $pos = 0; $pos < scalar(@{$ref}); $pos += $bit_width) {
    $result .= $unique_chars[int(join("", @{$ref}[$pos..($pos+$bit_width)]))]
  }
  
  return $result;
}


sub _fqdn {
  my $result = eval {
    use Sys::Hostname::FQDN qw(fqdn);
    return fqdn();
  };
  if ($@) {
    warn $@;
    if ($OBSOLETE_MODE) {
      $result = eval {
        use IO::Interface::Simple;
        for my $iface (IO::Interface::Simple->interfaces) {
          if ($iface->address !~ m/^(?:10\.|172.16\.|192.168.).*/) {
            return sprintf "[%s]", $iface->address;
          }
        }
      };
      warn $@ if $@;
    }
  }
  return $result;
}

sub _hash {
  my ($ref, $v) = @_;
  for my $hname (@{$ref}) {
    if ($hname == "crypt") {
      my $salt = join("", ('.', '/', 0..9, 'A'..'Z', 'a'..'z')[rand 64, rand 64]);
      return crypt($v, $salt);
      
    } elsif ($hname == "md5") {
      use Digest::MD5 qw(md5_base64);
      return md5_base64($v);
      
    } elsif ($hname == "sha1") {
      use Digest::SHA1 qw(sha1_base64);
      return sha1_base64($v);

    } else {
      warn "unknown hash function: $hname";
    }
  }
}


1;