#!/usr/bin/perl -w #============================================================================== # WMidi v.1.00 (Hyper Automatic Web Site Anlyzing Music Maker) # (C) Makamaka Hannyaharamitu http://www.donzoko.net/ # 自由に改変しちゃってください。ご使用の結果の責任は負いかねます。 # # MIDIは CPAN http://search.cpan.org/author/SBURKE/MIDI-Perl-0.8/ から # 手に入れるなどしてください。 # # 2003-08-30 v.1.00 とりあえず完成 # 2003-08-31 v.1.01 音色指定, use lib 追加 # 2003-09-01 v.1.02 md5により変換する文字数を一定に # 2003-09-05 v.1.03 check_url ドメイン名を正しく扱うように修正 # #============================================================================== $| = 1; use strict; use lib qw(.); use IO::Socket; use CGI qw(:standard); use MIDI::Simple; # MIDI-Perlが必要 use Digest::MD5 qw(md5_hex); # モジュールがない場合はコメントアウト use constant CRLF => "\x0D\x0A"; #============================================================================== # 設定 #============================================================================== use constant BASE => -10; # 生成される音程の補正。例は”低く”している use constant TEMPO => 80; # 1分あたりの四分音符の数 use constant MAX => 200; # URIの最大文字数 #============================================================================== use constant EXCLUSIVE => [ # 排除するURIを無名配列に入れる 'http://www.donzoko.net/cgi', ]; #============================================================================== main(); sub main{ my $cgi = new CGI; my $url = $cgi->param('url'); my $patch = $cgi->param('patch'); check_url($url) or error($cgi,"Invalid URL or Not Found"); print $cgi->header( -content_type => "audio/midi", -content_disposition => 'attachment;filename=' . time . '.mid' ); make_midi($url,$patch); } #============================================================================== sub make_midi{ my ($str,$patch) = @_; # URL,音色 my ($dura,$note); # 持続時間,音程 my $midi = MIDI::Simple->new_score(); # 新しいスコアを生成 $midi->text_event($str); # eventにURLを挿入 $str =~ s{http://(www\.)?}{}; # 余計な部分を取り除く $str =~ s{index\.html?}{}; $str =~ s/(\W)/'%' . unpack('H2', $1)/eg; $str = md5_hex($str); # Digest::MD5がない場合コメントアウト if(!defined $patch or $patch =~ /\D/ # デフォルトはチェレスタだ! or $patch < 0 or $patch > 127){ $patch = 8; } $midi->set_tempo( int(60000000 / TEMPO) ); # テンポの設定 $midi->patch_change( 1, $patch); # 音色の設定 $midi->noop( 'c1', 'f', 'o2'); # 準備完了 my $i = 0; for( reverse unpack('c*',$str) ){ $i++; $dura = 'd' . $_, next if($i % 2); $note = $MIDI::number2note{$_ + BASE}; $midi->n($dura,$note) if(defined $note); } $midi->write_score( *STDOUT{IO} ); # データを吐き出す } sub check_url{ # できればNet::HTTP使いたい… my $url = shift || return; my $port = 80; my $ex = EXCLUSIVE; my ($host,$file) = ( $url =~ m{^http://([a-zA-Z\.\-\d]+?)/(.*)} ); my ($socket,$request,$response); if(!defined $host or length($url) > MAX ){ return; } for( @$ex ){ # 無条件で失敗させる return if($url =~ /$_/); } $socket = IO::Socket::INET->new( PeerAddr => $host, PeerPort => $port, Proto => 'tcp', Type => SOCK_STREAM , Timeout => 15 ); $file = '/' . $file; $request = "HEAD $file HTTP/1.1" . CRLF . "Host: $host:$port" . CRLF . "User-Agent: " . 'Wmidi/1.0' . CRLF . CRLF; print $socket $request; $socket->flush(); $response = <$socket>; return ($response =~ /\s+2\d\d\s+/) ? 1 : 0; # ステータスのチェック } sub error{ my ($cgi,$message) = @_; print $cgi->header( "text/html" ), $cgi->start_html( "Error" ), $cgi->h1("Error"), $cgi->p( $message ), $cgi->end_html; exit; }