#!/usr/local/bin/perl # ↑サーバに合わせて設定 # ################################################################## # Script of Saga II $ver = 'modern 0.0 (strict β)'; # Copyright (C) 2001-2003 Missing Link. # All rights reserved. # 作成者 Sho # E-mail: sho@area-s.com # Home Page: http://www.area-s.com/ # このスクリプトはフリーウェアです。 # 本スクリプトを利用する方は以下のURLに記載された # 利用既定に同意したものとみなします。 # http://www.area-s.com/main/rule.html # 著作権はMISSING LINKが保有します。 # 質問等はサポート掲示板まで。 # http://www.area-s.com/main/support.html # ################################################################## # ################################################################## ### SOS2STRICT / 2008-09-01 / 鵜巷 ### ### Script of Saga II をとことん(でもないけど)厳格に書き直します ### ### このソースはより安全・堅牢なSOSの提案、 ### 安全・堅牢なSOSの実現のためのよりよい設計思想の学習、 ### リファレンス、オブジェクト指向など中上級者向けの仕組みの入門のための、 ### 実際に動作するテキストとなることを目標としています ### ### まえがき ### ### SOS2が世に出てからもう7年以上が経ちました。 ### その間、実に多くのウェブサイトがSOS2を設置し、また改造を公開しながらSOS2は発展して来ました。 ### その発展と同じように、Perlもまた成長・拡大していきました。 ### SOS2公開当時はまだ駆け出したばかり(…少なくともフリーCGI界隈では)だったPerl5も ### 今ではインターネットに繋がるほとんど全てのサーバにインストールされ、 ### 僕らのような末端のPerl愛好家にまで広く使われるようになりました。 ### 現在ではPerl6の開発も進み、近く正式に公開される見通しです。 ### ### SOS2はPerl4、つまり古い時代のPerlの文法に則って記述されています。 ### Perl4ではレキシカルスコープがなく、リファレンスも存在しなかったので ### 変数に予期しない数値が入るなどによるバグが生まれやすく ### また、複雑なデータ構造を表現することが困難でした。 ### Perl4の文法に則っているSOS2はPerl4と同じ問題を抱えているので ### 複雑なデータ処理を大量に必要とするゲームCGIとしては、これは致命的な欠陥と言えるでしょう。 ### CGIの基幹となるサブルーチン類とデータ構造は十分に設計されているとは言い難く、 ### 表示を担うサブルーチン類と品質を比較するといまいちな部分もいくつかあります。 ### ### 現在、古いPerlが使われているサーバはもう殆どないでしょう。 ### Perl4との互換性を気にしなければいけない時代はとうに過ぎ去りました。 ### SOS2にも新しい流れが必要です。そのために我々は新しきを学ぶときなのです。 ### ### 本当に変数の名前を100個も覚える必要があるでしょうか？ ### ユーザーデータやアイテムを使用するために毎回ややこしいおまじないを唱える必要があるでしょうか？ ### サブルーチンをあっちへ飛んだりこっちへ飛んだりしてるうちに ### 変数の中身がどんな風に変わってしまったのか悩んだりする必要が、あるでしょうか？ ### ### 答えはこのSOS2STRICTにあります。どうぞ、SOS2のイノベーションを楽しんでください。 ### SOS2もまた、生まれ変わるときが来たのです！ ### ### …というのは話の流れのアレなのでいいすぎです。革命とかそんなんじゃなくて、 ### あくまでこれはSOS2でPerlをもっと勉強してみたいひとへ向けたテキストです。 ### このテキストがPerlとより深くお付き合いするための手助けになればうれしいです。 ### (しっかし対象読者の範囲がとてつもなく狭いテキストだ…) ### ### 鵜巷 ### ### 表記について ### 通常のコメントと区別するために、以下の表記を使用します ### ### (井桁3つ): 解説のためのコメント ;;# (アポストロフィ2つ付コメント): ソースの置き換え・追加 ### SOS2STRICTでは実行順に解説するためにサブルーチンを並べ替えて書いています ### 解説したい順にいろいろと入れ替えているので ### オリジナルのソースに慣れているとちょっと混乱するかもしれません。がんばって ### ### それでは、SOS2STRICTの解説を始めます ### ### 2009-04-10 追記 ### 今読み返すと、かなり難易度の高いことを一遍にやっているようなので ### SOS2STRICT, SOS2REFERENCE, SOS2OOP の3章に分けようと思います ### このファイルでは ### ・use strict; ### ・スコープ ### ・いくつかの堅牢なプログラミングのための手引き ### について書いていきます。リファレンスとオブジェクト指向プログラミング、 ### それらを利用した高度なSOS2作成は SOS2REFERENCE, SOS2OOP で解説したいと思います ### ### それでは改めまして、SOS2STRICTの解説を始めます ### ### 2014-06-08 追記 ### Script of Saga II Wiki Rの掲示板でのやりとりでこの企画の存在を思い出し ### 1300行目辺りで力尽きて放置されているこのファイルを発掘しました ### 執筆当時から需要の無さに根気が続かず、お蔵入りになった企画ですが ### 誰にも求められていないことを重々承知しつつ、当時を思い出すよすがとして公開してみます ### ### (公開にあたって、筆者の名前を変更して、書きかけだった ### sub opensosdat, sub writesosdat の解説を仕上げました) # ################################################################## ;;# use strict; ### use strict はPerlの言語仕様を超厳しいものに変えるおまじないです ### use strict が呼ばれると、宣言されていない変数、つまり ### my とか local とかが付いていない変数を使った場合などにコンパイルエラーになります ### ほかにもいくつか機能があるのですが、主だったものは上記のとおりで ### 変数の名前を間違えて書いたりするのを防ぐことが出来ます。端的に言えば、バグが減る ### SOS2はむき出しの変数が殆どなので、異常な変数がらみのバグがとっても多いのですが ### それが確実に減少しますし、変数には my や local を必ずつけなければいけないというルールは ### 後々よい状況を生み出してくれます。良い状況については、後述 ### ### use strict は現代のPerlでは必須も必須、超基本のおまじないです ### 一画面に収まりきらないようなコードなら確実に書きます。収まってても書きます ### 一行目に #!/usr/local/bin/perl って書くくらい基本だと思ってもいいかもしれません ### 新しくCGIを作ったりするのなら間違いなく書きましょう ### SOSで use strict は…ちょっとどころかかなりの困難があるので、この限りではありませんが――― ### （そして皆さんにはその困難に立ち向かって貰うわけです…） ### ### use warnings というのもあるんですが、今回は使いません ### "use" に関してはググってね。"perl use"とか"perl モジュール"とか"perl プラグマ"とか ### ### ちなみに use strict の前にある変数は use strict のルールが適用されません ### だからこのソースの最初に $ver があるけど大丈夫 ### our (%Fm, %In); # use vars qw(%Fm %In); # for under v5.5 ### %Fm はフォームデータ、%In は設定が入ります ### our は変数を宣言します ### my や local と何が違うのか… ### 非常に説明が長く難しくそれでいてSOS2STRICTの解説から逸脱するのでやりませんが ### スコープの概念やレキシカル・グローバル変数、パッケージについて調べてみるといいかもしれません ### このテキストでも後ほど簡単に説明します ### ここではsos2.cgiのファイルの中ならどこでも使える ### グローバルな変数を宣言するよーってしるし、くらいに捉えていただければ ### ### our は perl 5.6.0 からの機能なので、それ以前のバージョンのperlを使っている場合は ### use vars のほうを使ってくださいねー ### ;;# require 'jcode.pl'; # jcode.plのパス 644 ;;# ### 設定を全て %In に格納します。 ### ;;# ---------- FILE PATH ;;#$cgiurl = './sos2.cgi'; # sos.cgiのパス 755(705) ;;#$sosdat = './sos.dat'; # sos.datのパス 666(606) ;;#$jobdat = './job.dat'; # job.datのパス 666(606) ;;#$itmdat = './itm.dat'; # itm.datのパス 666(606) ;;#$cjbdat = './cjb.dat'; # cjb.datのパス 666(606) ;;#$bupdat = './bup.dat'; # bup.datのパス 666(606) ;;#$bitdat = './bit.dat'; # bit.datのパス 666(606) ;;# ;;# ;;# ---------- USER DIRECTORY ;;#$usrdir = 'userdata/'; # ユーザデータを格納するフォルダ ;;# ;;# ---------- BACK URL ;;#$homurl = 'index.html'; # 戻り先URL ;;#$target = 'target=_self'; # ターゲット ;;# ;;# ---------- ADMINISTER ;;#$admpas = '0000'; # 管理者パスワード ;;# ;;# ---------- IMAGE ;;# CGIと同じ場所にフォルダを置く場合は'./フォルダ名/';　上の階層は'../フォルダ名/'; ;;# 相対パスがわからなければ絶対パス(http://からはじまる)でも構いません。 ;;#$imgdir = './img/'; # 全ての画像を格納するフォルダのパス ;;#$ttlimg = 'title.gif'; # タイトルイメージファイル ;;#$ttlapd = 1; # プレイ中にタイトル画像を表示する(yes = 1,no = 0) ;;# ;;#$htitle = 'Script of Saga II'; ;;# ;;# ---------- LOCK FILE ;;#$lockkey = 1; # ファイルのロック(Mkdir = 1,Symlink=2,No = 0) ;;#$lockfile = './sos.lock'; # ロックファイル名＆パス ;;# ;;# ---------- FONT ;;#$fntsze = 12; # フォントサイズ ;;#$scdclr = '#5599CC'; # メニューのフォント色 ;;#$butfsz = 10; # ボタンフォントサイズ ;;# ;;# ---------- GET HOST ;;# ホスト名取得 ;;# $ENV{'REMOTE_HOST'} で取得→0 ;;# gethostbyaddr で取得→1 ;;#$hosttype = 0; ;;# ;;# ---------- TABLE ;;#$tblbdr = 5; # テーブルの枠の太さ ;;#$tblcpd = 5; # テーブルの余白サイズ ;;#$tblbgc = '#FFFFFF'; # テーブルの背景色 ;;#$tblbdc = '#000000'; # テーブルのボーダー色 ;;#$tblwth = '100%'; # テーブルの横幅 ;;# ;;# ---------- LIST ;;#$ltclr = '#C4C4C4'; # リストの背景色 ;;#$optclr = '#A52A2A'; # レアアイテム、賞金首の色 ;;#$nfclr = '#FFFFFF'; # 名前表示部のフォント色 ;;#$nmclr = '#666666'; # 名前表示部の背景色 ;;#$mnclr = '#333333'; # メニューの背景色 ;;#$pznclr = 'purple'; # 接触相手のpoisonの色 ;;#$dedclr = 'red'; # 接触相手のdeadの色 ;;# ;;# ---------- MESSAGE ;;#$msgclr = '#FF3333'; # メッセージのフォント色 ;;#$msgclr = '#FF3333'; # メッセージのフォント色 ;;# ;;# ---------- BODY ;;#$body = qq|\n|; ;;# ;;# 通常変更不要 ;;#$hernam = '英雄'; ;;#$ricnam = '大富豪'; ;;#$poenam = '語り部'; ;;#$avenam = '旅人'; ;;#$def_ok = '決定'; ;;#$def_pb = '質屋'; ;;# ;;# ---------- キャラクター画像サイズ ;;#$ig_wd = 52; # 横 ;;#$ig_ht = 102; # 縦 ;;# ---------- ステラツィオ画像サイズ ;;#$st_wd = 15; # 横 ;;#$st_ht = 15; # 縦 ;;# ;;# ---------- 戦闘設定 ;;#$Badice = 8; # 戦闘に使うサイコロの面数 ;;#$def_dm = 5; # ダメージ修正値（ダメージの値を軽減します) ;;#$def_ab = 1; # 戦闘を挑まれる側の攻撃ボーナス(アドバンテージ) ;;# ;;#$Chdice = 7; # 必殺の確率 1/x ;;#$Mgdice = 8; # 魔法の確率 1/x ;;#$Afdice = 5; # 鉄壁の確率 1/x ;;#$Bedice = 5; # 悩殺の確率 1/x ;;#$Cndice = 6; # 首狩の確率 1/x ;;#$Drdice = 6; # 吸収の確率 1/x ;;#$Ctdice = 5; # 反撃の確率 1/x ;;#$Lddice = 5; # 愛犬の確率 1/x ;;#$Dtdice = 6; # 道連の確率 1/x ;;#$Dkdice = 4; # 連切の確率 1/x ;;#$Cmdice = 4; # 魅了の確率 1/x ;;#$Bkdice = 6; # 暴走の確率 1/x ;;#$def_Qm = 2; # 剣の舞のボーナスポイント ;;# ;;#$Sidice = 12; # 相手からアイテムを奪う確率 アイテム総数/x ;;#$def_td = 2; # 盗賊のアイテムを奪う確率修正 アイテム総数/x-y ;;#$Bidice = 10; # 戦闘中に武器、防具の壊れる確率 1/x ;;#$Bldice = 2; # レアアイテムは通常のx倍壊れにくい ;;# ---------- 回復設定 ;;#$def_hc = 1; # 聖職者が一回の解毒に消費する体力 ;;#$def_hr = 3; # 聖職者が一回の蘇生に消費する体力 ;;#$def_hn = 10; # 「町にいる」で体力が1回復するのにかかる時間(分) ;;#$def_hh = 15; # 「人里離れる」で体力が1回復するのにかかる時間(分) ;;#$def_hs = 8; # アイテムによる保存で体力が1回復するのにかかる時間(分) ;;#$def_hm = 5; # 格闘家の体力回復のボーナス時間(分)(マイナスする時間) ;;#$def_pz = 3; # 毒状態によって遅延される時間(分) ;;#$def_ha = 10; # 蘇生するのに必要な時間(時間) ;;#$def_pd = 20; # 探索時に毒により体力を奪われる確率 x/100 ;;# ---------- 保存設定 ;;#$def_hd = 3; # 人里離れたプレイヤーの発見率 1/x ;;#$def_th = 2; # 人里離れた盗賊を発見する場合の修正値 1/x+y ;;#$def_bh = 1; # 賞金稼ぎが人里離れた賞金首を見付ける場合の修正値 1/x-y ;;#$def_gl = 4; # 一定期間プレイしないと名前に棒線が引かれる(日数) ;;#$def_dl = 5; # 一定期間プレイしないと削除(日数) ;;# ---------- 質屋設定 ;;#$def_pa = 1; # 特定の人物以外質屋を使えないようにする(yes=1,no=0) ;;#$def_pp = 'pawn'; # 質屋を使用するためのパスワード(この語を含んでいればOK) ;;#$def_as = 5; # 買取品を自動で幾らか上乗せして売る(yes=値段,no=0) ;;#$def_ap = 10; # 買取品を自動で何%か上乗せして売る(yes=%,no=0) ;;# 古いアイテムは順に捨てていく(アイテムソートOFFの場合有効)(yes=1,no=0) ;;#$def_ad = 0; # ゲームバランスが狂う可能性があるので要注意 ;;#$def_gp = 10; # 非戦闘系の最低販売額の設定(yes=質屋買取額に上乗せする額,no=0) ;;#$def_lv = 0; # 徴収対象(全員=0,戦闘系=1,非戦闘系=2) ;;#$def_lp = 10; # 徴収率(%) ;;# ---------- 報奨金設定 ;;#$def_rp = 100; # 賞金首として登録される金額(執行猶予がつかない) ;;#$def_ar = 4; # 自動で賞金首に懸賞金が付くようにする(yes=金額,no=0) ;;#$def_wm = 0.02; # 攻撃者勝利金制度{yes=(勝者のRate-敗者のRate)*$def_wmの勝利金,no=0} ;;#$def_lm = 0.02; # 迎撃者勝利金制度{yes=(勝者のRate-敗者のRate)*$def_lmの勝利金,no=0} ;;#$def_lt = 100; # 限度額(yes=金額,no=0) ;;# ---------- 武器屋設定 ;;# 武器屋が作れる武具の設定(戦闘型は全て装備可能、○○は置換されます) ;;# ボーナスは必ず4桁にして下さい。上2桁攻撃。下2桁が防御) ;;#$def_yw = '○○の剣';# 剣 ;;#$def_bn1 = '0200'; # ボーナス ;;#$def_pc1 = 30; # 下取り価格 ;;#$def_ys = '○○の盾';# 盾 ;;#$def_bn2 = '0002'; # ボーナス ;;#$def_pc2 = 30; # 下取り価格 ;;#$def_ya = '○○の鎧';# 鎧 ;;#$def_bn3 = '0002'; # ボーナス ;;#$def_pc3 = 30; # 下取り価格 ;;#$def_yt = '○○の銀細工'; # 銀細工 ;;#$def_bn4 = '0101'; # ボーナス ;;#$def_pc4 = 50; # 下取り価格 ;;# ;;#$def_pr = 40; # 作成成功率 % ;;# ---------- その他設定 ;;#$def_ts = 60; # テキスト部の長さ(名前入力欄とパスワード除く) ;;#$def_md = 100; # 削除するために必要な金額 ;;#$def_om = 30; # My RecordのMAX個人記事保存数（30でおよそ3.5kb） ;;#$def_np = 60; # セーブしないで終了したプレイヤーと接触可能になる時間(分) ;;#$def_ne = 1; # 新規登録を受け付ける(yes=1,no=0) ;;#$def_sv = 0; # プレイヤーリスト簡易表示(yes=1,no=0) ;;#$def_so = 0; # アイテムをソートして並べる(yes=1,no=0) ;;#$def_mr = 0; # My Recordをメニューにも表示する(yes=1,no=0) ;;# (別ウィンドウで表示しますがアドレスにpassが載るので注意してください) ;;# ---------- ステラツィオ ;;# ステラツィオの名前 ;;#@itn = ('Aries','Taurus','Gemini','Cancer','Leo','Virgo','Libra','Scorpio','Sagittarius','Capricorn','Aquarius','Pisces'); ;;# ;;#$def_zd = 1; # ステラツィオの発見確率 x/100 ;;#$def_xs = 0; # ステラツィオに所持上限をつける(yes=上限値,no=0) ;;#$def_jg = '.gif'; # 画像のファイル形式 ;;# ;;# ステラツィオの略字(変更不要) ;;#@iti = ('A','T','G','C','L','V','B','O','R','N','Q','P'); ;;# ステラツィオを全て揃えたときにアップ可能なリスト ;;# HP=体力,BG=所持上限,AT=攻撃,DF=防御,その他のスキルは略字のみを入力 ;;#@sdtlines = ('HP2','BG1','AT1','DF1'); ;;# 説明 ;;#@smglines = ('体力+2','所持上限+1','攻撃+1','防御+1'); ;;# ;;# 追加攻撃魔法 攻撃力0〜10まで 例：攻撃力0の場合MarshMallowが発動 ;;# 魔法のダメージは攻撃力と同等 それ以上は追加して下さい。 ;;#@def_mn = ('MarshMallow','Fire','Quake','Lightning','Plasma','Explosion','Terror','Death','Demolish','Extinction','Ultimate'); ;;# ;;# コメントのデコレーション(変更のSUPPORTはお受けできません) ;;#@deckey = (':S:',':I:'); # ←を入力すると↓に変換する ;;#@decwrd = ('SALE!','告知!'); ;;# ;;# 2001/5/21追加 ;;#$def_pg = 20; # リストで1回に表示する件数 ;;# ;;# ---------- METHOD ;;#$method = 'POST'; # アクションメソッド (POST Only) # ---------- FILE PATH $In{cgiurl} = './sos2.cgi'; # sos.cgiのパス 755(705) $In{sosdat} = './sos.dat'; # sos.datのパス 666(606) $In{jobdat} = './job.dat'; # job.datのパス 666(606) $In{itmdat} = './itm.dat'; # itm.datのパス 666(606) $In{cjbdat} = './cjb.dat'; # cjb.datのパス 666(606) $In{bupdat} = './bup.dat'; # bup.datのパス 666(606) $In{bitdat} = './bit.dat'; # bit.datのパス 666(606) # ---------- USER DIRECTORY $In{usrdir} = 'userdata/'; # ユーザデータを格納するフォルダ # ---------- BACK URL $In{homurl} = 'index.html'; # 戻り先URL $In{target} = 'target=_self'; # ターゲット # ---------- ADMINISTER $In{admpas} = '0000'; # 管理者パスワード # ---------- IMAGE # CGIと同じ場所にフォルダを置く場合は'./フォルダ名/';　上の階層は'../フォルダ名/'; # 相対パスがわからなければ絶対パス(http://からはじまる)でも構いません。 $In{imgdir} = './img/'; # 全ての画像を格納するフォルダのパス $In{ttlimg} = 'title.gif'; # タイトルイメージファイル $In{ttlapd} = 1; # プレイ中にタイトル画像を表示する(yes = 1,no = 0) $In{htitle} = 'Script of Saga II'; # ---------- LOCK FILE $In{lockkey} = 1; # ファイルのロック(Mkdir = 1,Symlink=2,No = 0) $In{lockfile} = './sos.lock'; # ロックファイル名＆パス # ---------- FONT $In{fntsze} = 12; # フォントサイズ $In{scdclr} = '#5599CC'; # メニューのフォント色 $In{butfsz} = 10; # ボタンフォントサイズ # ---------- GET HOST # ホスト名取得 # $ENV{'REMOTE_HOST'} で取得→0 # gethostbyaddr で取得→1 $In{hosttype} = 0; # ---------- TABLE $In{tblbdr} = 5; # テーブルの枠の太さ $In{tblcpd} = 5; # テーブルの余白サイズ $In{tblbgc} = '#FFFFFF'; # テーブルの背景色 $In{tblbdc} = '#000000'; # テーブルのボーダー色 $In{tblwth} = '100%'; # テーブルの横幅 # ---------- LIST $In{ltclr} = '#C4C4C4'; # リストの背景色 $In{optclr} = '#A52A2A'; # レアアイテム、賞金首の色 $In{nfclr} = '#FFFFFF'; # 名前表示部のフォント色 $In{nmclr} = '#666666'; # 名前表示部の背景色 $In{mnclr} = '#333333'; # メニューの背景色 $In{pznclr} = 'purple'; # 接触相手のpoisonの色 $In{dedclr} = 'red'; # 接触相手のdeadの色 # ---------- MESSAGE $In{msgclr} = '#FF3333'; # メッセージのフォント色 $In{msgclr} = '#FF3333'; # メッセージのフォント色 # ---------- BODY $In{body} = qq|\n|; # 通常変更不要 $In{hernam} = '英雄'; $In{ricnam} = '大富豪'; $In{poenam} = '語り部'; $In{avenam} = '旅人'; $In{def_ok} = '決定'; $In{def_pb} = '質屋'; # ---------- キャラクター画像サイズ $In{ig_wd} = 52; # 横 $In{ig_ht} = 102; # 縦 # ---------- ステラツィオ画像サイズ $In{st_wd} = 15; # 横 $In{st_ht} = 15; # 縦 # ---------- 戦闘設定 $In{Badice} = 8; # 戦闘に使うサイコロの面数 $In{def_dm} = 5; # ダメージ修正値（ダメージの値を軽減します) $In{def_ab} = 1; # 戦闘を挑まれる側の攻撃ボーナス(アドバンテージ) $In{Chdice} = 7; # 必殺の確率 1/x $In{Mgdice} = 8; # 魔法の確率 1/x $In{Afdice} = 5; # 鉄壁の確率 1/x $In{Bedice} = 5; # 悩殺の確率 1/x $In{Cndice} = 6; # 首狩の確率 1/x $In{Drdice} = 6; # 吸収の確率 1/x $In{Ctdice} = 5; # 反撃の確率 1/x $In{Lddice} = 5; # 愛犬の確率 1/x $In{Dtdice} = 6; # 道連の確率 1/x $In{Dkdice} = 4; # 連切の確率 1/x $In{Cmdice} = 4; # 魅了の確率 1/x $In{Bkdice} = 6; # 暴走の確率 1/x $In{def_Qm} = 2; # 剣の舞のボーナスポイント $In{Sidice} = 12; # 相手からアイテムを奪う確率 アイテム総数/x $In{def_td} = 2; # 盗賊のアイテムを奪う確率修正 アイテム総数/x-y $In{Bidice} = 10; # 戦闘中に武器、防具の壊れる確率 1/x $In{Bldice} = 2; # レアアイテムは通常のx倍壊れにくい # ---------- 回復設定 $In{def_hc} = 1; # 聖職者が一回の解毒に消費する体力 $In{def_hr} = 3; # 聖職者が一回の蘇生に消費する体力 $In{def_hn} = 10; # 「町にいる」で体力が1回復するのにかかる時間(分) $In{def_hh} = 15; # 「人里離れる」で体力が1回復するのにかかる時間(分) $In{def_hs} = 8; # アイテムによる保存で体力が1回復するのにかかる時間(分) $In{def_hm} = 5; # 格闘家の体力回復のボーナス時間(分)(マイナスする時間) $In{def_pz} = 3; # 毒状態によって遅延される時間(分) $In{def_ha} = 10; # 蘇生するのに必要な時間(時間) $In{def_pd} = 20; # 探索時に毒により体力を奪われる確率 x/100 # ---------- 保存設定 $In{def_hd} = 3; # 人里離れたプレイヤーの発見率 1/x $In{def_th} = 2; # 人里離れた盗賊を発見する場合の修正値 1/x+y $In{def_bh} = 1; # 賞金稼ぎが人里離れた賞金首を見付ける場合の修正値 1/x-y $In{def_gl} = 4; # 一定期間プレイしないと名前に棒線が引かれる(日数) $In{def_dl} = 5; # 一定期間プレイしないと削除(日数) # ---------- 質屋設定 $In{def_pa} = 1; # 特定の人物以外質屋を使えないようにする(yes=1,no=0) $In{def_pp} = 'pawn'; # 質屋を使用するためのパスワード(この語を含んでいればOK) $In{def_as} = 5; # 買取品を自動で幾らか上乗せして売る(yes=値段,no=0) $In{def_ap} = 10; # 買取品を自動で何%か上乗せして売る(yes=%,no=0) # 古いアイテムは順に捨てていく(アイテムソートOFFの場合有効)(yes=1,no=0) $In{def_ad} = 0; # ゲームバランスが狂う可能性があるので要注意 $In{def_gp} = 10; # 非戦闘系の最低販売額の設定(yes=質屋買取額に上乗せする額,no=0) $In{def_lv} = 0; # 徴収対象(全員=0,戦闘系=1,非戦闘系=2) $In{def_lp} = 10; # 徴収率(%) # ---------- 報奨金設定 $In{def_rp} = 100; # 賞金首として登録される金額(執行猶予がつかない) $In{def_ar} = 4; # 自動で賞金首に懸賞金が付くようにする(yes=金額,no=0) $In{def_wm} = 0.02; # 攻撃者勝利金制度{yes=(勝者のRate-敗者のRate)*$def_wmの勝利金,no=0} $In{def_lm} = 0.02; # 迎撃者勝利金制度{yes=(勝者のRate-敗者のRate)*$def_lmの勝利金,no=0} $In{def_lt} = 100; # 限度額(yes=金額,no=0) # ---------- 武器屋設定 # 武器屋が作れる武具の設定(戦闘型は全て装備可能、○○は置換されます) # ボーナスは必ず4桁にして下さい。上2桁攻撃。下2桁が防御) $In{def_yw} = '○○の剣';# 剣 $In{def_bn1} = '0200'; # ボーナス $In{def_pc1} = 30; # 下取り価格 $In{def_ys} = '○○の盾';# 盾 $In{def_bn2} = '0002'; # ボーナス $In{def_pc2} = 30; # 下取り価格 $In{def_ya} = '○○の鎧';# 鎧 $In{def_bn3} = '0002'; # ボーナス $In{def_pc3} = 30; # 下取り価格 $In{def_yt} = '○○の銀細工'; # 銀細工 $In{def_bn4} = '0101'; # ボーナス $In{def_pc4} = 50; # 下取り価格 $In{def_pr} = 40; # 作成成功率 % # ---------- その他設定 $In{def_ts} = 60; # テキスト部の長さ(名前入力欄とパスワード除く) $In{def_md} = 100; # 削除するために必要な金額 $In{def_om} = 30; # My RecordのMAX個人記事保存数（30でおよそ3.5kb） $In{def_np} = 60; # セーブしないで終了したプレイヤーと接触可能になる時間(分) $In{def_ne} = 1; # 新規登録を受け付ける(yes=1,no=0) $In{def_sv} = 0; # プレイヤーリスト簡易表示(yes=1,no=0) $In{def_so} = 0; # アイテムをソートして並べる(yes=1,no=0) $In{def_mr} = 0; # My Recordをメニューにも表示する(yes=1,no=0) # (別ウィンドウで表示しますがアドレスにpassが載るので注意してください) # ---------- ステラツィオ # ステラツィオの名前 $In{itn} = ['Aries','Taurus','Gemini','Cancer','Leo','Virgo','Libra','Scorpio','Sagittarius','Capricorn','Aquarius','Pisces']; $In{def_zd} = 1; # ステラツィオの発見確率 x/100 $In{def_xs} = 0; # ステラツィオに所持上限をつける(yes=上限値,no=0) $In{def_jg} = '.gif'; # 画像のファイル形式 # ステラツィオの略字(変更不要) $In{iti} = ['A','T','G','C','L','V','B','O','R','N','Q','P']; # ステラツィオを全て揃えたときにアップ可能なリスト # HP=体力,BG=所持上限,AT=攻撃,DF=防御,その他のスキルは略字のみを入力 $In{sdtlines} = ['HP2','BG1','AT1','DF1']; # 説明 $In{smglines} = ['体力+2','所持上限+1','攻撃+1','防御+1']; # 追加攻撃魔法 攻撃力0〜10まで 例：攻撃力0の場合MarshMallowが発動 # 魔法のダメージは攻撃力と同等 それ以上は追加して下さい。 $In{def_mn} = ['MarshMallow','Fire','Quake','Lightning','Plasma','Explosion','Terror','Death','Demolish','Extinction','Ultimate']; # コメントのデコレーション(変更のSUPPORTはお受けできません) $In{deckey} = [':S:',':I:']; # ←を入力すると↓に変換する $In{decwrd} = ['SALE!','告知!']; # 2001/5/21追加 $In{def_pg} = 20; # リストで1回に表示する件数 # ---------- METHOD $In{method} = 'POST'; # アクションメソッド (POST Only) ;;# ### なぜ設定をハッシュ(連想配列)に変えたかというと、 ### まず一つは設定とその他の変数の区別を明確にするためです ### 設定は %In に全て入っているよと覚えておけば新しい変数を作りたくなった時に ### %In を使わないようにするだけで済み、名前付けで悩みませんし ### 実際に使うときも、設定とサブルーチン内でだけ使っている変数の違いがひとめで分かるようになります ### ### もう一つは、設定のような最初に代入した数値から変更しない変数が大量に ### それもどこからでも参照できるグローバル変数として宣言されていると ### どこかで確実に他の変数と名前がぶつかってバグの元になるからです ### 設定がひとつふたつならスカラーで宣言してもいいとは思いますが ### これだけ大量の設定を全てスカラーで宣言するということは ### そのぶんプログラム中で使ってはいけない名前が増えるわけですから ### 気づかないうちに設定を書き換えてしまったりして、バグを生んでしまうということがあります ### ハッシュに入れてしまえば、使う変数は一つだけです ### それでもまだ設定と設定で名前がぶつからないように気を使わなければいけません ### これは仕方のない部分でもありますが、それも工夫次第で悩みは少なくなります ### ### ハッシュにした理由の最後は、スカラーだと値が一つ増えるたびに ### my を付けて宣言しなければいけないので、とても面倒だからです。本当です。 ### ### ここで use strict の利点そのいち ### 変数を使うときは my や local で必ず使うことを宣言しなければならないので ### 変数の作成に慎重になり、使用する変数の数も少なくなります ### 使う変数が少なければ、変数の中身を把握するために使う労力も減ります ### 使っている変数の中身を全て把握していればバグを作る可能性が減り ### バグを作ったとしてもすぐに原因が特定できるでしょう。これはとても素晴らしいことです ### # Main Program # ;;# ;;#&decode; decode(); ### %Fm にフォームデータが入ります ### &(アンパサンド)を先頭につけ、()を省略したサブルーチン呼び出しをやめて ### ()を付けて、&を省略したサブルーチン呼び出しに書き換えました ### &を省略したのは、それが通例・慣習だから…ということにします ### ### これにより sub decode には空のリストが渡されるようになります(何も渡されませんということ) ### ()を省略していると @_ が渡されてしまうので ### 呼び出し方によっては @_ に何か入っていると思いもよらない動作を起こすことがあります ### 不要なものがサブルーチンに渡るのは出来るだけ避けたほうがいいでしょう ### ### &か()が付いていればサブルーチン呼び出しであることは示されるので ### どちらか付けて置けばいいのですが、上記のこともあるので()をつけるほうを推奨します ### &が付いてないとサブルーチンっぽくなくて嫌！という方は&も付けておいていいんじゃないかな ### 明示的にするために&つけなきゃいけない場面もありますし ### ;;# if ($Fm{'id'} =~ /\W/) { error('不正な入力です') } if ($Fm{'pd'} =~ /\W/) { error('不正な入力です') } if ($Fm{'pd2'} =~ /\W/) { error('不正な入力です') } ;;# ;;#&lock; lock_start(); ### lock -> lock_start に変更しました ### lock は perl 5.5 から予約語になっています? ### 使ったことがないので詳しく説明することが出来ませんが ### スレッド機能を利用する際に名前のとおりの機能を提供するようです ### ### 組み込み関数(なのかな？)と混乱したくないので ### lock という名前は出来れば使わないようにしたいです ### ### ちなみに、&lock のままなら問題なく sub lock が呼ばれてきちんと動作します ### これが先ほど書いた明示的にするために&をつけないといけない場面です…ｗ ### しかしSOS2STRICTでは全てのサブルーチン呼び出しで&を省略する予定ですので ### ここも例外とせず、&を省略するためにサブルーチン名を変更しました ### ;;# ;;# ;;#if (!$Fm{'mode'}) { &main_form } ;;#if ($Fm{'mode'} eq 'norm_save') { &save_game } ;;#if ($Fm{'mode'} eq 'hide_save') { &save_game } ;;#if ($Fm{'mode'} eq 'make_new') { &make_new } ;;#if ($Fm{'mode'} eq 'make_con') { &make_con } ;;#if ($Fm{'mode'} eq 'new_game') { &enter_form } ;;#if ($Fm{'mode'} eq 'con_game') { &enter_form } ;;#if ($Fm{'mode'} eq 'find_partner') { &contact_form } ;;#if ($Fm{'mode'} eq 'find_item') { &play_form } ;;#if ($Fm{'mode'} eq 'dump_before') { &play_form } ;;#if ($Fm{'mode'} eq 'dump_after') { &play_form } ;;#if ($Fm{'mode'} eq 'goods_before') { &action_form } ;;#if ($Fm{'mode'} eq 'goods_after') { &play_form } ;;#if ($Fm{'mode'} eq 'use_before') { &action_form } ;;#if ($Fm{'mode'} eq 'use_after') { &play_form } ;;#if ($Fm{'mode'} eq 'stell_before') { &action_form } ;;#if ($Fm{'mode'} eq 'stell_after') { &play_form } ;;#if ($Fm{'mode'} eq 'stell_comp') { &play_form } ;;#if ($Fm{'mode'} eq 'judge_before') { &action_form } ;;#if ($Fm{'mode'} eq 'judge_after') { &play_form } ;;#if ($Fm{'mode'} eq 'trade_before') { &action_form } ;;#if ($Fm{'mode'} eq 'trade_after') { &contact_form } ;;#if ($Fm{'mode'} eq 'sell_before') { &action_form } ;;#if ($Fm{'mode'} eq 'sell_after') { &contact_form } ;;#if ($Fm{'mode'} eq 'buy_before') { &action_form } ;;#if ($Fm{'mode'} eq 'buy_after') { &contact_form } ;;#if ($Fm{'mode'} eq 'fee_before') { &play_form } ;;#if ($Fm{'mode'} eq 'fee_after') { &play_form } ;;#if ($Fm{'mode'} eq 'cr') { &contact_form } ;;#if ($Fm{'mode'} eq 'rv') { &contact_form } ;;#if ($Fm{'mode'} eq 'com_before') { &play_form } ;;#if ($Fm{'mode'} eq 'com_after') { &play_form } ;;#if ($Fm{'mode'} eq 'note_before') { &play_form } ;;#if ($Fm{'mode'} eq 'note_after') { &play_form } ;;#if ($Fm{'mode'} eq 'poem_before') { &play_form } ;;#if ($Fm{'mode'} eq 'poem_after') { &play_form } ;;#if ($Fm{'mode'} eq 'name_before') { &play_form } ;;#if ($Fm{'mode'} eq 'name_after') { &play_form } ;;#if ($Fm{'mode'} eq 'words_before') { &contact_form } ;;#if ($Fm{'mode'} eq 'words_after') { &contact_form } ;;#if ($Fm{'mode'} eq 'goodbye') { &play_form } ;;#if ($Fm{'mode'} eq 'list') { &list_order } ;;#if ($Fm{'mode'} eq 'list') { &player_list } ;;#if ($Fm{'mode'} eq 'sale') { &sale_order } ;;#if ($Fm{'mode'} eq 'my_record') { &my_record } ;;#if ($Fm{'mode'} eq 'reward') { &play_form } ;;#if ($Fm{'mode'} eq 'fight') { &contact_form } ;;#if ($Fm{'mode'} eq 'del_before') { &play_form } ;;#if ($Fm{'mode'} eq 'del_after') { &main_form } ;;#if ($Fm{'mode'} eq 'back_up') { &play_form } ;;#if ($Fm{'mode'} eq 'levy') { &levy } ;;#&unlock; ;;#&footer; ;;#exit; if (!$Fm{'mode'}) { main_form() } elsif ($Fm{'mode'} eq 'norm_save') { save_game() } elsif ($Fm{'mode'} eq 'hide_save') { save_game() } elsif ($Fm{'mode'} eq 'make_new') { make_new() } elsif ($Fm{'mode'} eq 'make_con') { make_con() } elsif ($Fm{'mode'} eq 'new_game') { enter_form() } elsif ($Fm{'mode'} eq 'con_game') { enter_form() } elsif ($Fm{'mode'} eq 'find_partner') { contact_form() } elsif ($Fm{'mode'} eq 'find_item') { play_form() } elsif ($Fm{'mode'} eq 'dump_before') { play_form() } elsif ($Fm{'mode'} eq 'dump_after') { play_form() } elsif ($Fm{'mode'} eq 'goods_before') { action_form() } elsif ($Fm{'mode'} eq 'goods_after') { play_form() } elsif ($Fm{'mode'} eq 'use_before') { action_form() } elsif ($Fm{'mode'} eq 'use_after') { play_form() } elsif ($Fm{'mode'} eq 'stell_before') { action_form() } elsif ($Fm{'mode'} eq 'stell_after') { play_form() } elsif ($Fm{'mode'} eq 'stell_comp') { play_form() } elsif ($Fm{'mode'} eq 'judge_before') { action_form() } elsif ($Fm{'mode'} eq 'judge_after') { play_form() } elsif ($Fm{'mode'} eq 'trade_before') { action_form() } elsif ($Fm{'mode'} eq 'trade_after') { contact_form() } elsif ($Fm{'mode'} eq 'sell_before') { action_form() } elsif ($Fm{'mode'} eq 'sell_after') { contact_form() } elsif ($Fm{'mode'} eq 'buy_before') { action_form() } elsif ($Fm{'mode'} eq 'buy_after') { contact_form() } elsif ($Fm{'mode'} eq 'fee_before') { play_form() } elsif ($Fm{'mode'} eq 'fee_after') { play_form() } elsif ($Fm{'mode'} eq 'cr') { contact_form() } elsif ($Fm{'mode'} eq 'rv') { contact_form() } elsif ($Fm{'mode'} eq 'com_before') { play_form() } elsif ($Fm{'mode'} eq 'com_after') { play_form() } elsif ($Fm{'mode'} eq 'note_before') { play_form() } elsif ($Fm{'mode'} eq 'note_after') { play_form() } elsif ($Fm{'mode'} eq 'poem_before') { play_form() } elsif ($Fm{'mode'} eq 'poem_after') { play_form() } elsif ($Fm{'mode'} eq 'name_before') { play_form() } elsif ($Fm{'mode'} eq 'name_after') { play_form() } elsif ($Fm{'mode'} eq 'words_before') { contact_form() } elsif ($Fm{'mode'} eq 'words_after') { contact_form() } elsif ($Fm{'mode'} eq 'goodbye') { play_form() } elsif ($Fm{'mode'} eq 'list') { player_list() } elsif ($Fm{'mode'} eq 'sale') { sale_order() } elsif ($Fm{'mode'} eq 'my_record') { my_record() } elsif ($Fm{'mode'} eq 'reward') { play_form() } elsif ($Fm{'mode'} eq 'fight') { contact_form() } elsif ($Fm{'mode'} eq 'del_before') { play_form() } elsif ($Fm{'mode'} eq 'del_after') { main_form() } elsif ($Fm{'mode'} eq 'back_up') { play_form() } elsif ($Fm{'mode'} eq 'levy') { levy() } lock_end(); footer(); exit; ### if, if, if, ... を if, elsif, ... に変更 ### list_order() は player_list() 内で行うようにします ### action_form() はデフォルトでは不要なので ### play_form() と contact_form() に移動します ### lock_start() に合わせて unlock -> lock_end に変更 ### 別にいいかなぁと思ったんですが、とことん厳格にということで ### if, elsif, else で条件分岐をグループ化しました ### これにより余計な if は実行されません(もしかしたらそのままでも最適化されてるかも？) ### ;;# ### ここからはサブルーチンをstrictに改造していきます ### ### まずは decode(), lock_start(), lock_end(), error() から ;;# our (%Fg); ### %Fg を宣言します。use strict を行っているので使う変数はあらかじめ宣言が必要でしたね ### %Fg にはサブルーチンをまたぐフラグ(条件分岐のための変数)を代入していきます ### あんまりスマートではない気がしますがこれが一番単純明快な解法だと思います ### ;;# # Sub Decode # sub decode { ;;# my ($buffer, @pairs); ### $buffer, @pairs を宣言 ### use strict が有効になっているときは ### 変数の使用を宣言しなければエラーになります。覚えましたか？ ### my はスコープ内でのみ有効な変数を宣言します ### スコープを抜けたとき、宣言された変数はメモリから削除されます ### ### スコープ、これは my, local, our の挙動を理解するうえで非常に重要な概念です ### スコープとは変数の有効範囲のことで、変数は有効範囲内でのみ使用できます ### …なんにも情報の増えない説明ですね ### ### SOS2を例に出すと、$cgiurl や $id,$nm,$ps などは ### どんな場所・どんなサブルーチンの中でも中身を見ることが出来ますよね ### こういったプログラムのどんな場所からでも中身を見る(これを参照といいます)ことが出来る変数を ### グローバル変数(大域変数)と呼びます。our の解説でも出てきました ### グローバル変数のスコープは全域、プログラム内部の全てです ### ### グローバル変数は便利な反面、どこからでも変更できる性質から ### その内容を把握することが難しく、グローバル変数に絡んで依存関係 ### (ある変数の値によって別の変数の内容が変わったりプログラムの動作が変わったりすること) ### …が生まれると、プログラムは複雑化が進み、問題が発生してもプログラム全体を把握しなければ ### 原因が特定出来ないなど煩わしい状況の原因になりやすいです ### ### いつでもどこからでも呼び出せる状況が必要であるならばかまいませんが ### そうでない、例えば $price (アイテムの値段)などは金額の計算や表示が終わったら必要ないものです ### $price という変数名は何度も使うのにその中身は使い捨てです ### 次に使う時に思いがけない数値が入っていたりすると、予想しない動作の原因になります ### 箱も中身も使いすての場合、変数を開放しないのはメモリの無駄でもあります ### プログラムが開始して数行の間しか使わないような変数が ### いつまでもメモリを占有してるのはナンセンスですよね ### ### $price のように短い期間しか使用しないような変数には ### 上記のような問題を回避するためにも有効期限のようなものを用意しておきます ### ―このサブルーチンの処理の間だけ変数を使って、処理が終わったら削除します、みたいに― ### クーポンでいう「8/1-8/31の期間のみ有効」の、期間に相当するのがスコープです ### 有効期限によってプログラムの一部でしか利用出来ない変数のことをローカル変数(局所変数)と呼び ### 変数をローカル変数にすることを局所化といいます ### ### ではそのスコープとはどうやって決まるのか ### Perlではブロックによってスコープの範囲が決定され、スコープはブロックの内部に限定されます ### ### ブロック、はスコープに比べればずっと簡単です ### { } 中括弧でくくられた部分をブロックと呼びます ### ### if (hoge < fuga) { this is block } ### foreach (0 .. 9) { this is block } ### map { this is blo(ry } @argments; ### sub routine { this is(ry } ### do { this(ry }; ### { th(ry }; ### ### 上記の中括弧全てが、ブロックです ### ブロックの中で宣言された変数は、ブロックの中でしか参照できません ### 中括弧を抜けたその瞬間に開放され、消えてなくなります ### ### ### さて、用語解説が長くなりましたが my ($buffer, @pairs) です ### $buffer, @pairs は my によってローカル変数(局所変数)として宣言されました ### これにより $buffer, @pairs のスコープ(有効範囲)は宣言された行から ### sub decode のブロックが終了するまでとなりました ### sub decode の処理が終了すれば $buffer, @pairs は ### メモリ上からもキレイさっぱり消え去って未定義の状態に戻ります ### 以降どこかで見かけてもそれは他人の空似です。彼らはもう二度と帰ってきません ### ### ;;# if ($ENV{'REQUEST_METHOD'} eq "POST") { ;;# ;;# $post = 1; $Fg{post} = 1; ### $postはフラグに使う変数なので%Fgに格納しておきます ;;# read(STDIN, $buffer, $ENV{'CONTENT_LENGTH'}); @pairs = split(/&/, $buffer); } else { @pairs = split(/&/, $ENV{'QUERY_STRING'}); } ;;# ;;# foreach $pair (@pairs) { ;;# ($name, $value) = split(/=/, $pair); foreach my $pair (@pairs) { my ($name, $value) = split(/=/, $pair); ### $pair, $name, $value を定義 ### これらのスコープは foreach のブロック内で、ループのたび初期化されます ### ブロックの外側に $name や $value があったとしても、それらとは別物として扱われます ;;# $value =~ tr/+/ /; ;;# ;;# $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg; $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("H2", $1)/eg; ### たぶんこの変換方法では最も高速な記述です ;;# ;;# ;;# &jcode'convert(*value,'sjis'); jcode::convert(\$value,'sjis'); ### 記法をPerl5風に。型グロブではなくリファレンスを渡す ### リファレンスについては後述 ;;# $value =~ s//>/g; $value =~ s/"/"/g; $value =~ s/\,/，/g; $value =~ s/△/▲/g; ;;# ;;# $value =~ s/\r\n/
/g; ;;# $value =~ s/\r/
/g; $value =~ s/\r\n?/
/g; ### ふたつをひとつに ;;# $value =~ s/\n/
/g; $Fm{$name} = $value; ### 本当なら $name もデコードしたほうがいいんでしょうけど、$name に英字以外使わないし… } } ### sub decode は以上です。続いて lock_start, lock_end # Sub Lock Start sub lock_start { return if !$In{lockkey}; ### 設定はすべて %In に収まっているのでそのように ### 以降設定に関しては特に注釈は入れていきません ;;# ;;# local($flag) = 10; my $flag = 10; ### local から my へ ### my のほうがよりスコープが狭いので my を使います。宣言はとりあえず my で ### local や our は動作がちょっと特殊なので、どうしても必要な場面以外では使用しません ### my と local、この二つはローカル変数の宣言である点は同じなのですが、スコープの性質が違います ### local で宣言するとダイナミックスコープという実行時のブロックで有効範囲が決まる形式が使用され ### my で宣言するとレキシカルスコープというソース上のブロックで有効範囲が決まる形式が使用されます ### 難しいですね…。とりあえず、以下の「二つの明確な違い」だけ覚えていればOKです ### ### 二つの明確な違い ### local はブロック内で呼び出されたサブルーチンもスコープの範囲内となる ### my はブロック内で呼び出されたサブルーチンはスコープの範囲外となる ### ### sub print_name { ### print "私の名前は $name です。"; ### } ### ### { ### local $name = 'ローカルバリアブル'; ### print_name(); # 「私の名前は ローカルバリアブル です。」 ### # $name のスコープの中にあるサブルーチンから $name を参照できる！ ### }; ### ### { ### my $name = 'ローカルバリアブル'; ### print_name(); # 「私の名前は です。」 ### # $name は sub print_name では参照できない！ ### }; ### ### これでとりあえず my, local, our の3つの宣言が出てきました ### local は嘘でもないけど本当のことでもないこと書いてるので ### もうちょっと説明が必要な気がしますが、使う分には上記の説明でOKかなぁ ### もっと詳しく知りたい方は "perl my local our" でググってね ### ;;# ;;# ;;# if ($lockkey == 1) { ;;# rmdir($lockfile) if (time - (stat($lockfile))[9] > 60); ;;# while (!mkdir($lockfile,0755)) { ;;# --$flag or &error('現在、サーバが混み合っています',1); ;;# sleep(1); ;;# } ;;# } ;;# elsif ($lockkey == 2) { ;;# unlink($lockfile) if (time - (stat($lockfile))[9] > 60); ;;# while (!symlink(".",$lockfile)) { ;;# --$flag or &error('現在、サーバが混み合っています',1); ;;# sleep(1); ;;# } ;;# } if ($In{lockkey} == 1) { # ロックファイル名+time秒にリネーム # 成功すればリターン。失敗すればスリープ。$flag回チャレンジ # $Fg{lockname}にはリネーム後の名前。sub lock_endで使う while ($flag-- > 0) { return if rename $In{lockfile}, $Fg{lockname} = $In{lockfile} . time; sleep 1; } opendir LOCKDIR, '.' || error("ロックファイルが見つかりません"); my @files = readdir LOCKDIR; closedir LOCKDIR; # ロックファイルを探す # 見つかった場合、名前の末尾の秒数から60秒経過していればリネームしてリターン # 見つからない、あるいは名前の末尾の秒数から60秒経過していなければ error() へ foreach my $file (@files) { if ($file =~ /^$In{lockfile}(\d+)/) { return if time - $1 > 60 && rename $file, $Fg{lockname} = $In{lockfile} . time; last; } } # Busy! error('現在、サーバが混み合っています',1); } ### せっかくなのでプラットフォームに依存しないrenameを使った ### 堅牢なファイルロックを用意してみました ### ロックのために sos.cgi と同じフォルダに sos.lock ファイルが必要です ;;# } # Sub Lock End # sub lock_end { # ロックファイルの名前を戻すことでロックを解除 rename $Fg{lockname}, $In{lockfile}; } ### 最後に error()。大したことはしません ### # Sub Error # sub error { ;;# ;;# $_[1] || &unlock; ;;# if (!$headflag) { &header } $_[1] || unlock(); if (!$Fg{headflag}) { header() } ### &を取って()を。以降サブルーチン呼び出しについても特に注釈は入れません ### $headflag を %Fg に。以降フラグについても特に注釈は入れません ### ;;# print qq|
\n|; print qq|
\n|; print qq|$_[0]\n|; print qq|
\n|; print qq|
\n|; footer(); exit; } ### 続いて表示関連をいじっていきたいと思いますのでよろしくお願いします ### # Sub Main Form # sub main_form { del_after() if $Fm{'mode'} eq 'del_after'; header(); table_top(); msg(); saga(); table_bottom(); } # Sub Enter Form # sub enter_form { header(); if (!$In{def_ne} && $Fm{'mode'} eq 'new_game') { error("新規登録受付停止中") } table_top(); new_game() if $Fm{'mode'} eq 'new_game'; con_game() if $Fm{'mode'} eq 'con_game'; table_bottom(); } # Sub Play Form # sub play_form { find_item() if $Fm{'mode'} eq 'find_item'; dump_after() if $Fm{'mode'} eq 'dump_after'; goods_after() if $Fm{'mode'} eq 'goods_after'; use_after() if $Fm{'mode'} eq 'use_after'; stell_after() if $Fm{'mode'} eq 'stell_after'; stell_comp() if $Fm{'mode'} eq 'stell_comp'; fee_after() if $Fm{'mode'} eq 'fee_after'; com_after() if $Fm{'mode'} eq 'com_after'; note_after() if $Fm{'mode'} eq 'note_after'; poem_after() if $Fm{'mode'} eq 'poem_after'; judge_after() if $Fm{'mode'} eq 'judge_after'; name_after() if $Fm{'mode'} eq 'name_after'; reward() if $Fm{'mode'} eq 'reward'; back_up() if $Fm{'mode'} eq 'back_up'; header(); table_top(); fee_before() if $Fm{'mode'} eq 'fee_before'; com_before() if $Fm{'mode'} eq 'com_before'; note_before() if $Fm{'mode'} eq 'note_before'; poem_before() if $Fm{'mode'} eq 'poem_before'; del_before() if $Fm{'mode'} eq 'del_before'; dump_before() if $Fm{'mode'} eq 'dump_before'; name_before() if $Fm{'mode'} eq 'name_before'; ;;# ### action_form を解体 goods_before if $Fm{'mode'} eq 'goods_before'; use_before if $Fm{'mode'} eq 'use_before'; stell_before if $Fm{'mode'} eq 'stell_before'; judge_before if $Fm{'mode'} eq 'judge_before'; ;;# msg(); normal_action(); player_data(); table_bottom(); } # Sub Contact Form # sub contact_form { contact_check() if $Fm{'mode'} eq 'find_partner'; trade_after() if $Fm{'mode'} eq 'trade_after'; sell_after() if $Fm{'mode'} eq 'sell_after'; buy_after() if $Fm{'mode'} eq 'buy_after'; words_after() if $Fm{'mode'} eq 'words_after'; cure_revive() if $Fm{'mode'} eq 'cr'; cure_revive() if $Fm{'mode'} eq 'rv'; header(); table_top(); words_before() if $Fm{'mode'} eq 'words_before'; fight() if $Fm{'mode'} eq 'fight'; ;;# ### action_form を解体 trade_before if $Fm{'mode'} eq 'trade_before'; sell_before if $Fm{'mode'} eq 'sell_before'; buy_before if $Fm{'mode'} eq 'buy_before'; ;;# msg(); contact_action() if !$notfound; normal_action() if $notfound; player_data(); table_bottom(); } ;;# ;;## Sub Action Form # ;;#sub action_form { ;;# header; ;;# table_top; ;;# goods_before if $Fm{'mode'} eq 'goods_before'; ;;# use_before if $Fm{'mode'} eq 'use_before'; ;;# stell_before if $Fm{'mode'} eq 'stell_before'; ;;# trade_before if $Fm{'mode'} eq 'trade_before'; ;;# sell_before if $Fm{'mode'} eq 'sell_before'; ;;# buy_before if $Fm{'mode'} eq 'buy_before'; ;;# judge_before if $Fm{'mode'} eq 'judge_before'; ;;# msg; ;;# if ($Fm{'mode'} =~ /(trade|sell|buy)/) { &contact_action } else { &normal_action } ;;# player_data; ;;# table_bottom; ;;#} ;;# ### さよなら action_form ### # Sub Header # sub header { ;;# ;;# print qq|Content-type: text/html\n\n|; print qq|Content-type: text/html; charset=Shift_JIS\n\n|; ### Shift_JIS 追加してみました ;;# print qq|\n\n|; print qq|\n|; print qq|$htitle\n|; style(); print qq|\n$In{body}\n|; $In{headflag} = 1; } # Sub Footer # sub footer { # 著作権表示。絶対に消さないで下さい！ print qq|
Script Of Saga II Ver $ver
\n|; print qq|■ MISSING LINK ■|; print qq|□ SOS2WIKI R □|; print qq|
\n

- Rental Orbit Space -
\n\n|; } # Sub Style # sub style { print qq|\n|; } # Sub Table Top # sub table_top { print qq|
\n|; print qq|\n|; } # Sub Table Bottom # sub table_bottom { print qq|\n
\n|; menu(); print qq|
\n|; } # Sub Menu # sub menu { ### & -> & に変更しました ### HTMLのルールで、& を表示させたいときは実体参照を使わなくてはいけません ### print qq||; print qq|New Game｜|; print qq|Continue｜|; print qq|Return|; ;;# ;;# print qq|｜My Record| if $In{def_mr} && $id; print qq|｜My Record| if $In{def_mr} && $Fm{'id'}; ### 主に解説の順序の都合により $id,$ps を $Fm{'id'},$Fm{'ps'} に ### ;;# print qq|
PLayer List ：( |; print qq|ID｜|; print qq|Name｜|; print qq|Job｜|; print qq|Money｜|; print qq|Bounty｜|; print qq|Rate｜|; print qq|Sale )|; print qq|\n|; } ### ここまでは変数の名前がちょっと変わったくらいでした。特に解説もなし… ### ;;# our (@msg); ### @msg を宣言します。変数を使うときは事前に使うことを宣言する。忘れてませんでしたか？ ### どのブロックにも囲まれていないので @msg はグローバル変数です ### ### 以降変数の宣言については特に注釈を入れていきません ;;# # Sub Msg # sub msg { ### foreach の $line を my で宣言しています。変数は宣言してから使うんですよ(しつこい) ### return if !@msg; print qq|\n|; foreach my $line (@msg) { print qq|$line
\n| } print qq|\n|; } ### ここからはファイルのオープンに関係するサブルーチンを改造していきます ### がんばって解説読んでね。僕もがんばって書くから… ### ### まずは sub opendat, sub writedat. ここは変更はほぼありません # Sub Open dat # sub opendat { open(IN,"$_[0]") || error("Can't open $_[0]"); local(@lines) = ; close(IN); return @lines; } # Sub Write dat # sub writedat { open(OUT,">$_[0]") || error("Write Error : $_[0]"); shift(@_); print OUT @_; close(OUT); } ### 続いて sub opensosdat, sub writesosdat. ここから処理の変更が入っていきます # Sub Open sos dat # sub opensosdat { ;;# ;;# open(IN,"$sosdat") || &error("Can't open $sosdat"); ;;# $line = ; ;;# close(IN); ;;# ($poem,$poet,$note,$aven,$intl,$info,$king) = split(/<>/,$line); my $line = opendat($In{sosdat}); return split(/<>/,$line); ;;# ### 読み込み処理を sub opendat を利用するように変更しました ### このようにごくごく基本的な操作はすでにあるサブルーチンを利用する ### あるいは新たにサブルーチンとして分離し、再利用すると ### プログラムの処理が理解しやすくなることがあります ### ### ここからの話がとても重要なのですが、ポエムや日誌の変数がなくなったのが分かりますね ### これは、いままでグローバル変数に入れていたポエムや日誌を ### ### my %story = opensosdat(); ### ### こんなふうに、ハッシュ(連想配列)に入れて使おう、ということを考えて変更しています ### さらには、ファイルの内容が壊れてしまわないようにする工夫も追加されています ### 具体的にどういうことなのかは、次の sub writesosdat で解説します } # Sub Write sos dat # sub writesosdat { ;;# ;;# open(OUT,">$sosdat") || &error("Write Error : $sosdat"); ;;# print OUT "$poem<>$poet<>$note<>$aven<>$intl<>$info<>$king"; ;;# close(OUT); my %hash = @_; my @hash = map { ($_, $hash{$_}) } qw(poem poet note aven intl info king); writedat($In{sosdat}, join('<>', @hash, "\n")); ;;# ### サブルーチンが引数を受け取るようになり ### 書き込み処理も sub writedat にお任せするように変更されています ### いままでは、 ### ### # 今までの書き方 ### &opensosdat; ### $poem = 'あたらしい詩を書き上げたぞ！'; ### &writesosdat; ### ### のように使用していたものが ### ### # 新しい書き方 ### my %story = opensosdat(); ### $story{poem} = 'あたらしい詩を書き上げたぞ！'; ### writesosdat(%story); ### ### のように使用するようになりました ### ### ファイルの内容も変更されています ### 「詩<>詩を書いた人<>探検日誌<>日誌を書いた人<>...」のように ### データを<>で区切って、並んでいる順番でどんなデータなのかを判断していたものが ### 「poem<>詩<>poet<>詩を書いた人<>...」のように ### 情報の名前(poem)と内容(詩)2つで1セットという書式になりました ### これにより、<>でデータを区切るだけでファイルの内容を ### 連想配列として受け取ることが出来るようになりました ### sos.datをテキストエディタで開いた時もどれが何のデータかというのがわかりやすくなりました ### ### なぜこのような修正を行ったのでしょうか――― ### 今までの書き方だと、ポエムや探検日誌を正しい変数に代入できたのか ### そもそもポエムや日誌をちゃんと読み込めたのか、がよくわからず ### うっかり sub opensosdat を実行せずに sub writesosdat を呼び出してしまうと ### sos.datファイルの情報が失われてしまいます。改造をしてると実によくやります ### ### 新しい書き方では、opensosdatから値を受け取って、%story連想配列を宣言していなければ ### writesosdatを実行するときに、use strictの効果で必ず500エラーになります ### つまり、opensosdatを呼ばずにwritesosdatを実行できなくなったのですね ### 詩や日誌を読み込む前に書き込めなくなったので、sos.datの情報が失われません ### さらに、連想配列ですから、他の変数と名前が被らない=意図しない値の上書きが ### 発生しないので、opensosdatからwritesosdatまでの間に長い処理があっても安心です ### ### このように、グローバル変数を使わなくすることで ### データを消してしまうというバグを入れる可能性が減りました ### 書き方を工夫することで安全なプログラムを書くことが出来るというひとつの例ですね } # Sub Open sos dat # sub opensosdat { open(IN,"$sosdat") || &error("Can't open $sosdat"); $line = ; close(IN); ($poem,$poet,$note,$aven,$intl,$info,$king) = split(/<>/,$line); } # Sub Write sos dat # sub writesosdat { open(OUT,">$sosdat") || &error("Write Error : $sosdat"); print OUT "$poem<>$poet<>$note<>$aven<>$intl<>$info<>$king"; close(OUT); } # Sub Get User # sub get_user { return if $getuserflag; open(IN,"$usrdir$_[0]\.dat") || &error("ID $_[0]は存在しません"); @_ = ; close(IN); if (!@_) { &error("読みこみエラー") } ($id,$nm,$ps,$jb,$ig,$sp,$bp,$bn,$ak,$dd,$hp,$xp,$ab,$db, $av,$wn,$lz,$dt,$mn,$bg,$xi,$tm,$lf,$fe,$cm,$is,$ht,$fg,$rw,$kl) = split(/<>/,$_[0]); &error("パスワードが違います") if $Fm{'ps'} ne $ps && $Fm{'ps'} ne $admpas && $Fm{'mode'} ne 'make_con'; $userline = shift(@_); $getuserflag = 1; return @_; } # Sub Get Partner # sub get_partner { return if $getpartnerflag; open(IN,"$usrdir$_[0]\.dat") || &error("ID $_[0]は存在しません"); @_ = ; close(IN); if (!@_) { &error("読みこみエラー") } ($pid,$pnm,$pps,$pjb,$pig,$psp,$pbp,$pbn,$pak,$pdd,$php,$pxp,$pab,$pdb, $pav,$pwn,$plz,$pdt,$pmn,$pbg,$pxi,$ptm,$plf,$pfe,$pcm,$pis,$pht,$pfg,$prw,$pkl) = split(/<>/,$_[0]); shift(@_); $getpartnerflag = 1; return @_; } # Sub User Out # sub userout { $tm = time; $line = join('<>',$id,$nm,$ps,$jb,$ig,$sp,$bp,$bn,$ak,$dd,$hp,$xp,$ab,$db, $av,$wn,$lz,$dt,$mn,$bg,$xi,$tm,$lf,$fe,$cm,$is,$ht,$fg,$rw,$kl,"\n"); unshift (@rcdlines,$line); &writedat("$usrdir$id\.dat",@rcdlines); } # Sub Partner Out # sub partnerout { $pline = join('<>',$pid,$pnm,$pps,$pjb,$pig,$psp,$pbp,$pbn,$pak,$pdd,$php,$pxp,$pab,$pdb, $pav,$pwn,$plz,$pdt,$pmn,$pbg,$pxi,$ptm,$plf,$pfe,$pcm,$pis,$pht,$pfg,$prw,$pkl,"\n"); unshift (@prclines,$pline); &writedat("$usrdir$pid\.dat",@prclines); } # Sub Get User File # sub get_file { return if $getfileflag; opendir(DIR,"$usrdir") || &error("ユーザデータ読みこみエラー"); @usrfile = sort grep /\.dat/,readdir(DIR); closedir(DIR); $getfileflag = 1; } # Sub List In # sub list_in { return if $listinflag; foreach $no (0 .. $#usrfile) { open(IN,"$usrdir$usrfile[$no]") || &error("Can't open $usrfile[$no]"); $line = ; close(IN); push(@lstlines,$line); } $listinflag = 1; } # Sub Saga # sub saga { &opensosdat; &list_order; print qq|

\n|; print qq|この物語は$hernam$heroと$ricnam$rich、\n|; print qq|その他多くの勇者、商人達の幾千年にもわたる壮大な歴史の叙事詩である。
\n|; # 英雄、大富豪の紹介 if ($hero || $rich) { print qq|\n|; print qq|\n
\n|; print qq|
\n| if $himg; print qq|$hernam$hero| if $hero; print qq|		\n|; print qq|
\n| if $rimg; print qq|$ricnam$rich| if $rich; print qq|
\n|; } # 吟遊詩人の詩 if ($poem) { print qq|
$poem
$poenam：$poet
\n| } # 探検日誌 if ($note) { print qq|
$note
$avenam$avenの日誌より
\n| } print qq|\n|; $info =~ s/(https?|ftp|gopher|telnet|whois|news)\:([\w|\:\!\#\$\%\=\&\-\^\`\\\|\@\~\[\{\]\}\;\+\*\,\.\?\/]*)/CLICK<\/a>/ig; print qq|$intl

\n$info

\n|; $totalplayer = @odrlines; if (!$totalplayer) { $totalplayer = 0 } if (!$playernow) { $playernow = 0 } print qq|
プレイヤー総数：$totalplayer
\n|; print qq|現在のプレイ人数：$playernow
\n|; } # Sub New Game # sub new_game { &form('start'); print qq||; print qq|\n|; print qq|\n|; print qq|\n|; print qq|\n|; print qq|\n|; print qq|\n|; @joblines = &opendat($jobdat); print qq|\n|; print qq|
新規登録
名前
パスワード
確認のためもう一度
職業
\n|; &OKbuttoninform('','make_new'); print qq|
\n|; &form('end'); } # Sub Continue Game # sub con_game { &form('start'); print qq||; &cookie_get; print qq|\n|; print qq|\n|; print qq|\n|; print qq|\n|; print qq|\n|; print qq|
コンティニュー
名前
パスワード
4桁のID
\n|; &OKbuttoninform('','make_con'); print qq|
\n|; &form('end'); } # Sub Make New # sub make_new { if (!$def_ne) { &error("新規登録受付停止中") } if ($Fm{'name'} eq "") { &error("名前を入力してください") } if ($Fm{'pass'} eq "") { &error("パスワードを入力してください") } if ($Fm{'pass'} ne $Fm{'pass2'}) { &error("2つのパスワードが一致しません") } if ($def_pa && $Fm{'job'} eq $def_pb && $Fm{'pass'} !~ /$def_pp/) { &error("質屋は管理者以外使用することができません"); } &get_file; &list_in; &get_host; &find_user; &error("その名前は既に使用されています") if $xpoint ne 'del'; &error("同一のホストが既に存在しています") if $zpoint; $Fm{'ps'} = $Fm{'pass'}; @joblines = &opendat($jobdat); foreach $line (@joblines) { ($jbn,$jig,$jsp,$jhp,$jxi,$jak,$jdd,$jmn) = split(/<>/,$line); if ($jbn eq $Fm{'job'}) { last } } $id = "0000"; while (-e "$usrdir$id\.dat") { $id++; $id = sprintf("%04d",$id) } $line = join('<>',$id,$Fm{'name'},$Fm{'pass'},$jbn,$jig,$jsp,'','',$jak,$jdd,$jhp,$jhp,0,0,'alive',0,0,0,$jmn,'',$jxi,time,'','','???','',$host,'',0,0,"\n"); &writedat("$usrdir$id\.dat",$line); chmod(0666,"$usrdir$id\.dat"); $Fm{'id'} = $id; &cookie_set; &play_form; } # Sub Make Continue # sub make_con { if ($Fm{'name'} eq "" && $Fm{'pass'} ne $admpas) { &error("名前を入力してください"); } if ($Fm{'pass'} eq "") { &error("パスワードを入力してください"); } if ($Fm{'id'} eq "") { &error("4桁のIDを入力してください"); } @rcdlines = &get_user("$Fm{'id'}"); &error("名前がIDと一致しません") if $nm ne $Fm{'name'} && $Fm{'pass'} ne $admpas; &error("パスワードが間違っています") if $ps ne $Fm{'pass'} && $Fm{'pass'} ne $admpas; $Fm{'ps'} = $Fm{'pass'}; $now = int((time - $tm) / 3600); if ($av eq 'dead') { $bp += $now; if ($bp >= $def_ha) { $av = 'alive'; $hp = &hpcheck($hp,$xp,$bp - $def_ha); $bp = '' } } else { ($hp) = &hprecover($hp,$xp,$sp,$av,$tm,$fg) } $fg = ''; &userout; &cookie_set; &play_form; } # Sub Player's Data # sub player_data { @rcdlines = &get_user("$Fm{'id'}"); print qq|\n|; print qq|

\n| if $ttlapd; print qq|\n|; print qq|\n|; print qq|

$nm		ID：$id
\n|; print qq|職業：$jb
\n|; print qq|状態：$av
\n|; print qq|攻撃力：$ak|; print qq| + $ab| if $ab; print qq|
\n|; print qq|防御力：$dd|; print qq| + $db| if $db; print qq|
\n|; print qq|一時使用：|; if ($bp) { print qq|$bn
| } else { print qq|なし
| } print qq|体力：$hp/MAX$xp
\n|; print qq|
所持金：$mn\G
|; ($cr,$rv) = split(/△/,$fe); print qq|解毒費：$cr
| if $cr; print qq|蘇生費：$rv
| if $rv; print qq|		アイテム/MAX$xi

\n|; &splititem('i'); foreach $item (@items) { ($item,$sts,$price) = split(/△/,$item); if ($sts =~ /Q[swat]/) { print qq|【$item】
\n| } elsif ($price > 0) { print qq|$item⇒$price\G
\n| } else { print qq|$item
\n| } } print qq|なし
\n| if !$bg; $cm_ = &decoration($cm); print qq|

\nコメント：$cm_\n|; print qq|
\n|; print qq|\n|; &OKbuttoninform('n','my_record'); print qq|
My Record
\n|; &form('end'); print qq|\n|; } # Sub Partner's Data # sub partner_data { print qq|\n|; print qq|\n|; print qq|

$pnm		ID：$pid
\n|; print qq|職業：$pjb
\n|; $av_clr = $dedclr if $pav eq 'dead'; $av_clr = $pznclr if $pav eq 'poison'; print qq|状態：$pav
\n|; print qq|攻撃力：$pak|; print qq| + $pab| if $pab; print qq|
\n|; print qq|防御力：$pdd|; print qq| + $pdb| if $pdb; print qq|
\n|; if ($sp =~ /Wo/) { print qq|一時使用：|; if ($pbp) { print qq|$pbn
| } else { print qq|なし
| } } if ($sp =~ /Sl/) { ($php) = &hprecover($php,$pxp,$psp,$pav,$ptm,$pfg); print qq|体力：$php
|; } print qq|
所持金：$pmn\G
|; ($cr,$rv) = split(/△/,$pfe); print qq|解毒費：$cr
| if $cr; print qq|蘇生費：$rv
| if $rv; &splititem('I'); print qq|		アイテム
\n|; if ($psp =~ /Bf|Bm/) { $max = @pitems; print qq|所持数：$max/$pxi
\n|; } print qq|
\n|; foreach $item (@pitems) { ($item,$sts,$price) = split(/△/,$item); if ($sts =~ /Q[swat]/) { print qq|【$item】
\n| } elsif ($price > 0) { print qq|$item⇒$price\G
\n| } else { print qq|$item
\n| } } print qq|なし
\n| if !$pbg; $pcm_ = &decoration($pcm); print qq|

\nコメント：$pcm_\n|; } # Sub Normal Action # sub normal_action { &get_file; &list_in; print qq||; &form('start'); print qq||; &input('radio','mode','find_partner',' checked',"他のプレイヤーを探す
\n"); &input('radio','mode','note_before','',"手紙を書く
\n"); print qq|
ID：|; &input('text','pd2','',' size=4',''); print qq|
\n|; &OKbuttoninform('n'); &form('end'); &form('start'); &input('radio','mode','find_item',' checked',"アイテム探索
\n") if $mysp !~ /Nf/; &input('radio','mode','use_before','',"アイテムの脱着・使用
\n") if $mysp =~ /Tf/; &input('radio','mode','use_before','',"アイテムの使用
\n") if $mysp =~ /Tv/; &input('radio','mode','dump_before','',"アイテムを捨てる
\n"); &input('radio','mode','stell_before','',"ステラツィオの設定
\n") if $mysp !~ /Nf/; &input('radio','mode','poem_before','',"詩・日誌を書く
\n") if $mysp =~ /Wp/ || $mysp =~ /An/; &input('radio','mode','goods_before','',"商品の設定
\n") if $mysp =~ /Tv/ && $mysp !~ /Nf/; &input('radio','mode','goods_before',' checked',"商品の設定
\n") if $mysp =~ /Nf/; &input('radio','mode','fee_before','',"治療費の設定
\n") if $mysp =~ /Ad|Rv/; &input('radio','mode','com_before','',"コメント文の変更
\n"); &input('radio','mode','judge_before','',"アイテム鑑定
\n") if $mysp =~ /Eo/; &input('radio','mode','name_before','',"銘入り品の名前を変更する
\n") if $mybp =~ /Na/; if ($mysp !~ /X/) { &input('radio','mode','reward','','賞金首に金をかける　ID：'); &input('text','pd','',' size=4','　金額：'); &input('text','price','',' size=5','

'); } &input('radio','mode','norm_save','',"町で保存\n"); &input('radio','mode','hide_save','',"人里離れて保存
\n"); &input('radio','mode','levy','',"税の徴収をして保存（注意）
\n") if $mysp =~ /Lv/; &input('radio','mode','del_before','',"キャラを削除\n"); &input('radio','mode','back_up','',"バックアップ\n"); &OKbuttoninform('n'); print qq||; &form('end'); } # Sub Contact Action # sub contact_action { @rcdlines = &get_user("$Fm{'id'}"); @prclines = &get_partner("$Fm{'pd'}"); if ($psp =~ /(V[a-z])/) { $vflag = $1; &splititem('i'); foreach (@items) { $right = 1 if (split(/△/))[1] =~ /$vflag/; } if (!$right) { &error("$pnmに会うためにはあるアイテムが必要です"); } } print qq|\n|; &partner_data; &form('start'); &input('radio','mode','words_before',' checked',"メッセージを残す
\n"); if (($sp =~ /Tf/ && $psp =~ /Tv/ && $psp !~ /Pb/) || ($sp =~ /Tv/ && $psp =~ /(Pb|Tv)/)) { &input('radio','mode','buy_before','',"買う
\n") } &input('radio','mode','sell_before','',"売る
\n") if ($psp =~ /Bf/ && $sp !~ /Pb/) || ($psp =~ /Bm/ && $sp !~ /Tf/); &input('radio','mode','rv','',"蘇生してもらう
\n") if $psp =~ /Rv/ && $av eq 'dead'; &input('radio','mode','cr','',"解毒してもらう
\n") if $psp =~ /Ad/ && $av eq 'poison'; &input('radio','mode','fight','',"戦う
\n") if $psp =~ /Tf/ && $sp =~ /Tf/; &input('radio','mode','trade_before','',"ステラツィオのトレード
\n") if $psp !~ /Nf/ && $sp !~ /Nf/; &input('radio','mode','goodbye','',"別れる\n"); &OKbuttoninform('on'); &form('end'); print qq||; } # Sub Contact Check # sub contact_check { if (!$post) { return } if ($Fm{'pd2'}) { $Fm{'pd'} = $Fm{'pd2'} } if ($Fm{'pd2'} eq $Fm{'id'}) { push (@msg,"自分に会うことはできません"); $notfound = 1; return } @rcdlines = &get_user("$Fm{'id'}"); @prclines = &get_partner("$Fm{'pd'}"); $now = (time - $ptm) - ($def_np * 60); if ($psp =~ /(V[a-z])/) { $vflag = $1; &splititem('i'); foreach (@items) { $right = 1 if (split(/△/))[1] =~ /$vflag/; } } if ($vflag && !$right) { push (@msg,"$pnmに会うためにはあるアイテムが必要です"); $notfound = 1; } elsif ($pfg eq 'HS') { srand(time | $$); $def_hd += $def_th if $psp =~ /Hd/; $def_hd -= $def_bh if $prw >= $def_rp && $sp =~ /X/; $rnd = int(rand($def_hd)); if (!$rnd && $hp > 1) { push (@msg,"$pnmを発見することに成功しました"); &partnerout } else { push (@msg,"散々探しましたが、$pnmはどこにもいませんでした"); $notfound = 1; if ($hp > 1) { push (@msg,'疲れの為、体力を消耗しました'); $hp--; &userout } } } elsif ($pfg eq 'NS') { push (@msg,"$pnmが現れた"); &partnerout } elsif ($pfg eq 'SS') { push (@msg,"$pnmはどこにもいませんでした"); $notfound = 1 } elsif ($now > 0) { push (@msg,"$pnmを発見しました"); $pfg = 'NS'; &partnerout } else { push (@msg,"$pnmは現在プレイ中です"); $notfound = 1 } } # Sub Find Item # sub find_item { if (!$post) { return } @rcdlines = &get_user("$Fm{'id'}"); if ($av eq 'dead') { push (@msg,'死んでいます');return } if ($hp <= 1) { push (@msg,'ヒットポイントが足りません');return } &splititem('i'); if (@items >= $xi) { push (@msg,'これ以上は持てません');return } @itemlines = &opendat($itmdat); if (!@itemlines) { &error('アイテムデータ読みこみエラー') } sleep(1); srand(time | $$); $poison = int(rand(100)) + 1; $stellatio = int(rand(100)) + 1; $rnd = int(rand(100)) + 1; # 探索の特殊能力 if ($sp =~ /Ft/) { $rnd -= 2; $rnd = 1 if $rnd < 1 } foreach $item (@itemlines) { ($inm,$idt,$idc) = split(/<>/,$item); if ($rnd <= $idc) { push(@founditems,$item) } } $rnd = int(rand(@founditems)); ($inm,$idt,$idc) = split(/<>/,$founditems[$rnd]); if (!$inm) { push (@msg,'何もみつかりませんでした');return } $hp--; if ($poison <= $def_pd && $av eq 'poison') { $hp--; if ($hp < 1) { $hp = 1 } push (@msg,'毒によるダメージのため体力が1減りました'); } if ($stellatio <= $def_zd) { if ($def_xs && length($is) > $def_xs - 1) { push (@msg,'ステラツィオを発見しましたが、所持オーバーの為捨てました');return } $itsrnd = int(rand(12)); $is .= "$iti[$itsrnd]"; push (@msg," $itn[$itsrnd]のステラツィオを発見しました"); &userout; return; } if ($idt !~ /Gl/) { push(@items,"$inm△$idt"); &joinitem('i') } else { $mn += substr($idt,0,4) } &userout; if ($idt =~ /Li/) { foreach (0 .. $#itemlines) { ($lnm,$ldt,$ldc) = split(/<>/,$itemlines[$_]); if ($inm eq $lnm) { splice (@itemlines,$_,1); last } } &writedat($itmdat,@itemlines); } push (@msg,"$inmをみつけました"); } # Sub Use Before # sub use_before { @rcdlines = &get_user("$Fm{'id'}"); if (!$bg) { push (@msg,'何ももっていません'); return } $fg = 'UB'; &userout; push (@msg,"脱着・使用するアイテムにチェックをいれて$def_okボタンを押してください"); &splititem('i'); &form('start'); print qq||; foreach (0 .. $#items) { ($item,$sts,$price) = split(/△/,$items[$_]); if ($sts =~ /Q[swat]/) { &input('checkbox',"$_",'on',' checked',''); print qq|【$item】 \n| } else { &input('checkbox',"$_",'on','',''); print qq|$item \n| } } &OKbuttoninform('n','use_after'); print qq||; &form('end'); } # Sub Use After # sub use_after { if (!$post) { return } @rcdlines = &get_user("$Fm{'id'}"); return if $fg ne 'UB'; &splititem('i'); $ab = $db = 0; $sp =~ s/Qb//g; $sp =~ s/Qk//g; $sp =~ s/Qx//g; $sp =~ s/Qm//g; foreach (0 .. $#items) { ($item,$sts,$price) = split(/△/,$items[$_]); $iak = substr($sts,4,2); $idd = substr($sts,6,2); if ($sts =~ /Q[swat]/) { $nomsg = 1 } else { $nomsg = 0 } $sts =~ s/Q[swat]//g; if ($Fm{$_}) { if ($sts =~ /(Sw|Kn|Kt|Ax|Gv|Bw|Mi|Wd|Yw)/) { &arm($1,'Qw') } elsif ($sts =~ /(Sh|Ys)/) { &arm($1,'Qs') } elsif ($sts =~ /(Ar|Ya)/) { &arm($1,'Qa') } elsif ($sts =~ /(Jw|Yt)/) { &arm($1,'Qt') } elsif ($sts =~ /Ig/) { &blacksmith } elsif ($sts =~ /Fd/) { &food } elsif ($sts =~ /Rb/) { &umsg('蘇'); $av = 'alive'; $hp = &hpcheck($hp,$xp,$iak); $gn = 1 } elsif ($sts =~ /Bg/) { &umsg('荷'); $xi += $iak; $xi = 1 if $xi < 1; $gn = 1 } elsif ($sts =~ /Ss/) { if ($av eq 'dead') { &umsg('死') } else { &set_item("セーブ時に$itemを使用します") } } elsif ($sts =~ /Ca/) { &umsg('紋') } elsif ($sts =~ /Na/) { if ($av eq 'dead') { &umsg('死') } elsif ($sp =~ /Ws|As|Sc/) { &set_item("銘入り品の名前を変更することができます") } else { &umsg('銘') } } elsif ($sts =~ /Hb/) { if ($av eq 'dead') { &umsg('死') } elsif ($sp =~ /Mf/) { &set_item("$itemを使用します。組合わせる食材を選んでください") } else { &umsg('服'); $av = 'alive'; $hp += $iak; $hp = 1 if $hp < 1; $gn = 1 } } elsif ($sts =~ /Di/ && $sp =~ /Rp/) { &umsg('灰'); $item = "食用$item"; $sts =~ s/Di/Fd/ } elsif ($sts =~ /(Di|Lc|Pi|Oi)/) { if ($av eq 'dead') { &umsg('死') } elsif ($sp =~ /Tf/) { &set_item("$itemを次回の戦闘に使用します") } else { &umsg('不') } } else { &umsg('不') } } if (!$gn) { $newitem = "$item△$sts"; $newitem .= "△$price" if $price; push(@bag,$newitem) } $gn = 0; } @items = @bag; &joinitem(i); $fg = ''; &userout; } # Sub Use Message # sub umsg { %umsg = ( '蘇',"$itemを使い蘇生しました", '荷',"$itemにより所持上限が$iak増えました", '紋',"$itemは使用するものではありません", '死',"死亡中は$itemを使用できません", '服',"$itemを服用しました", '灰',"$itemの灰汁を抜きました", '不',"$jbは$itemを使用できません", '作',"$itemを作成しました", '摂',"$itemを摂取しました", '既',"既に$bnを使用中です", '装',"$itemを装備しました", '両',"$itemを装備するには両手を空ける必要があります", '別',"$itemを装備するには別のアイテムを外す必要があります", '職',"この職業は$itemを装備できません", '失',"$itemの加工に失敗しました", '加',"この職業は$itemを加工できません", '銘',"武具、或いは銀細工を作成できる者しか$itemは使用できません", 'レ',"あなたはまだレアアイテムを装備できません"); push (@msg,$umsg{"$_[0]"}); } # Sub Food # sub food { if ($av eq 'dead') { &umsg('死') } elsif ($bp =~ /Hb/) { $item = $bn . $item; $bp =~ tr/a-zA-Z//d; $iak *= $bp; $iak = 99 if $iak > 99; $iak = -9 if $iak < -9; $sts = sprintf("%04d%02d%02d",0,$iak,0) . "FdWi"; &umsg('作'); $bp = $bn = ''; } else { &umsg('摂'); $hp = &hpcheck($hp,$xp,$iak); $gn = 1 } } # Sub Set Item # sub set_item { # if ($bp) { &umsg('既'); return } # else { $bp = $sts; $bp =~ tr/0-9\-//d; $bp .= int($iak); $bn = $item; $gn = 1; push (@msg,"$_[0]"); # } } # Sub Arm # sub arm { local($a1,$a2) = @_; if ($sts =~ /Li/ && $sp !~ /Li/) { &umsg('レ') } elsif ($sp =~ /$a1/) { if ($sts =~ /Dh/ && $sp !~ /Oh/) { if ($ch !~ /Q[sw]/) { $ab += $iak; $db += $idd; &umsg('装') if !$nomsg; if ($a1 eq 'Bw') { $sp .= 'Qb' } if ($a1 eq 'Kt') { $sp .= 'Qk' } if ($a1 eq 'Ax') { $sp .= 'Qx' } if ($a1 eq 'Sw' && $sts =~ /Li/) { $sp .= 'Qm' } $ch .= 'QwQs'; $sts .= 'QwQs'; } else { &umsg('両') } } elsif ($ch !~ /$a2/) { $ab += $iak; $db += $idd; &umsg('装') if !$nomsg; if ($a1 eq 'Bw') { $sp .= 'Qb' } if ($a1 eq 'Kt') { $sp .= 'Qk' } if ($a1 eq 'Ax') { $sp .= 'Qx' } if ($a1 eq 'Sw' && $sts =~ /Li/) { $sp .= 'Qm' } $ch .= $a2; $sts .= $a2; } else { &umsg('別') } } else { &umsg('職') } } # Sub Blacksmith # sub blacksmith { if ($sp =~ /Ws|As|Sc/) { srand(time | $$); $rnd = int(rand(100)) + 1; if ($sp =~ /Ws/ && $sp =~ /As/ && $sp =~ /Sc/) { $trnd = int(rand(4)) } elsif ($sp =~ /Ws/ && $sp =~ /As/) { $trnd = int(rand(3)) } elsif ($sp =~ /Ws/ && $sp =~ /Sc/) { $trnd = (0,3)[int(rand(2))] } elsif ($sp =~ /As/ && $sp =~ /Sc/) { $trnd = int(rand(3)) + 1 } elsif ($sp =~ /Ws/) { $trnd = int(rand(1)) } elsif ($sp =~ /As/) { $trnd = int(rand(2)) + 1 } elsif ($sp =~ /Sc/) { $trnd = 3 } $rnd = 0 if $sp =~ /Bp/; if ($rnd <= $def_pr) { if ($trnd == 0) { $sts = sprintf("%04d%04d",$def_pc1,$def_bn1); $sts .= 'Yw'; $item = $def_yw; } if ($trnd == 1) { $sts = sprintf("%04d%04d",$def_pc2,$def_bn2); $sts .= 'Ys'; $item = $def_ys; } if ($trnd == 2) { $sts = sprintf("%04d%04d",$def_pc3,$def_bn3); $sts .= 'Ya'; $item = $def_ya; } if ($trnd == 3) { $sts = sprintf("%04d%04d",$def_pc4,$def_bn4); $sts .= 'Yt'; $item = $def_yt; } $item =~ s/○○/$nm/; &umsg('作'); } else { $gn = 1; &umsg('失') } } else { &umsg('加') } } # Sub Dump Before # sub dump_before { @rcdlines = &get_user("$Fm{'id'}"); if (!$bg) { push (@msg,'何ももっていません'); return } $fg = 'DB'; &userout; push (@msg,"捨てるアイテムにチェックを入れ$def_okボタンを押してください"); &splititem('i'); &form('start'); print qq||; foreach (0 .. $#items) { ($item,$sts,$price) = split(/△/,$items[$_]); $pc = int(substr($sts,0,4)); if ($sts =~ /Q[swat]/) { print qq| 装備中：【$item】\n| } else { &input('checkbox',"$_",'on','',''); print qq|$item\n|; print qq| ($pc)\n| if $sp =~ /Fa/ && $sts =~ /Li/; } } &OKbuttoninform('n','dump_after'); print qq||; &form('end'); } # Sub Dump After # sub dump_after { if (!$post) { return } @rcdlines = &get_user("$Fm{'id'}"); return if $fg ne 'DB'; &splititem('i'); foreach (0 .. $#items) { ($item,$sts,$price) = split(/△/,$items[$_]); if ($Fm{"$_"} && $sts !~ /Q[swat]/) { if ($sp =~ /Fa/ && $sts =~ /Li/) { $pc = int(substr($sts,0,4)); $mn += $pc; push (@msg,"国王に$itemを献上しました。$pc\Gの支援金を得ました"); } else { push (@msg,"$itemを捨てました") } } else { push(@newitems,$items[$_]) } } @items = @newitems; &joinitem('i'); $fg = ''; &userout; } # Sub Goods Before # sub goods_before { @rcdlines = &get_user("$Fm{'id'}"); if (!$bg) { push (@msg,'何ももっていません。'); return } $fg='GB'; &userout; push (@msg,"販売するアイテムにチェックを入れ$def_okボタンを押してください"); &splititem('i'); &form('start'); print qq||; foreach (0 .. $#items) { ($item,$sts,$price) = split(/△/,$items[$_]); $pawnpc = int(substr($sts,0,4)); if ($price > 0) { $pc = $price; $ch = ' checked' } else { $pc = 0; $ch = '' } &input('checkbox',"$_",'on',"$ch",''); print qq|$item\n|; &input('text',"T$_","$pc",' size=4',"($pawnpc) "); } &OKbuttoninform('n','goods_after'); print qq||; &form('end'); } # Sub Goods After # sub goods_after { if (!$post) { return } @rcdlines = &get_user("$Fm{'id'}"); return if $fg ne 'GB'; &splititem('i'); @INi = ('Sw','Kn','Kt','Ax','Gv','Wd','Bw','Mi','Sh','Ar','Jw','Na','V','Pi','Oi', 'Fd','Hb','Di','Lc','Ig','Rb','Bg','Ca','Ss','Yw','Ys','Ya','Yt'); @INs = ('Zs','Zk','Zt','Zx','Zg','Zw','Zb','Zm','Zl','Za','Zj','Zq','Yv','Zp','Zo', 'Zf','Zh','Zd','Zc','Zi','Zr','Zn','Zz','Zv','Yx','Yy','Yz','Yj'); foreach $x (0 .. $#items) { ($item,$sts,$price) = split(/△/,$items[$x]); $pc = int(substr($sts,0,4)) + $def_gp; if ($Fm{"$x"} && $Fm{"T$x"} !~ /[^0-9]/ && $Fm{"T$x"} > 0) { if ($sts =~ /Li/ && $sp !~ /Li/ && $sp !~ /Pb/) { push (@msg,"あなたはレアアイテムを売ることができません"); $price = '' } elsif ($def_gp && $Fm{"T$x"} < $pc && $sp !~ /Pb/) { push (@msg,"$itemの最低販売価格は$pc\Gです"); $price = '' } else { foreach $y (0 .. $#INi) { if ($sts =~ /$INi[$y]/) { if ($sp =~ /$INs[$y]/ || $sp =~ /Pb/) { $price = "△" . int($Fm{"T$x"}) } else { push (@msg,"この職業は$itemを売ることができません"); $price = '' } } } } } else { $price = '' } splice(@items,$x,1,"$item△$sts$price"); } &joinitem('i'); $fg = ''; &userout; } # Sub Fee Before # sub fee_before { @rcdlines = &get_user("$Fm{'id'}"); ($cr,$rv) = split(/△/,$fe); $fg='FB'; &userout; push (@msg,'治療費を設定してください'); &form('start'); print qq||; print qq|解毒の治療費：HP $def_hc 使用\n| if $sp =~ /Ad/; &input('text','cr',"$cr",' size=10',' G
') if $sp =~ /Ad/; print qq|蘇生の治療費：HP $def_hr 使用\n| if $sp =~ /Rv/; &input('text','rv',"$rv",' size=10',' G
') if $sp =~ /Rv/; &OKbuttoninform('n','fee_after'); print qq||; &form('end'); } # Sub Fee After # sub fee_after { @rcdlines = &get_user("$Fm{'id'}"); return if $fg ne 'FB'; return if $sp !~ /Ad|Rv/; if (($Fm{'cr'} =~ /[^0-9]/ || !$Fm{'cr'}) && $sp =~ /Ad/) { push (@msg,"解毒の治療費が設定されていません"); $Fm{'cr'} = 0; } if (($Fm{'rv'} =~ /[^0-9]/ || !$Fm{'rv'}) && $sp =~ /Rv/) { push (@msg,"蘇生の治療費が設定されていません"); $Fm{'rv'} = 0; } push (@msg,'治療費を設定を終了します'); $fg = ''; $fe = "$Fm{'cr'}△$Fm{'rv'}"; &userout; } # Sub Sell Before # sub sell_before { @rcdlines = &get_user("$Fm{'id'}"); @prclines = &get_partner("$Fm{'pd'}"); if (!$bg) { push (@msg,'何ももっていません'); return } $fg='SB'; &userout; push (@msg,"$pnmに売るアイテムにチェックを入れ$def_okボタンを押してください"); &splititem('i'); &form('start'); print qq||; foreach (0 .. $#items) { ($item,$sts,$price) = split(/△/,$items[$_]); $pc = int(substr($sts,0,4)); if ($sts =~ /Q[swat]/) { print qq|　　　装備中：【$item】・・・$pc\G \n| } elsif ($sts =~ /Wi/) { print qq|　　　買取不可：【$item】 \n| } elsif ($sts =~ /(V[a-z])/ && $psp =~ /$1/) { print qq|　　　買取不可：【$item】 \n| } else { &input('checkbox',"$_",'on','',''); print qq|$item・・・$pc\G \n| } } &OKbuttoninform('on','sell_after'); print qq||; &form('end'); } # Sub Sell After # sub sell_after { if (!$post) { return } @rcdlines = &get_user("$Fm{'id'}"); return if $fg ne 'SB'; @prclines = &get_partner("$Fm{'pd'}"); &splititem('iI'); $space = $pxi - $#pitems - 1; foreach (0 .. $#items) { ($item,$sts,$price) = split(/△/,$items[$_]); $returnbag = 1; $pc = int(substr($sts,0,4)); if ($Fm{"$_"} && $sts !~ /Q[swat]/) { if ($pmn >= $pc) { if ($space || $sts =~ /Ti/ || $def_ad) { $pmn -= $pc; $mn += $pc; push (@msg,"$itemを売りました"); $words .= "[$id] $nmから$itemを$pc\Gで買い取りました。"; if ($sts =~ /Ti/) { $space++ } elsif ($def_ap || $def_as) { $pc += $def_as if $def_as; $pc += int($def_ap * $pc / 100) if $def_ap; push(@pitems,"$item△$sts△$pc"); } else { push(@pitems,"$item△$sts") } $returnbag = 0; $space--; shift(@pitems) if $def_ad && $#pitems >= $pxi; } else { push (@msg,"$pnmは$itemを買う気がないようです") } } else { push (@msg,"$pnmは$itemを買うお金がありません") } } if ($returnbag) { push(@newitems,$items[$_]); } } @items = @newitems; &joinitem('iI'); $fg = ''; &userout; &add_record($words); } # Sub Buy Before # sub buy_before { @rcdlines = &get_user("$Fm{'id'}"); @prclines = &get_partner("$Fm{'pd'}"); &splititem('i'); if ($#items + 1 >= $xi) { push (@msg,"これ以上荷物を持てません"); return } $fg='BB'; &userout; push (@msg,"$pnmから買うアイテムにチェックを入れ$def_okボタンを押してください"); &form('start'); print qq||; &splititem('I'); foreach (0 .. $#pitems) { ($item,$sts,$price) = split(/△/,$pitems[$_]); if ($price) { &input('checkbox',"$_",'on','',''); &input('hidden',"i$_","$item$price",'',''); print qq|$item・・・$price\G \n|; } } &OKbuttoninform('on','buy_after'); print qq||; &form('end'); } # Sub Buy After # sub buy_after { if (!$post) { return } @rcdlines = &get_user("$Fm{'id'}"); return if $fg ne 'BB'; @prclines = &get_partner("$Fm{'pd'}"); &error("$pnmと現在接触する事ができません。") if $pfg eq "SS"; &splititem('iI'); $space = $xi - $#items - 1; foreach (0 .. $#pitems) { ($item,$sts,$price) = split(/△/,$pitems[$_]); $returnbag = 1; if ($Fm{"$_"}) { if ($Fm{"i$_"} ne "$item$price"){ push(@msg,"エラーのため$itemを買うことが出来ませんでした") } elsif (!$price) { push(@msg,"$itemは価格設定されていません") } elsif ($mn >= $price) { if ($space) { $mn -= $price; $pmn += $price; push (@msg,"$itemを買いました"); $words .= "[$id] $nmに$itemを$price\Gで売りました。"; push(@items,"$item△$sts"); $space--; $returnbag = 0; } else { push (@msg,"$nmはこれ以上$itemを持てません") } } else { push (@msg,"$nmは$itemを買うお金がありません") } } if ($returnbag) { push(@newitems,$pitems[$_]) } } @pitems = @newitems; &joinitem('iI'); $fg = ''; &userout; &add_record($words); } # Sub Name Before # sub name_before { @rcdlines = &get_user("$Fm{'id'}"); if ($bp !~ /Na/) { return } if (!$bg) { push (@msg,'アイテムを持っていません'); return } &splititem('i'); &form('start'); print qq||; print qq|所持している銘入り品
\n|; foreach (0 .. $#items) { ($item,$sts,$price) = split(/△/,$items[$_]); if ($sts !~ /Y[swat]/) { next } if ($sts =~ /Rn/) { next } &input('radio','ri',"$_",'',''); print qq|$item \n|; $exist = 1; } if (!$exist) { push (@msg,'改名できる銘入り品がありません'); return } $fg = 'NB'; &userout; print qq|
新しい名前：|; &input('text','nn','','',''); &OKbuttoninform('n','name_after'); push (@msg,'改名する銘入り品にチェックを入れてください。
銘入り品で無いアイテムは表示されません
また既に改名したアイテムは表示されません'); print qq||; &form('end'); } # Sub Name After # sub name_after { if (!$post) { return } @rcdlines = &get_user("$Fm{'id'}"); return if $fg ne 'NB'; if ($bp !~ /Na/) { return } if (!$Fm{'nn'}) { push (@msg,'新しい名前が未入力です'); return } if ($Fm{'nn'} =~ /,/) { push (@msg,'半角カンマは使用できません'); return } if ($Fm{'ri'} eq '') { push (@msg,'選択されていません'); return } &splititem('i'); ($item,$sts,$price) = split(/△/,$items[$Fm{'ri'}]); $item = $Fm{'nn'}; $sts .= 'Rn'; splice(@items,$Fm{'ri'},1,"$item△$sts"); &joinitem('i'); push (@msg,"$Fm{'nn'}が誕生しました！");$bp = $bn = $fg = '' ; &userout; } # Sub Judge Before # sub judge_before { @rcdlines = &get_user("$Fm{'id'}"); if (!$bg) { push (@msg,'アイテムを持っていません'); return } if ($hp < 2) { push (@msg,'体力が足りません'); return } $fg = 'JB'; &userout; push (@msg,'鑑定するアイテムにチェックをいれてください'); &splititem('i'); &form('start'); print qq||; print qq|鑑定するアイテム
\n|; foreach (0 .. $#items) { ($item,$sts,$price) = split(/△/,$items[$_]); &input('radio','jd',"$_",'',''); print qq|$item \n|; } &OKbuttoninform('n','judge_after'); print qq||; &form('end'); } # Sub Judge After # sub judge_after { if (!$post) { return } @rcdlines = &get_user("$Fm{'id'}"); return if $fg ne 'JB'; if ($hp < 2) { push (@msg,'体力が足りません'); return } if ($Fm{'jd'} eq '') { push (@msg,'選択されていません'); return } @INi = ('Sw','Kn','Kt','Ax','Gv','Wd','Bw','Mi','Sh','Ar','Jw', 'Dh','Ns','Ie','Wi','Li','Pz','Fd','Hb','Di','Lc','Ig','Rb','Bg','Ca','Ss','V','Pi','Oi'); @INs = ('剣','ナイフ','刀','斧','グラブ','杖','弓','楽器','盾','鎧','宝珠', '両手持ち用','盗まれない','壊れない','質屋に売ることができない','レアアイテム','毒性', '食べ物','スパイス','ダメージ追加アイテム','ダメージ軽減アイテム','インゴット', '復活','所持上限増加アイテム','イベント用アイテム','セーブ系アイテム', '接触用アイテム','防御力増加アイテム','攻撃力増加アイテム'); &splititem('i'); ($item,$sts,$price) = split(/△/,$items[$Fm{'jd'}]); $pc = int(substr($sts,0,4)); $iak = int(substr($sts,4,2)); $idd = int(substr($sts,6,2)); $words = "品名：$item 下取り価格：$pc 攻撃(増加)値: $iak 防御値: $idd "; foreach (0 .. $#INi) { if ($sts =~ /$INi[$_]/) { $words .= "$INs[$_]　" } } push (@msg,"$words"); $hp--; $fg = ''; &userout; } # Sub Stellatio Before # sub stell_before { @rcdlines = &get_user("$Fm{'id'}"); if (!$is) { push (@msg,'ステラツィオを持っていません'); return } $fg = 'ZB'; &userout; push (@msg,'トレードに出すステラツィオにチェックをいれてください'); push (@msg,'12種全てそろえるとステータスを上げることができます'); &form('start'); print qq||; print qq|トレードするステラツィオ
\n|; $stellalength = length($is) - 1; foreach (0 .. $stellalength) { &stell_sub($is,$_); &input('checkbox',$_,'on',' checked','') if $initial =~ /[a-z]/; &input('checkbox',$_,'on','','') if $initial =~ /[A-Z]/; print qq|\n|; print qq|$itn[$ininum] |; } &OKbuttoninform('n','stell_after'); print qq||; &form('end'); &form('start'); print qq||; print qq|ステータスを上げる(全12種必要)
\n|; foreach (0 .. $#sdtlines) { &input('radio','pw',"$_",'',''); print qq|$smglines[$_] \n| } &OKbuttoninform('n','stell_comp'); print qq||; &form('end'); } # Sub Stellatio After # sub stell_after { @rcdlines = &get_user("$Fm{'id'}"); return if $fg ne 'ZB'; $stellalength = length($is) - 1; foreach (0 .. $stellalength) { $initial = substr($is,$_,1); if ($Fm{$_}) { $initial = lc($initial) } else { $initial = uc($initial) } $newis .= $initial; } $is = $newis; $fg = ''; &userout; push (@msg,"ステラツィオのトレード設定を変更しました"); } # Sub Stellatio Complete sub stell_comp { @rcdlines = &get_user("$Fm{'id'}"); return if $fg ne 'ZB' || $Fm{'pw'} eq ''; $is_ = uc($is); foreach (@iti) { if($is_ =~ /$_/) { $stellatio++; $is_ =~ s/$_// } } if ($stellatio < 12) { push (@msg,'あなたは全てのステラツィオを揃えていません'); return } $is = $is_; foreach (0 .. $#sdtlines) { if ($Fm{'pw'} eq "$_") { ($value = $sdtlines[$_]) =~ tr/A-Za-z//d; if ($sdtlines[$_] =~ /AT/) { $ak += $value } elsif ($sdtlines[$_] =~ /DF/) { $dd += $value } elsif ($sdtlines[$_] =~ /BG/) { $xi += $value } elsif ($sdtlines[$_] =~ /HP/) { $xp += $value } else { $sp .= $sdtlines[$_] } } } $fg = ''; &userout; push (@msg,'ステータスがアップしました
ステラツィオの設定は解除されます'); } # Sub Stellatio Sub # sub stell_sub { $ininum = $initial = substr($_[0],$_[1],1); $ininum = "1" . $ininum if $initial =~ /[QPqp]/; $ininum =~ tr/ATGCLVBORNQPatgclvbornqp/012345678901012345678901/; } # Sub Trade Before # sub trade_before { @rcdlines = &get_user("$Fm{'id'}"); @prclines = &get_partner("$Fm{'pd'}"); if (!$is) { push (@msg,'トレードできるステラツィオがありません'); return } if ($pis !~ /[a-z]/ || !$pis) { push (@msg,'相手はトレードするステラツィオがありません'); return } $fg='TB'; &userout; $ulength = length($is) - 1; $plength = length($pis) - 1; push (@msg,'それぞれトレードするステラツィオを選んでください'); &form('start'); print qq||; print qq|$nm
|; foreach (0 .. $ulength) { &stell_sub($is,$_); print qq|\n| if !$_; print qq|\n| if $_; print qq|\n|; print "$itn[$ininum] "; } print qq|
|; print qq|$pnm
|; foreach (0 .. $plength) { &stell_sub($pis,$_); next if $initial =~ /[A-Z]/; print qq|\n|; print qq|\n|; print "$itn[$ininum] "; } &OKbuttoninform('on','trade_after'); print qq||; &form('end'); } # Sub Trade After # sub trade_after { if (!$Fm{'P'}) { push (@msg,'相手のステラツィオが選択されていません'); return } @rcdlines = &get_user("$Fm{'id'}"); @prclines = &get_partner("$Fm{'pd'}"); return if $fg ne 'TB'; $count = ($is =~ s/$Fm{'U'}//); $is .= uc($Fm{'P'}); return if !$count; $count = ($pis =~ s/$Fm{'P'}//); $pis .= uc($Fm{'U'}); return if !$count; $fg = ''; &userout; &add_record("[$id] $nmがあなたとステラツィオをトレードしました"); push (@msg,'ステラツィオをトレードしました'); } # Sub Comment Before # sub com_before { @rcdlines = &get_user("$Fm{'id'}"); $fg='CB'; &userout; push (@msg,'コメント文を変更してください'); &form('start'); print qq|コメント：|; &input('text','com',"$cm"," size=$def_ts",''); &OKbuttoninform('n','com_after'); print qq||; &form('end'); } # Sub Comment After # sub com_after { @rcdlines = &get_user("$Fm{'id'}"); return if $fg ne 'CB' || $Fm{'com'} eq ''; $cm = $Fm{'com'}; push (@msg,'コメント文を変更しました'); $fg = ''; &userout; } # Sub Note Before # sub note_before { if ($Fm{'pd2'}) { $Fm{'pd'} = $Fm{'pd2'} } if ($Fm{'pd2'} eq $Fm{'id'}) { push (@msg,"自分に手紙を出すことはできません"); return } @rcdlines = &get_user("$Fm{'id'}"); &get_partner("$Fm{'pd'}"); $fg='NB'; &userout; push (@msg,"[$Fm{'pd'}] 相手に手紙を書くことができます"); &form('start'); print qq|手紙の内容：|; &input('text','words',''," size=$def_ts",''); &OKbuttoninform('on','note_after'); print qq||; &form('end'); } # Sub Note After # sub note_after { @rcdlines = &get_user("$Fm{'id'}"); @prclines = &get_partner("$Fm{'pd'}"); return if $fg ne 'NB'; return if $Fm{'words'} eq ''; &add_record("[$id] $nmからの手紙:「$Fm{'words'}」"); push (@msg,"$pnmに手紙を残しました"); $fg = ''; &userout; } # Sub Poem Before # sub poem_before { @rcdlines = &get_user("$Fm{'id'}"); $fg='PB'; &userout; push (@msg,'詩を書くことができます') if $sp =~ /Wp/; push (@msg,'日誌を書くことができます') if $sp =~ /An/; &form('start'); print qq||; print qq|詩：| if $sp =~ /Wp/; &input('text','poem',''," size=$def_ts",'
') if $sp =~ /Wp/; print qq|日誌：| if $sp =~ /An/; &input('text','note',''," size=$def_ts",'
') if $sp =~ /An/; &OKbuttoninform('n','poem_after'); print qq||; &form('end'); } # Sub Poem After # sub poem_after { @rcdlines = &get_user("$Fm{'id'}"); return if $fg ne 'PB'; $fg = ''; &userout; &opensosdat; $poet = $nm if $Fm{'poem'}; $poem = $Fm{'poem'} if $Fm{'poem'}; $aven = $nm if $Fm{'note'}; $note = $Fm{'note'} if $Fm{'note'}; &writesosdat; push (@msg,'詩を書きました') if $Fm{'poem'}; push (@msg,'日誌を書きました') if $Fm{'note'}; } # Sub Words Before # sub words_before { @rcdlines = &get_user("$Fm{'id'}"); $fg='WB'; &userout; push (@msg,"[$Fm{'pd'}] 相手にメッセージを残すことができます"); &form('start'); print qq|メッセージ：|; &input('text','words',''," size=$def_ts",''); &OKbuttoninform('on','words_after'); print qq||; &form('end'); } # Sub Words After # sub words_after { @rcdlines = &get_user("$Fm{'id'}"); @prclines = &get_partner("$Fm{'pd'}"); return if $fg ne 'WB'; return if $Fm{'words'} eq ''; &add_record("[$id] $nm:「$Fm{'words'}」"); push (@msg,"$pnmにメッセージを残しました"); $fg = ''; &userout; } # Sub Cure & Revive # sub cure_revive { @rcdlines = &get_user("$Fm{'id'}"); @prclines = &get_partner("$Fm{'pd'}"); ($php,$ptm) = &hprecover($php,$pxp,$psp,$pav,$ptm,$pfg); if ($def_hc >= $php && $Fm{'mode'} eq 'cr') { push (@msg,"$pnmは解毒できる体力がありません");return } if ($def_hr >= $php && $Fm{'mode'} eq 'rv') { push (@msg,"$pnmは蘇生できる体力がありません");return } if ($pav eq 'dead') { push (@msg,"$pnmは死んでいます"); return } ($cr,$rv) = split(/△/,$pfe); if ($Fm{'mode'} eq 'cr') { if ($av ne 'poison') { return } if (!$cr) { push (@msg,"$pnmは解毒治療を行っていません");return } if ($mn < $cr) { push (@msg,"治療費を払うお金がありません");return } $av = 'alive'; $mn -= $cr; $pmn += $cr; $php -= $def_hc; &add_record("[$id] $nmを$cr\Gで解毒しました"); } if ($Fm{'mode'} eq 'rv') { if ($av ne 'dead') { return } if (!$rv) { push (@msg,"$pnmは蘇生治療を行っていません");return } if ($mn < $rv) { push (@msg,"治療費を払うお金がありません");return } $av = 'alive'; $mn -= $rv; $pmn += $rv; $php -= $def_hr; $hp = 1; &add_record("[$id] $nmを$rv\Gで蘇生しました"); } &userout; push (@msg,"解毒しました") if $Fm{'mode'} eq 'cr'; push (@msg,"蘇生しました") if $Fm{'mode'} eq 'rv'; } # Sub Fight # sub fight { @rcdlines = &get_user("$Fm{'id'}"); @prclines = &get_partner("$Fm{'pd'}"); if ($pav eq 'dead') { push (@msg,"$pnmは死んでいます"); return } if ($av eq 'dead') { push (@msg,'あなたは死んでいます'); return } if ($hp <= 2) { push (@msg,'戦闘できる体力がありません'); return } if ($plf eq $id) { push (@msg,"$pnmとは暫く戦えません"); return } srand(time | $$); if ($sp =~ /Qb/) { $uw = (-2,-1,0,1,2) [int(rand(5))] } if ($sp =~ /Qk/) { $uw = (-1,0,0,1,2) [int(rand(5))] } if ($sp =~ /Mw/) { $uw = 1 } if ($sp =~ /Qx/) { $ua = (-1,0,1) [int(rand(3))] } if ($sp =~ /Ma/) { $ua = 1 } if ($sp =~ /Sd/ && $sp =~ /Qm/) { $uw += $def_Qm } if ($psp =~ /Qb/) { $pw = (-2,-1,0,1,2) [int(rand(5))] } if ($psp =~ /Qk/) { $pw = (-1,0,0,1,2) [int(rand(5))] } if ($psp =~ /Mw/) { $pw = 1 } if ($psp =~ /Qx/) { $pa = (-1,0,1) [int(rand(3))] } if ($psp =~ /Ma/) { $pa = 1 } if ($psp =~ /Sd/ && $psp =~ /Qm/) { $pw += $def_Qm } if ($bp =~ /Oi/) { ($uo = $bp) =~ tr/A-Za-z//d } if ($bp =~ /Pi/) { ($up = $bp) =~ tr/A-Za-z//d } if ($pbp =~ /Oi/) { ($po = $pbp) =~ tr/A-Za-z//d } if ($pbp =~ /Pi/) { ($pp = $pbp) =~ tr/A-Za-z//d } $uatk = $ak + $ab + $uw + $uo; $patk = $pak + $pab + $def_ab + $pw + $po; $udfd = $dd + $db + $ua + $up; $pdfd = $pdd + $pdb + $pa + $pp; ($php,$ptm) = &hprecover($php,$pxp,$psp,$pav,$ptm,$pfg); foreach ('a','b','c','d','e') { $bcount++; if ($rw >= $def_rp && $psp =~ /X$_/) { $patk += $bcount } if ($prw >= $def_rp && $sp =~ /X$_/) { $uatk += $bcount } } $udice = int(rand($Badice)) + $uatk - $def_dm; # 己 $pdice = int(rand($Badice)) + $patk - $def_dm; # 敵 $Sidice -= $def_td if $sp =~ /Si/; $Bedice = int(rand($Bedice)); $Lddice = int(rand($Lddice)); $Dtdice = int(rand($Dtdice)); $Chdice = int(rand($Chdice)); $Mgdice = int(rand($Mgdice)); $Bidice = int(rand($Bidice)); $Cndice = int(rand($Cndice)); $Dkdice = int(rand($Dkdice)); $Sidice = int(rand($Sidice)); $Afdice = int(rand($Afdice)); $Cmdice = int(rand($Cmdice)); $Bkdice = int(rand($Bkdice)); $Drdice = int(rand($Drdice)); $Ctdice = int(rand($Ctdice)); $Bldice = int(rand($Bldice)); $result = $udice <=> $pdice; if ($result == 1) { $dmg = (1,1,$udice - $pdfd) [($udice <=> $pdfd) + 1]; ($php,$pav,$pdt,$prw,$hp,$av,$dt) = &fight_sub($nm,$hp,$sp,$ab,$bp,$ak,$av,$dt,$bn,$pnm,$php,$psp,$pbp,$pav,$pdt,$prw,$pbn); $mn += $Wm; $plz++; $wn++; $itemchance = 1; $hp = $xp if $hp > $xp; if ($def_ar) { $rw += $def_ar }; } if ($result == -1) { $dmg = (1,1,$pdice - $udfd) [($pdice <=> $udfd) + 1]; ($hp,$av,$dt,$rw,$php,$pav,$pdt) = &fight_sub($pnm,$php,$psp,$pab,$pbp,$pak,$pav,$pdt,$pbn,$nm,$hp,$sp,$bp,$av,$dt,$rw,$bn); $pmn += $Wm; $lz++; $pwn++; $php = $pxp if $php > $pxp; if ($def_ar) { $prw += $def_ar }; } if ($result == 0) { &fmsg('引'); $hp-- } if (!$php) { $kl++ }; if (!$hp) { $pkl++ }; if ($wn) { $rt = &rate($wn,$lz,$kl,$dt) } else { $rt = 0 } if ($pwn) { $prt = &rate($pwn,$plz,$pkl,$pdt) } else { $prt = 0 } if ($def_wm && $result == 1) { if ($rt < $prt) { $pay = int(($prt - $rt) * $def_wm) } if ($def_lt) { $pay = $def_lt if $pay > $def_lt } $mn += $pay; push (@msg,"$pay\Gの勝利金を手に入れました") if $pay; } if ($def_lm && $result == -1) { if ($prt < $rt) { $pay = int(($rt - $prt) * $def_lm) } if ($def_lt) { $pay = $def_lt if $pay > $def_lt } $pmn += $pay; &fmsg('金') if $pay; } &splititem('i'); if (!$Bidice) { foreach (0 .. $#items) { ($item,$sts,$price) = split(/△/,$items[$_]); if ($sts =~ /Li/ && $Bldice) { next } if ($result == 1 && $sts =~ /Qw/ && $sts !~ /Ie/) { $breakitem = 1 } if ($result == -1 && $sts =~ /Qs/ && $sts !~ /Qw/ && $sts !~ /Ie/) { $breakitem = 1 } elsif ($result == -1 && $sts =~ /Qa/ && $sts !~ /Ie/) { $breakitem = 1 } if ($result == 0 && $sts =~ /Qt/ && $sts !~ /Ie/) { $breakitem = 1 } if ($breakitem) { $ab -= substr($sts,4,2); $db -= substr($sts,6,2); splice(@items,$_,1); &joinitem('i'); $sp =~ s/Qb//g if $sts =~ /Bw/; $sp =~ s/Qk//g if $sts =~ /Kt/; $sp =~ s/Qx//g if $sts =~ /Ax/; $sp =~ s/Qm//g if $sts =~ /Sw/; push (@msg,"$itemが壊れました"); last; } } } $itemchance = 0 if $#items + 1 >= $xi; &splititem('I'); if ($itemchance && $pitems[$Sidice]) { &splititem('i'); ($item,$sts,$price) = split(/△/,$pitems[$Sidice]); if ($sts !~ /Ns/) { if ($sts =~ s/Q[swat]//g) { $pab -= substr($sts,4,2); $pdb -= substr($sts,6,2) } splice(@pitems,$Sidice,1); push(@items,"$item△$sts"); $psp =~ s/Qb//g if $sts =~ /Bw/; $psp =~ s/Qk//g if $sts =~ /Kt/; $psp =~ s/Qx//g if $sts =~ /Ax/; $psp =~ s/Qm//g if $sts =~ /Sw/; &joinitem('iI'); &fmsg('奪'); } } $bp = $bn = $pbp = $pbn = ''; $plf = $id; &userout; &add_record($fwords); } # Fight Sub # sub fight_sub { ($Wn,$Wh,$Ws,$Ww,$Wb,$Wa,$Wv,$Wt,$Wm,$Ln,$Lh,$Ls,$Lb,$Lv,$Lt,$Lr,$Lm) = @_; ($Wd = $Wb) =~ tr/A-Za-z//d; ($Ld = $Lb) =~ tr/A-Za-z//d; &fmsg('勝'); if ($Ls =~ /Im/) { &fmsg('不'); goto JUMP } if (!$Bedice && $Ls =~ /Be/) { &fmsg('悩'); goto JUMP } if (!$Chdice && $Ws =~ /Ch/) { &fmsg('殺'); $DIE = 1; goto JUMP } if (!$Cndice && $Ws =~ /Cn/ && $Lr >= $def_rp) { &fmsg('狩'); $DIE = 1; goto JUMP } if (!$Afdice && $Ls =~ /Af/) { &fmsg('鉄') } else { &fmsg('ダ'); $Lh -= $dmg } if (!$Drdice && $Ws =~ /Dr/) { &fmsg('吸'); $Wh += $dmg } if (!$Lddice && $Ls =~ /Ld/) { &fmsg('犬'); $Wh -= $dmg } if (!$Mgdice && $Ws =~ /Mg/) { &fmsg('魔'); $Lh -= $Wa } if (!$Dkdice && $Ws =~ /Dk/) { &fmsg('連'); $Lh -= $Ww } if (!$Bkdice && $Ws =~ /Bk/ && $Wh > 1) { $hWh = int($Wh/2); &fmsg('走'); $Lh -= $hWh } if ($Wb =~ /Di/) { if (!$Cmdice && $Ls =~ /Cm/) { &fmsg('魅'); $Wh -= $Wd } elsif ($Ls =~ /Aa/) { &fmsg('鋼') } else { &fmsg('追'); $Lh -= $Wd } } if ($Lb =~ /Lc/) { &fmsg('守'); $Lh += $Ld } if ($Wb =~ /Pz/) { if ($Ls =~ /Np/) { &fmsg('解') } else { &fmsg('毒'); $Lv = 'poison' } } if (!$Ctdice && $Ls =~ /Ct/) { &fmsg('反'); $Wh = int(($Wh + 1)/2) } if ($Lh <= 0) { &fmsg('死'); $DIE = 1 } if ($Wh < 1) { $Wh = 1 } JUMP: if ($DIE) { $Lv = 'dead'; $Lt++; $Lh = 0 } if ($DIE && !$Dtdice && $Ls =~ /Dt/) { &fmsg('道'); $Wv = 'dead'; $Wt++; $Wh = 0 } if ($DIE && $Lr >= $def_rp) { &fmsg('褒'); $Wm = $Lr; $Lr = 0 } return ($Lh,$Lv,$Lt,$Lr,$Wh,$Wv,$Wt); } # Fight Message # sub fmsg { %fmsg = ( '勝',"$Wnが戦闘に勝利しました！", '不',"だが$Lnは不死身のため全くダメージを受けない！", '悩',"$Lnは$Wnを悩殺し$Wnに攻撃をやめさせました", '殺',"$Wnの一撃は$Lnを死に至らしめた！", '狩',"$Wnの一撃が$Lnの喉を掻き切った！", '鉄',"$Lnは鉄壁の守りによりダメージを防ぎました！", 'ダ',"$Lnは$dmgポイントのダメージを受けました！", '吸',"$Wnは相手の体力を$dmgポイント吸収しました！", '犬',"$Lnの愛犬が$Wnに仕返しの一撃！$Wnは$dmgポイントのダメージを食らった！", '魔',"$def_mn[$Wa]による$Waポイントの追加ダメージ！", '連',"$Wnは連続切りで$Lnに更に$Wwの追加ダメージ！", '走',"$Wnは突如暴\走しました。$Lnに更に$hWhの追加ダメージ！", '魅',"$Lnは$Wnを魅了した！$Wnは自分に$Wmを使ってしまい$Wdのダメージを食らった！", '鋼',"$Lnは$Wmによる追加ダメージを無効化！", '追',"$Wmによる$Wdポイントの追加ダメージ！", '守',"$Lnは$Lmにより$Ldポイントの体力を取り戻しました", '解',"$Lnは毒を無効化しました", '毒',"$Lnは毒化しました", '反',"$Wnは$Lnの反撃を食らい体力が半減しました！", '死',"体力が0になり、$Lnは死亡しました", '道',"$Lnは最後の一撃をもって$Wnを道連れにした！", '褒',"賞金首$Lnの殺害により$Wnは$Lr\Gの報奨金を得ました", '奪',"$pnmから$itemを奪いました", '引',"戦いは引き分けに終わりました。" ); %frcd = ( '勝',"[$id] $nmの挑戦を受け、$Wnが戦いに勝利しました。", '悩',"$Lnは$Wnを悩殺し$Wnに攻撃をやめさせました。", '殺',"$Wnの一撃が$Lnを死に至らしめました。", '狩',"$Wnの一撃が$Lnの喉を掻き切り死に至らしめました。", '鉄',"$Lnは鉄壁の守りによりダメージを防ぎました！", 'ダ',"$Wnは$Lnに$dmgポイントのダメージ！", '吸',"$Wnは相手の体力を$dmgポイント吸収しました！", '犬',"$Lnの愛犬が$Wnに仕返しの一撃！$Wnは$dmgポイントのダメージを食らった！", '魔',"$def_mn[$Wa]による$Waポイントの追加ダメージ。", '連',"連続切りで$Lnに更に$Wwの追加ダメージ。", '走',"暴\走した$Wnは$Lnに更に$hWhの追加ダメージ！", '魅',"$Lnは$Wnを魅了しました！$Wnは自分に$Wmを使ってしまい$Wdのダメージ！", '鋼',"$Lnは$Wmによる追加ダメージを無効化！", '追',"$Wmによる$Wdポイントの追加ダメージ！", '守',"$Lnは$Lmにより$Ldポイントの体力を取り戻しました。", '解',"$Lnは毒を無効化しました。", '毒',"$Wnの毒が$Lnを毒化しました。", '反',"$Wnは$Lnの反撃を食らい体力が半減しました！", '死',"体力が0になり、$Lnは死亡しました。", '道',"$Lnは$Wnを自分の死の道連れにしました。", '褒',"賞金首$Lnの殺害により$Wnは$Lr\Gの報奨金を得ました。", '奪',"$nmに$itemを奪われました。", '引',"[$id] $nmの挑戦を受けましたが、戦いは引き分けに終わりました。", '金',"$pay\Gの勝利金を手に入れました。" ); push (@msg,$fmsg{$_[0]}); $fwords .= $frcd{$_[0]}; } # Sub Reward # sub reward { if ($Fm{'id'} eq $Fm{'pd'}) { push (@msg,"自分に報奨金をかけることはできません"); return } if ($Fm{'price'} =~ /[^0-9]/ || !$Fm{'price'}) { push (@msg,"金額を入力してください"); return } @rcdlines = &get_user("$Fm{'id'}"); if (!$mn) { push (@msg,"お金を持っていません"); return } @prclines = &get_partner("$Fm{'pd'}"); if ($psp !~ /Tf/) { push (@msg,"$pnmは戦闘系ではありません"); return } $Fm{'price'} = $mn if $Fm{'price'} >= $mn; $mn -= $Fm{'price'}; &userout; $prw += $Fm{'price'}; &partnerout; push (@msg,"$pnmに$Fm{'price'}\Gの報奨金をかけました"); } # Sub Save Game # sub save_game { @rcdlines = &get_user("$Fm{'id'}"); if ($fg =~ /NS|HS/) { &main_form; return } if ($Fm{'mode'} eq 'norm_save') { $fg = 'NS' } if ($Fm{'mode'} eq 'hide_save') { $fg = 'HS' } if ($bp =~ /Ss/) { $fg = 'SS'; push (@msg,"$bnを使用しました"); $bp = $bn = '' } push (@msg,"ゲームを保存しました。お疲れ様でした"); &userout; $printmsg = 1; &main_form; } # Sub Levy # sub levy { if (!$post) { return } if ($def_lv == 1) { $target = 'Tv' } elsif ($def_lv == 2) { $target = 'Tf' } &get_file; @usrfile = sort(@usrfile); foreach $dat (@usrfile) { $dat =~ s/\.dat//; @rcdlines = &get_user("$dat"); if ((!$def_lv || $sp !~ /$target/) && $id ne $Fm{'id'}) { $tax = int($def_lp / 100 * $mn); $mn -= $tax; $taxs += $tax; &userout; } $getuserflag = 0; } @rcdlines = &get_user("$Fm{'id'}"); $mn += $taxs; $fg = 'NS'; &userout; $jobtype = ('全員','戦闘系','非戦闘系') [ $def_lv ]; &error("$jobtypeから$def_lp %の税金を徴収しました。
同時にキャラクターの保存もしました。
更新ボタンは押さないで下さい。"); } # Sub Back Up # sub back_up { @rcdlines = &get_user("$Fm{'id'}"); @buplines = &opendat($bupdat); if (!@buplines) { &error("バックアップファイル読みこみエラー") } foreach (0 .. $#buplines) { ($bid,$bnm,$others) = split(/<>/,$buplines[$_]); if ($id eq $bid && $nm eq $bnm) { splice(@buplines,$_,1,$userline); $bingo = 1; } } if (!$bingo) { push (@buplines,$userline) } &writedat($bupdat,@buplines); push (@msg,"正常にバックアップが完了しました"); } # Sub Delete Before # sub del_before { push (@msg,"本当に削除しても宜しいですか？") &form('start'); print qq|削除する場合は$def_okボタンを押してください。|; &OKbuttoninform('n','del_after'); print qq||; &form('end'); } # Sub Delete After # sub del_after { unless (-e "$usrdir$Fm{'id'}\.dat") { &error("$Fm{'id'}のデータは存在しません") } @rcdlines = &get_user("$Fm{'id'}"); if ($mn < $def_md) { push (@msg,"削除するには$def_md\G必要です") } else { unlink("$usrdir$id\.dat"); push (@msg,"キャラを削除しました
お疲れ様でした") } } # Sub HitPoint Recover # sub hprecover { ($Hhp,$Hxp,$Hsp,$Hav,$Htm,$Hfg) =@_; $now = time - $Htm; $tmb = 0; if ($Hav eq 'poison') { $tmb -= $def_pz } if ($Hsp =~ /Hl/) { $tmb += $def_hm } if ($Hfg eq 'NS') { $rchp = int($now / (($def_hn - $tmb) * 60)) } if ($Hfg eq 'SS') { $rchp = int($now / (($def_hs - $tmb) * 60)) } if ($Hfg eq 'HS') { $rchp = int($now / (($def_hh - $tmb) * 60)) } $Hhp = &hpcheck($Hhp,$Hxp,$rchp); $Htm = time; return($Hhp,$Htm); } # Sub HitPoint Check # sub hpcheck { $_[0] += $_[2]; $_[0] = 1 if $_[0] < 1; $_[0] = $_[1] if $_[0] > $_[1]; return($_[0]); } # Sub Rate # sub rate { local($wn,$lz,$kl,$dt,$rt) = @_; $rt = int($wn/($wn + $lz) * 100) * $wn - ($dt * 100) + ($kl * 100); return $rt; } # Sub Add Record # sub add_record { &get_time; if ($_[0]) { $words = "$_[0] $date\n"; pop (@prclines) if @prclines >= $def_om; unshift (@prclines,$words); } &partnerout; } # Sub Decoration # sub decoration { $com = $_[0]; foreach (0 .. $#deckey) { $com =~ s/$deckey[$_]/$decwrd[$_]/g } return $com; } # Sub Form # sub form { print qq|\n| if $_[0] eq 'start'; print qq|
\n| if $_[0] eq 'end'; } # Sub Input # sub input { print qq|$_[4]|; } # Sub Split Item # sub splititem { @items = split(/,/,$bg) if $_[0] =~ /i/; @pitems = split(/,/,$pbg) if $_[0] =~ /I/; } # Sub Join Item # sub joinitem { @items = sort(@items) if $_[0] =~ /i/ && $def_so; $bg = join(',',@items) if $_[0] =~ /i/; @pitems = sort(@pitems) if $_[0] =~ /I/ && $def_so; $pbg = join(',',@pitems) if $_[0] =~ /I/; } # Sub OK Button Inform sub OKbuttoninform { print qq|
\n|; print qq|\n| if $_[0] =~ /n/; print qq|\n| if $_[0] =~ /o/; print qq|\n|; print qq|\n| if $_[1]; print qq|
\n|; } # Sub List In Order # sub list_order { $now = time - $def_dl * 86400; &get_file; &list_in; &unlock; foreach (0 .. $#lstlines) { ($id,$nm,$ps,$jb,$ig,$sp,$bp,$bn,$ak,$dd,$hp,$xp,$ab,$db, $av,$wn,$lz,$dt,$mn,$bg,$xi,$tm,$lf,$fe,$cm,$is,$ht,$fg,$rw,$kl) = split(/<>/,$lstlines[$_]); if ($wn) { $rt = &rate($wn,$lz,$kl,$dt) } else { $rt = 0 } if ($Fm{'mode'} eq '' || $Fm{'mode'} eq 'norm_save' || $Fm{'mode'} eq 'hide_save') { &find_del; &find_best; if ($fg eq '' || $fg =~ /B/) { $playernow++ } } %order = ('ID',$id,'Name',$nm,'Rate',$rt,'Money',$mn,'Bounty',$rw,'Job',$jb); next if $Fm{'order'} eq 'Bounty' && $sp !~ /Tf/; next if $Fm{'order'} eq 'Rate' && $sp !~ /Tf/; push (@odrlines,"$order{$Fm{'order'}}<>$lstlines[$_]"); } if ($Fm{'order'} ne 'Name' && $Fm{'order'} ne 'Job' && $Fm{'order'} ne 'ID') { @odrlines = sort({$b <=> $a} @odrlines) } else { @odrlines = sort(@odrlines) } } # Sub Page # sub page { ($first,$total,$eachpage) = @_; $start = $first eq '' ? 0 : $first; $end = $start + ($eachpage - 1); $end = $total if $end >= $total; $next = $end + 1; $back = $start - $eachpage; } # Sub Sales In Order # sub sale_order { &get_file; &list_in; &unlock; foreach (0 .. $#lstlines) { ($id,$nm,$ps,$jb,$ig,$sp,$bp,$bn,$ak,$dd,$hp,$xp,$ab,$db, $av,$wn,$lz,$dt,$mn,$bg,$others) = split(/<>/,$lstlines[$_]); if ($sp =~ /Pb/) { next } splititem('i'); foreach (0 .. $#items) { ($item,$sts,$price) = split(/△/,$items[$_]); if ($price) { push (@odrlines,"$item<>$price<>$id<>$nm") } } } @odrlines = sort(@odrlines); &header; print qq|\n|; print qq|\n|; print qq|\n|; foreach (0 .. $#odrlines) { ($item,$price,$id,$nm) = split(/<>/,$odrlines[$_]); print qq|\n|; } print qq|
販売品リスト
販売品値段ID販売者
$item$price\G$id$nm
\n|; } # Sub Find to Delete # sub find_del { if ($now > $tm && $ps ne $admpas) { unlink("$usrdir$id\.dat") } } # Sub Find the Best Player # sub find_best { if ($rt > $bestrate ) { $hero = $nm; $himg = $ig; $bestrate = $rt } if ($mn > $bestmoney && $sp !~ /Pb/) { $rich = $nm; $rimg = $ig; $bestmoney = $mn } } # Sub My Record # sub my_record { @rcdlines = &get_user("$Fm{'id'}"); if ($ps ne $Fm{'pass'}) { &error("パスワードが違います") } &header; if (!@rcdlines) { print qq|
あなたの記録は白紙です
\n| } else { print qq|
$nmの記録
\n| } foreach $line (@rcdlines) { print qq|$line
\n| } } # Sub Player List # sub player_list { $now = time - $def_gl * 86400; &header; &page($Fm{'page'},$#odrlines,$def_pg); $page_cmd = "$cgiurl?mode=list&order=$Fm{'order'}&page="; print qq|[一括表\示]|; if ($Fm{'all'}) { $start = 0; $end = $#odrlines } else { print qq|[前の$def_pg件]| if $back >= 0; print qq|[次の$def_pg件]| if $end != $total; } for ($i=0; $i <= $#odrlines; $i += $def_pg ) { $page_no = $i / $def_pg + 1; if ($i == $Fm{'page'} && !$Fm{'all'}) { print "[$page_no]" } else { print qq|[$page_no]| } } if ($def_sv) { &simpleview; return } print qq|
\n|; print qq|\n|; print qq||; print qq||; print qq||; print qq|\n|; print qq|\n|; foreach ('居場所','ID','攻','防','勝','負','殺','死','状','所持金','報奨金','アイテム') { print qq|\n|; } print qq|\n|; foreach ($start .. $end) { ($od,$id,$nm,$ps,$jb,$ig,$sp,$bp,$bn,$ak,$dd,$hp,$xp,$ab,$db, $av,$wn,$lz,$dt,$mn,$bg,$xi,$tm,$lf,$fe,$cm,$is,$ht,$fg,$rw,$kl) = split(/<>/,$odrlines[$_]); if ($now > $tm && $ps ne $admpas) { $nm = "$nm" } if ($fe) { ($cu,$rv) = split(/△/,$fe); if ($cu) { $jb .= "　毒：$cu" } if ($rv) { $jb .= "　蘇：$rv" } } print qq||; print qq||; print qq|\n|; print qq|\n|; $cm_ = &decoration($cm); print qq|\n\n|; print qq|\n|; if ($ab) { print qq|\n|} else { print qq|\n|} if ($db) { print qq|\n|} else { print qq|\n|} print qq|\n|; print qq|\n|; print qq|\n|; print qq|\n|; $sh = '生' if $av eq 'alive'; $sh = '死' if $av eq 'dead'; $sh = '毒' if $av eq 'poison'; print qq|\n|; print qq|\n|; if ($rw >= $def_rp) { print qq|\n| } else { print qq|\n| } print qq|\n|; } print qq|
$Fm{'order'}
$Fm{'order'}名前職業コメント
$_
$od$nm$jb$cm_
|; print $av eq 'dead' ? '墓地' : $fg eq 'NS' ? '町' : $fg eq 'HS' ? '放浪' : $fg eq 'SS' ? '不明' : '使用中'; print qq|$id$ak+$ab$ak$dd+$db$dd$wn$lz$kl$dt$sh$mn\G$rw\G$rw\G|; if ($bg) { &splititem('i'); foreach $line (@items) { ($item,$sts,$price) = split(/△/,$line); if ($sts =~ /Q[swat]/) { $item = "$item" } if ($sts =~ /Li/) { $item = "$item" } if ($price) { $item .= "($price)" } print qq|$item |; } } else { print qq|なし| } if ($is =~ /[a-z]/) { $stellalength = length($is) - 1; print qq|
ステラツィオ：|; foreach (0 .. $stellalength) { &stell_sub($is,$_); print qq|\n| if $initial =~ /[a-z]/; } } print qq|
\n|; } # Sub Find User # sub simpleview { foreach ($start .. $end) { ($od,$id,$nm,$ps,$jb,$ig,$sp,$bp,$bn,$ak,$dd,$hp,$xp,$ab,$db, $av,$wn,$lz,$dt,$mn,$bg,$xi,$tm,$lf,$fe,$cm,$is,$ht,$fg,$rw,$kl) = split(/<>/,$odrlines[$_]); if ($now > $tm && $ps ne $admpas) { $nm = "$nm" } if ($fe) { ($cu,$rv) = split(/△/,$fe); if ($cu) { $jb .= "　毒：$cu" } if ($rv) { $jb .= "　蘇：$rv" } } $cm_ = &decoration($cm); $place = $av eq 'dead' ? '墓地' : $fg eq 'NS' ? '町' : $fg eq 'HS' ? '放浪' : $fg eq 'SS' ? '不明' : '使用中'; print qq|$od $nm $jb コメント：$cm_
|; print qq| ID:$id [$place] |; if ($ab) { print qq|攻：$ak+$ab\n|} else { print qq|攻：$ak\n|} if ($db) { print qq|防：$dd+$db\n|} else { print qq|防：$dd\n|} print qq| 勝：$wn 負：$lz 殺：$kl 死：$dt 状態：$av 所持金：$mn\G 報奨金：$rw\G
アイテム：\n|; if ($bg) { &splititem('i'); foreach $line (@items) { ($item,$sts,$price) = split(/△/,$line); if ($sts =~ /Q[swat]/) { $item = "$item" } if ($sts =~ /Li/) { $item = "$item" } if ($price) { $item .= "($price)" } print qq|$item |; } } else { print qq|なし| } if ($is =~ /[a-z]/) { print qq|
ステラツィオ：|; foreach (0 .. length($is) - 1) { &stell_sub($is,$_); print qq|\n| if $initial =~ /[a-z]/; } } print qq|
|; } } # Sub Find User # sub find_user { foreach $no (0 .. $#lstlines) { ($id,$nm,$ps,$jb,$ig,$sp,$bp,$bn,$ak,$dd,$hp,$xp,$ab,$db, $av,$wn,$lz,$dt,$mn,$bg,$xi,$tm,$lf,$fe,$cm,$is,$ht,$fg,$rw,$kl) = split(/<>/,$lstlines[$no]); if ($nm eq $Fm{'name'}) { $xpoint = $no; return } if ($ht eq $host) { $zpoint = 1 } } $xpoint = 'del'; } # Sub Get Host # sub get_host { $host = $ENV{'REMOTE_HOST'}; $addr = $ENV{'REMOTE_ADDR'}; if ($hosttype) { if ($host eq "" || $host eq "$addr") { $host = gethostbyaddr(pack("C4", split(/\./, $addr)), 2); } } if ($host eq "") { $host = $addr; } $host =~ s/(\d+)\.(\d+)\.(\d+)\.(\d+)/$1\.$2\.$3\./; } # Sub Get Cookie # sub cookie_get { @pairs = split(/;/,$ENV{'HTTP_COOKIE'}); foreach $pair (@pairs) { local($name, $value) = split(/=/, $pair); $name =~ s/ //g; $DUMMY{$name} = $value; } @pairs = split(/,/,$DUMMY{'SOS2'}); foreach $pair (@pairs) { local($name, $value) = split(/:/, $pair); $COOKIE{$name} = $value; } $c_name = $COOKIE{'name'}; $c_pass = $COOKIE{'pass'}; $c_id = $COOKIE{'id'}; } # Sub Set Cookie # sub cookie_set { ($secg,$ming,$hourg,$mdayg,$mong,$yearg,$wdayg,$ydayg,$isdstg) = gmtime(time + 90*24*60*60); $yearg += 1900; if ($secg < 10) { $secg = "0$secg"; } if ($ming < 10) { $ming = "0$ming"; } if ($hourg < 10) { $hourg = "0$hourg"; } if ($mdayg < 10) { $mdayg = "0$mdayg"; } $month = ('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct', 'Nov','Dec')[$mong]; $week = ('Sunday','Monday','Tuesday','Wednesday','Thursday','Friday', 'Saturday')[$wdayg]; $date_gmt = "$week, $mdayg\-$month\-$yearg $hourg:$ming:$secg GMT"; $cook="name\:$Fm{'name'}\,pass\:$Fm{'pass'},id\:$Fm{'id'}"; print "Set-Cookie: SOS2=$cook; expires=$date_gmt\n"; } # Sub Get Time # sub get_time { $ENV{'TZ'} = "JST-9"; ($sec,$min,$hour,$day,$mon,$year,$wday,$yday,$isdst) = localtime(time); $year += 1900; @week = ('Sun','Mon','Tue','Wed','Thu','Fri','Sat'); $date = sprintf("%04d-%02d-%02d(%s)%02d:%02d:%02d", $year,$mon +1,$day,$week[$wday],$hour,$min,$sec); }