#!/usr/bin/perl -T # # unko.pl ver 0.0.5 # # ChangeLog: # v0.0.5: Info を出す # ローカル送信の名前化け解消 # # v0.0.4: notice 実装 # バグ潰し # # v0.0.3: help や nick,list 対応 # # v0.0.2: ReadLine と ReadKey を使う # ひたすらバグ潰し # 色んなのを関数に分ける # # v0.0.1: とりあえず作ってみる # unko コマンド実装 # # Depending on: # Perl-5.8.x # ReadLine-Perl # ReadKey-Perl # Modules use IO::Socket; use Term::ReadLine; use Encode::JP; # Pragmas use strict; use POSIX qw(:sys_wait_h); # Be taintless $ENV{'PATH'} = '/bin:/usr/bin'; delete @ENV{ 'IFS', 'CDPATH', 'ENV', 'BASH_ENV' }; my $VER = '0.0.5'; # Connect to server my $SOC = &connect( '172.16.xxx.xxx', 8801, 'tcp' ); $SOC = $$SOC; # Naming my $NAME = &name(); print $SOC 'nick ' . $NAME . "\n"; $SOC->flush(); print "* Your nickname is $NAME\n" if ( <$SOC> =~ /ok/ ); my $NOTICE = 'on'; my $TERM = new Term::ReadLine 'UNKO Client'; &sendlocal( '\s[5]HOGEサーバへの接続を確立しました.\w9\n' . 'UNKOクライアント v' . $VER . ' 起動しました.\w9' . '\1\s[10]ユーザ名は' . $NAME . 'です.\w9\n' . 'helpコマンドで簡単なコマンドの説明を見ることができます.' ); while ( defined( my $cmd = $TERM->readline('MESSAGE> ') ) ) { chomp($cmd); next if $cmd =~ /^\s*$/; print "\n"; last if $cmd eq 'quit' or $cmd eq 'exit' or $cmd eq 'q'; if ( $cmd =~ /^\s*list\s*$/ ) { &list(); } elsif ( $cmd =~ /^nick\s+(.+)\s*$/ ) { &nick($1); } elsif ( $cmd =~ /^notice\s+([Oo][Nn]|[Oo][Ff][Ff])\s*$/ ) { ¬ice($1); } elsif ( $cmd =~ /^\s*help\s*$/ ) { &help(); } else { if ( $cmd =~ /^unko\s+(.+)\s*$/ ) { $cmd = &unko($1); } $cmd =~ s/((http|https|ftp|file)\:\/\/[\w\.\~\-\/\?\&\+\=\:\@\%\;\#]+)/\\URL[$1]/g if $cmd !~ /\\URL\[.+\]/; print $SOC 'msg \t\h\0' . $cmd . '\w9\e' . "\n"; $SOC->flush(); my $tmp = <$SOC>; print $tmp; } } &disconnect( \$SOC ); # in -> none # out -> name string sub name() { my $name = `whoami` || `hostname` || "ななし"; chomp($name); return $name; } # in -> host, port, protocol # out -> ref to socket sub connect() { die if scalar(@_) != 3; my ( $host, $port, $proto ) = @_; my $socket = IO::Socket::INET->new( PeerAddr => $host, PeerPort => $port, Proto => $proto, ); die "Can't connect server $host:$port, $proto: $!\n" if !$socket; return \$socket; } # in -> ref to socket # out -> none sub disconnect() { my $socket = shift; $socket = $$socket; $socket->close() if defined $socket; } # in -> messages # out -> none sub sendlocal() { my $s = &connect( '127.0.0.1', 9801, 'tcp' ); $s = $$s; Encode::from_to( $NAME, 'euc-jp', 'shift_jis' ); print $s "SEND SSTP/1.1\r\n"; print $s "Sender: $NAME\r\n"; print $s "Script: \\t\\h\\0\\s[0]"; Encode::from_to( $NAME, 'shift_jis', 'euc-jp' ); foreach (@_) { $_ =~ s/\n/\\n/g; $_ =~ s/\r/\\r/g; Encode::from_to( $_, 'euc-jp', 'shift_jis' ); print $s $_; } print $s "\\e\r\n"; print $s "\r\n"; $s->flush(); &disconnect( \$s ); } # in -> none # out -> none sub list() { my $lists; print $SOC "list\n"; $SOC->flush(); while ( my $line = <$SOC> ) { $line =~ s/[\r\n]//g; last if ( $line eq 'ok' or $line eq 'err' ); $lists = "$lists\\n$line"; print "$line\n"; } &sendlocal($lists); } # in -> name # out -> none sub nick() { my ( $newname, $res ); $newname = shift; print $SOC "nick $newname\n"; $SOC->flush(); $res = <$SOC>; $res =~ s/[\r\n]//g; if ( $res eq 'ok' ) { print "Now your nickname is $newname.\n"; if ( $NOTICE eq 'on' ) { print $SOC "msg $NAME が $newname に変更されました.\n"; $SOC->flush(); <$SOC>; } $NAME = $newname; } else { print "nick command failed.\n"; } } # in -> on or off # out -> none sub notice() { $NOTICE = lc(shift); print "Notice broadcasting $NOTICE.\n"; &sendlocal("nick 変更通知を $NOTICE に設定しました."); } # in -> none # out -> none sub help() { print < target # out -> unko sub unko() { return sprintf( "%s なんて…\\w9…\\w9%s", shift, '\s[1]' . 'うんこ' x 70 . '\w9\c\s[7]\1\s[10]\_s超\w9\w3 う\w9 ん\w9 \s[11]こ\w9' ); }