トップページ - リンク

• とほほのperl入門 : Perlの入門
• Perl Memo 正規表現 : 正規表現のテクニック
• 排他制御
• Perlマニュアル(和訳)

トップページ / ソフトウェア

• slashuser ver1.0 2004/06/16 : slashdot.jp のユーザIDとニックネームを相互に変換します。

トップページ

• ソフトウェア
• リンク

# slashuser.pl
#   Webを取得してSlashdotJapanのユーザID/ニックネームを相互に変換します
#
# 使い方と実行結果:
# > perl slashuser.pl
# SLASHDOT_JP_USER_INFO/1.0 (2004.06.16; by ghh; http://srad.jp/~ghh/)
#  USAGE: slashuser.pl (#USER_NUMBER|NICK_NAME)
#
# > perl slashuser.pl #22902
# Slash User @ Wed Jun 16 04:20:12 2004
#  User ID   = 22902
#  Nick Name = ghh
#
# > perl slashuser.pl ghh
# Slash User @ Wed Jun 16 04:20:12 2004
#  User ID   = 22902
#  Nick Name = ghh
#

#!/usr/bin/perl

# License : GPL ( http://www.gnu.org/copyleft/gpl.html )

use strict;

my $ua = qq!SLASHDOT_JP_USER_INFO/1.0 (2004.06.16; by ghh; http://srad.jp/~ghh/)!;

my ($uid, $nick);
if ($ARGV[0] =~ m!^#(\d+)$!) {
  ($uid, $nick) = &slashuser($1, "", $ua);
} elsif ($ARGV[0] ne "") {
  ($uid, $nick) = &slashuser("", $ARGV[0], $ua);
}

if ($nick ne "") {
  printf(qq!Slash User @ %s\n!, scalar(localtime));
  print(qq! User ID   = $uid\n!);
  print(qq! Nick Name = $nick\n!);
} else {
  if ($ARGV[0] ne "") {
    printf stderr qq!Unknown user: !;
    if ($ARGV[0] =~ m!^#(\d+)$!) {
      printf stderr "User ID = $1";
    } else {
      printf stderr qq!Nick Name = "$ARGV[0]"!;
    }
    printf stderr qq!\n!;
  }
  printf stderr qq!$ua\n!;
  printf stderr qq!  USAGE: $0 (#USER_NUMBER|NICK_NAME)\n!;
  exit;
}

sub slashuser {
  my ($uid, $nick, $ua) = @_;
  my $url = qq!http://srad.jp/users.pl?op=userinfo&light=1\&nick=$nick\&uid=$uid!;
  my @str = &wget($url, $ua);
  my ($ruid, $rnick) = ("!", "");
  for my $l(@str) {
    if ($ruid eq "!" && $l =~ m!titles;users;!) {
      $ruid = "";
    } elsif ($l =~ m!^([\w]+)\s\((\d+)\)\s!) {
      $ruid = $2;
      $rnick = $1;
      last;
    }
  }
  $ruid = "" if ($ruid eq "!");
  return ($ruid, $rnick);
}

sub wget {
  my $arg = shift;
  my $useragent = shift;
  $useragent = qq!Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1)! if ($useragent eq "");
  my @ret;
  if ($arg =~ m/^http:\/\/([^\/]+)(:(\d+))?\/(.*)$/) {
    my $target_server = $1;
    my $target_port = $3;
    $target_port = 80 if (!$target_port);
    my $target_path = "/" . $4;
    use Socket;
    socket(S, &PF_INET, &SOCK_STREAM, (getprotobyname('tcp'))[2]);
      connect(S, pack('S n a4 x8', &AF_INET, $target_port, (gethostbyname($target_server))[4]));
      binmode(S);
      select(S); $| = 1; select(stdout);
      print S "GET $target_path HTTP/1.0\r\n";
      print S "User-Agent: $useragent\r\n";
      print S "Host: $target_server\r\n";
      print S "\r\n";
      my($header_end) = 0;
      while (<S>) {
        if ($header_end) {
          push(@ret, $_);
        } elsif ($_ =~ /^\r\n$/) {
          $header_end = 1;
        }
      }
    close(S);
  }
  return @ret;
}

簡単なスクリプトを配布していきます。
もしよろしければご利用ください。
スクリプトのライセンスは、GPL ( http://www.gnu.org/copyleft/gpl.html ) です。
すなわち、利用・改変は自由です。
再配布はソース公開をする場合にできます。

どうぞよろしく。