pax_global_header00006660000000000000000000000064122207351520014511gustar00rootroot0000000000000052 comment=815a36a89fcfa19cd6547eb9b0e0be3dc9096d32 yoshinari-nomura-mhc-815a36a/000077500000000000000000000000001222073515200161145ustar00rootroot00000000000000yoshinari-nomura-mhc-815a36a/.gitignore000066400000000000000000000000061222073515200201000ustar00rootroot00000000000000*.elc yoshinari-nomura-mhc-815a36a/COPYRIGHT000066400000000000000000000030031222073515200174030ustar00rootroot00000000000000Copyright (C) 1999, 2000 Yoshinari Nomura. All rights reserved. Copyright (C) 2000-2010 MHC developing team. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the team nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE TEAM OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. yoshinari-nomura-mhc-815a36a/README000066400000000000000000000050141222073515200167740ustar00rootroot00000000000000 MHC -- Message Harmonized Calendaring system. Yoshinari Nomura Created: 1999-09-01 Revised: 2010-08-07 ** DESCRIPTION: MHC is designed to help those who receive most appointments via email. Using MHC, you can easily import schedule articles from emails. You can get the latest version from: http://www.quickhack.net/mhc/ MHC has following features: + Easy import your schedule from email articles. Using with Mew/Gnus/Wanderlust (MUAs on Emacs), you can easily compose your schedule items from appoint-emails. MHC will guess the title, date, time and description by scanning the email. + Simple data structure allows you to manipulate stored data in many ways. + Both UNIX and Windows support. + Appointments can be made to repeat in flexible ways. + powerful but simple expression of appointments. Each appointment can have following attributes: date, subject, start/end time(not mandatory), advance time of alarm, multiple categories, recurrence rules, duration of the recurrence, list of exception dates, list of extra dates description. + Multiple user interfaces such as commandline/emacs/GUI/Web. MHC currently has following interfaces: + Elisp package cooperative with Mew, Wanderlust or Gnus (popular MUA in the Emacs world) (emacs/mhc.el) + GUI (Ruby/Gtk based) desktop calendar application. (gemcal) + CGI based Web interface (not in this package please see http://mhc.hauN.org/web-mhc/) + Command line schedule lister like the scan of MH. (today) MHC stores schedule articles in the same form of MH; you can manipulate these messages not only by above tools but also by many other MUAs, editors, UNIX commandline tools or your own scripts. ** SYSTEM REQUIREMENTS MHC is supposed to work on systems which has gemcal -- Ruby + ruby-gtk mhc-sync -- Ruby + ssh palm2mhc -- Ruby + pilot-link library (libpisock) mhc2palm -- Ruby + pilot-link library (libpisock) today -- Ruby mhc.el -- Environments which Mew (1.94 or later) or Wanderlust (ver 2.2.10 or later) or Gnus or cmail supports. ** INSTALL: Sorry, I've not written a precise document yet. Edit emacs/Makefile and type make in emacs/ directory to install mhc.el. For Ruby stuffs, type: ruby configure.rb ruby make.rb ruby make.rb install if you don't need Palm support, try: ruby configure.rb --disable-palm ** FOR MORE INFORMATION: Please visit our site: http://www.quickhack.net/mhc/ yoshinari-nomura-mhc-815a36a/README.ja000066400000000000000000000070421222073515200173700ustar00rootroot00000000000000 MHC -- Message Harmonized Calendaring system. Yoshinari Nomura Created: 1999-09-01 Revised: 2010-08-07 ** カレントバージョンを利用する際の注意 ・ emacs 19.x には対応していません。 ・ TODO の仕様は、今後変更される可能性がありますので、 データの互換性がなくなるかもしれません。 ・ X-SC-Next: で 1ファイルに複数のアーティクルが書ける機能も 仕様変更される予定です。 ・ C-cC-c 時のコンフリクトチェックがまだありません。 ・ C-cC-c 時のチェックが甘いです。 + X-SC-Subject がない + X-SC-Day: X-SC-Cond: の両方に何もない + X-SC-Duration: に間違った範囲を指定する 等、一度もスケジュールに現れないような場合に、迷子になります。 ** はじめに: MHC は、ほとんどの予定を電子メールで受け取るような人のためにデザインさ れました。MHC を使うと、簡単に電子メールから予定の情報を取り込むことが できます。 MHC は以下のような特長をもっています: + 取り扱いやすいシンプルなデータ構造 + UNIX と Windows のマルチプラットホームサポート + 予定の柔軟な記述 + 分かりやすく、強力な予定の記述法。 各予定は、以下のような情報を保持することができます: 日付, サブジェクト, 開始/終了時間 (なくてもいい) アラーム, 複数のカテゴリ, 繰り返しのルール, 繰り返しの期間, 繰り返しから例外的に外したい日付 繰り返しに、例外的に加えたい日付 覚書き、予定発生の元になったメール。 + コマンドライン, emacs, GUI, Web といった複数のユーザインターフェース MHC は現在、以下のようなインターフェースを提供しています: + Mew や Wanderlust と協調して動く Elisp パッケージ (mhc.el) + Ruby/Gtk で記述された GUI カレンダー (gemcal) + CGI ベースの Web インターフェース (web-mhc) (パッケージには含まれてません。http://mhc.hauN.org/web-mhc/ 参照) + コマンドラインでの予定一覧表示ツール (mscan) MHC は、予定の情報を MH と同じ形式で保存します。そのため、上記以外のツー ルからでも、メールと似た操作をすることができます。自分独自のスクリプトを 書くことも簡単です。 ** 動作環境: MHC は、以下のようなコマンドを利用しています。 gemcal -- Ruby + ruby-gtk mhc-sync -- Ruby + ssh palm2mhc -- Ruby + pilot-link のライブラリ mhc2palm -- Ruby + pilot-link のライブラリ today -- Ruby mhc.el -- Mew/Wanderlust/Gnus/cmail が動く環境 上記のいずれも UNIX と Windows9x で動くようにしているつもりです。 ** インストール: キュメント類がまだ整備されていません。 emacs 関係は、emacs/ の下で、Makefile を編集して、 make を叩くとコンパイルできます。 その他の ruby 関係は、トップディレクトリから、 ruby configure.rb ruby make.rb ruby make.rb install と叩いて下さい。pilot-link ライブラリがシステムに入っていない場合は、 ruby configure.rb --disable-palm として下さい。この場合、mhc2palm palm2mhc は使えません。 ** さらなる情報: http://www.quickhack.net/mhc/ yoshinari-nomura-mhc-815a36a/README.w32.ja000066400000000000000000000277221222073515200200110ustar00rootroot00000000000000* このファイルの内容 このファイルには、以下に示す Windows 固有の情報の情報が含まれてい ます。 o mhc2ol の使い方 o Windows で mhc2palm/palm2mhc を動かす手順 * mhc2ol の使い方 ** はじめに mhc2ol は、MHC のスケジュールを、Microsoft 社のスケジュール管理ソ フト Outlook (*1)に転送するスクリプトです。Outlook の OLE コント ロールを利用しているため、Windows マシンでしか動きません。 mhc2ol を利用することで、Outlook 経由で、WindowsCE マシンにスケ ジュールを転送できるようになります。 また、cygwin を利用した mhc2palm では対応できていなかった(と思う) USB 接続の Palm にもスケジュールを転送できるようになります。ただ し、Outlook と Palm で同期をとるツールが別途必要です。このような ツールとしては、Intellisync for Palm (*2),PocketMirror (*3) など があります。 *1) MUA の Outlook Express ではありません。 *2) http://www.pumatech.co.jp/product/personal/workpad/is_wp_00.html *3) http://www.chapura.com/html/products/pocketmirror/highlights.html ** 前提条件 以下のソフトウェアをを事前にインストールして使えるようにしておく 必要があります。 (1) ruby http://www.ruby-lang.org/ ruby-1.6.4 以降で動作確認済みです。 (2) win32ole http://homepage1.nifty.com/markey/ruby/win32ole/ win32ole-0.2.8 以降で動作確認済みです。 (3) Outlook Outlook 2000で動作確認済みです。 (4) MHC の ruby ライブラリ MHC パッケージの ruby-ext/lib 以下に存在するものです。通常の 手順で MHC をインストールすることで自動的にインストールされま す。 ** インストール Configure.rb と make.rb を使った通常の手順で MHC をインストールす ることで、Windows 環境では、mhc2ol が自動的にインストールされます。 ** 使い方 Unix 系のシェルを使った実行例を下記に示します。詳しくは、コマンド ライン・ヘルプを参照して下さい。このヘルプは、オプションなしで mhc2ol を起動することで見ることができます。 *** Outlook を初期化して転送 $ mhc2ol -i Outlook のデータを全て削除した後で、MHC のスケジュールを Outlook に転送します。 *** Outlook を初期化しないで転送 $ mhc2ol -a Outlook のデータを削除しないで、MHC のスケジュールを Outlook に転 送します。 *** 必要最小限のスケジュールを転送 $ mhc2ol -N スケジュールのタイムスタンプを比較して、必要最小限のスケジュール を Outlook に転送します。無駄な転送を避けるために、前回の転送後に、 新規作成されたスケジュールや修正されたスケジュールだけを選択して 転送します。万が一、動作が変になった場合は、上記 `-i' オプション で、Outlook のスケジュールを初期化してください。 ** 制限 MHC のスケジュールの全ての形式には対応できていません。 特に X-SC-Cond: での複雑な指定をした場合はダメだと思います。 * Windows で mhc2palm/palm2mhc を動かす手順 ** はじめに この文書は Windows 9X/NT/2000 で mhc2palm と palm2mhc を動かす手 順をまとめたものです。 ここでは、次の2種類の方法を紹介します。 O バイナリパッケージを利用する方法 O ソースからコンパイルする方法 前者は、簡単ですので、とにかく mhc2palm と palm2mhc を使ってみた い人にお勧めです。一方、後者は、UNIX 系のツールの知識が必要であり、 やや上級者向けです。 ** 利用上の制限 現在のところ、シリアルポートで接続された Palm デバイスと MHC でデー タを交換できることを確認しております。しかし、残念ながら USB で接 続された Palm デバイスとはデータを交換できません。 ** バイナリパッケージを利用する方法 ここでは、コンパイル済みのバイナリパッケージを利用して、環境を構 築する方法を説明します。 *** ruby のインストール mhc2palm と palm2mhc は Ruby スクリプトなので、実行するには ruby の実行環境が必要です。 http://www.ruby-lang.org/~eban/ruby/binaries/cygwin/ から cygwin 版のバイナリパッケージを入手します。2001/10/07現在の 最新の安定版は、ruby-1.6.5-i386-cygwin.tar.gz(ruby-1.6.5)です。 パッケージを展開(*)後、パスを通します。C:\ 以下に展開する場合には、 次のように設定します。以降、このディレクトリに ruby をインストー ルしたものとして説明します。 Windows 9X の場合： C:\autoexec.bat に次の設定を加えます。 set PATH=C:\usr\local\bin;%PATH% Windows 2000/NT の場合： 「コントロールパネル」→「システム」→「環境」で、環境変数 Path に C:\usr\local\bin を追加します。 (*)tar.gz 形式(別名 tgz)を展開できるツールを利用してください。こ のようなツールは、下記で、探すことができます。 http://www.vector.co.jp/vpack/pickup/win/util/arc/index.html *** mhc_pilib.so のインストール ruby から Palm にアクセスするためのライブラリ mhc_pilib.so を http://www.quickhack.net/mhc/arc/distfiles/ から入手して、c:\usr\local\lib\ruby\1.6\i386-cygwin にコピーしま す。 *** MHC のインストール 以上の準備を済ませた後で、MHC を通常の手順でインストールすること で、mhc2palm, palm2mhc, およびこれらを動かすために必要なライブラ リもインストールできます。 以下、インストールの手順を示します。 $ cd MHC のトップディレクトリ $ ruby configure.rb [必要ならばオプションを指定します(*)] $ ruby make.rb $ ruby make.rb install (*)オプションの詳細は、`ruby configure.rb --help' を実行して調べてく ださい。Meadow 1.15 が \usr\local\Meadow にインストールされて いて、MUA として gnus を使う場合は、次のように指定すればよいでしょう。 MUA として Mew や Wanderlust を使う場合は、--with-gnus の代わりに、 --with-mew, --with-wl を指定します。 `ruby configure.rb --with-emacs=/usr/local/Meadow/1.15/bin/meadownt\ --with-lispdir=/usr/local/Meadow/site-lisp/mhc\ --disable-palm --with-gnus' *** mhc2palm, palm2mhc の利用方法 mhc2palm, palm2mhc は、DOS プロンプト、または、コマンドプロンプト から実行します。次の点に注意してください。 ・-d オプションで指定するデバイスファイルは、com1, com2 のような 形式で指定します。 ・ruby スクリプトを直接コマンドラインからは実行できません(注)。そ のため、ruby を明示的に実行して、実行したいスクリプトをコマンドラ インオプションとして指定します。 ・mhc2palm と palm2mhc を実行する場合には、事前に、HotSync マネー ジャを停止しておく必要があります。 注)後述する Cygwin に含まれる、sh.exe や bash.exe を使えば、ruby スクリプトを直接コマンドラインから実行できます。 Palm のクレイドルがシリアルポートの1番(com1)に接続されている場合 の、mhc2palm の使用例を次に示します。なお、詳しい利用方法は、 00usage.jis を参照してください。 $ ruby C:\usr\local\bin\mhc2palm -i -d com1 ** ソースからコンパイルする方法 ここでは、必要なツール類をソースからコンパイルする方法を説明しま す。Unix 系のツールの知識が必要となります。 *** Cygwin のインストール まず、各種ツールをコンパイルするために、Cygwin をインストールしま す。これ以降、Cygwin 1.3.X がインストールしてあることを前提として 説明します。 Cygwin のインストール方法は、早田さんの Web ページ http://www.mars.dti.ne.jp/~sohda/cygwin/ を参考にしてください。 また、Cygwin の詳細な情報は、藤枝さんの Web ページ http://www.jaist.ac.jp/~fujieda/cygwin/ からも入手できますので、参考にしてください。 以下、Cygwin の sh.exe または bash.exe をシェルとして利用するもの として説明します。 *** ruby のインストール mhc2palm, palm2mhc は Ruby スクリプトなので、実行のためには ruby の実行環境が必要です。ここでは、後述する ruby 拡張ライブラリのイ ンストールのために、バイナリ配布を使わずに、ソースからビルドしま す。 ruby の最新の安定版を http://www.ruby-lang.org/ja/download.html から入手してください。2001/10/07現在の最新の安定版は、ruby-1.6.5 です。 アーカイブ展開後のコンパイル手順は下記のとおりです。 $ ./configure --enable-shared $ make $ make test (=> test succeeded) $ make install *** pilot-link のインストール pilot-link に含まれる libpisock が、Palm と連携するために必要とな ります。 pilot-link は、下記 URI から入手可能です。 http://www.gnu-designs.com/pilot-link/ 2001/10/07現在の最新版は、pilot-link.0.9.5 です。 次に、アーカイブ入手後のコンパイル手順を示します。なお、パッチファ イル pilot-link.0.9.5.cygwin.diff は、 http://www.quickhack.net/mhc/arc/distfiles/ から入手できます。アーカイブとパッチファイル共に、カレントディレ クトリにあるとします。 $ tar zxvf pilot-link.0.9.5.tar.gz $ cd pilot-link.0.9.5 $ patch -p1 < ../pilot-link.0.9.5.cygwin.diff $ ./configure --enable-shared --with-tcl=no --with-tk=no $ make $ make install EXT='.exe' *** MHC のインストール 以上の準備を済ませた後で、MHC を通常の手順でインストールすること で、mhc2palm, palm2mhc, およびこれらを動かすために必要なライブラ リもインストールされます。 以下、インストールの手順を示します。 $ cd MHC のトップディレクトリ $ ruby configure.rb [必要ならばオプションを指定します(*)] $ ./make.rb $ ./make.rb install (*)オプションの詳細は、`ruby configure.rb --help' を実行して調べてく ださい。Meadow 1.15 が /usr/local/Meadow にインストールされて いて、MUA として gnus を使う場合は、次のように指定すればよいでしょう。 MUA として Mew や Wanderlust を使う場合は、--with-gnus の代わりに、 --with-mew, --with-wl を指定します。 `ruby configure.rb --with-emacs=/usr/local/Meadow/1.15/bin/meadownt\ --with-lispdir=/usr/local/Meadow/site-lisp/mhc\ --with-gnus' *** mhc2palm, palm2mhc のインストール 上記の手順で MHC をインストールすることで、mhc2palm, palm2mhc も インストールされます。 *** mhc2palm, palm2mhc の利用方法 mhc2palm, palm2mhc は、sh.exe や bash.exe などのシェルから実行し ます。次の点に注意してください。 ・-d オプションで指定するデバイスファイルは、com1, com2 のような 形式で指定します(/dev/com1, /dev/com2 の形式でも可)。 ・mhc2palm と palm2mhc を実行する場合には、事前に、HotSync マネー ジャを停止しておく必要があります。 Palm のクレイドルがシリアルポートの1番(com1)に接続されている場合 の、mhc2palm の使用例を次に示します。なお、詳しい利用方法は、 00usage.jis を参照してください。 $ mhc2palm -i -d com1 Local variables: mode:outline fill-column:65 End: yoshinari-nomura-mhc-815a36a/USAGE.ja000066400000000000000000000262451222073515200173050ustar00rootroot00000000000000;;; -*- Mode: outline -*- ################################################################ USAGE.ja ################################################################ Created: 2000-06-26 Revised: 2001-09-30 * コマンドの簡単な使い方 これらのコマンドを利用するには、ruby-ext/ 以下のライブラリをあらかじめイ ンストールしておく必要があります。GUI に関しては、ruby-gtk を必要とします。 samples/DOT.schedule.sample.jp は日本の祭日についてのデータを記述したファ イルです。~/.schedule としてコピーしておくとよいでしょう。 ** today コマンドラインでの予定一覧表示ツールです。today と単に打つと、 今日の予定が表示されますが、指定の日のスケジュール一覧表示をすることも できます。 today には次のようなオプションが使えます。 --format=html/ps スケジュールを HTML や PostScript (のカレンダー) 形式で出力します。 --category=CATEGORY 指定のカテゴリのみを出力することができます。 "!CATEGORY" とすると、指定のカテゴリのみの出力抑制ができます。 --date=[string][+n] 表示したい日付とその範囲を指定します。 string に指定できるのは、 today, tomorrow, sun ... sat, yyyymmdd, yymm です。以下によく使われると思われる date の指定を挙げておきます。 --date=today+1 今日から明日まで --date=200007 2000年 7月の一ヶ月分 --format=ps の場合は、これを指定したいでしょう --date=mon+6 今週一週間のスケジュール --mail=ADDRESS スケジュールを指定のメールアドレスに送信します。 cron などで、毎日自分宛にスケジュールを送ると便利でしょう。 ** gemcal gemcal は、MHC の GUI です。 閲覧、入力、アラームの発行等することができ、これ単体でもスケジュールアプ リケーションとして機能するようになっています。入力は mhc からの方が便利 かもしれません。日程の変更等は gemcal の方が便利かもしれません。 ruby/gtk で書かれています。ruby の 1.4.2 + FreeBSD 3.3 / Solaris 2.6 で は正常に動くことを確認しています。ruby-gtk は 0.21 以降で使って下さい。 gemcal -g +X+Y geometory の指定 X と Y には数値が入ります。 + の代わりに - は使えません。 -r dir MHC のデータを保存しているディレクトリを指定します。 デフォルトは ~/Mail/schedule です。 -d +X+Y 一ヶ月カレンダーと同時に日めくり(DayBook) を最初から表示 します。 -f 祭日等を書いた定数ファイルを指定します。 デフォルトは ~/.schedule です。 通常は、単に、 % gemcal & として起動すればいいでしょう。あとは想像して下さい。 1ヶ月表示ウィンドウを最大化すると、各日付の予定を参照することができます。 ** mhc-sync の使い方 mhc-sync は、NotePC とデスクトップといった、MHC を利用している 2台の PC 間のスケジュールの同期を取るコマンドです。mhc-sync と叩くと usage が出ます。 以下を行う前に、バックアップをきちんと取りましょう。 1. notepc, server の 2台のマシンがあるとします。双方で mhc-sync, ssh が使 えるようにしておきます。 ruby-ext/lib もインストールしましょう。 2. 古い mhc で作ったアーティクルには、X-SC-Record-Id がないもの がありま す。まず、全部に付けておきましょう。 コマンド create_message_id を使っ て、 % create_message_id ~/Mail/schedule/[0-9]*/[0-9]*/[0-9]* % create_message_id ~/Mail/schedule/intersect/[0-9]* のように実行します。 3. 2台の間の +schedule 以下をまったく同じにしておきます。 例えば、notepc で rsync を使って、 % rsync -a --delete server:/home/Mail/schedule/ /home/Mail/schedule のようにしておきます。 そして、db の同期のための情報を白紙にするために、.mhc-db-log という ファイルを双方ともに消しておきます。これは通常 ~/Mail/schedule/ に生成 されています。 4. notepc, server でいつも通りの操作をします。 C-cm した後に、C-cC-c で finish するのを忘れないで下さい。 (C-xC-s してセーブしないように) 5. どちらか一方のホストで、(たとえば notepc) % mhc-sync -x exchange_id user@server.host.name のように実行すると、sync が行われます。 exchange_id というのは、2台の間で sync 履歴を管理するための 識別名(合言葉) です。何でもいいですが、同じ 2 台の組み合わせ で sync するときは、常に同じでないといけません。 実行の 前に、何が起こるかだけを見たい場合は、-n オプションを使って下さい。 % mhc-sync -n -x exchange_id user@server.host.name create_message_id: -------------------------------------------------------------------- #!/usr/local/bin/ruby $last_mid_rand = 'AAAA' $last_mid_time = nil $i = 0 $DOMAIN = 'set_your_domain' def create_message_id(domain = $DOMAIN) mid_time = Time .now .strftime("%Y%m%d%H%M%S") mid_user = Process .uid .to_s if $last_mid_time && mid_time == $last_mid_time $i += 1 $last_mid_rand .succ! mid_rand = $last_mid_rand else $last_mid_rand = 'AAAA' mid_rand = $last_mid_rand $i = 0 end mid_rand += '-' + $$ .to_s $last_mid_time = mid_time return '<' + mid_time + mid_rand + '.' + mid_user + '@' + domain + '>' end while path = ARGV .shift file = File .open(path) contents = file .gets(nil) file .close if contents =~ /X-SC-Record-Id:/ print "#{path} has X-SC-Record-Id: ignored.\n" else print "add X-SC-Record-Id: to #{path}.\n" contents .sub!(/^/np, "X-SC-Record-Id: " + create_message_id() + "\n") ## contents .sub!(/\n\n/np, "\nX-SC-Record-Id: " + ## create_message_id() + "\n\n") file = File .open(path, "w") file << contents file .close end end -------------------------------------------------------------------- ** mhc2palm -- MHC のデータを Palm に転送する MHC のデータを Palm/WorkPad に転送するコマンドです。 pilot-link の libpisock を必要とします。 usage: mhc2palm [-a | -i] [-n] [-d dev] [-r dir] [YYYYMMDD-yyyymmdd] 以下のようなオプションがあります。 -v verbose mode. 実行時に色々な表示を行います。 -a Palm に MHC のデータを追加 (Append) します。 つまり全ての Palm 上のデータは保存されます。 -i Palm に MHC のデータを導入 (Install) します。 つまり全ての Palm 上のデータは消去されます。 MHC を主に使っているユーザであれば、 通常はこれを利用するでしょう。 -n 実行の過程を示すだけで、実際の転送は行いません。 mhc2palm が何をするのかを見るのに有効でしょう。 -d dev Palm と繋っているシリアルポートを指定します。 デフォルトは /dev/pilot です。 (Cygwin ユーザは /dev/com1 等になるでしょう) -r dir MHC のデータを保存しているディレクトリを指定します。 デフォルトは ~/Mail/schedule です。 YYYYMMDD-yyyymmdd MHC から転送するデータの範囲を指定します。 デフォルトは、3ヶ月前 〜 3ヶ月後です。 ** palm2mhc -- Palm のデータを MHC に転送する Palm/WorkPad のデータを MHC に転送するコマンドです。 pilot-link の libpisock を必要とします。 usage: palm2mhc [-a | -u] [-n] [-i] [-d dev] [-r dir] -a 全ての Palm のデータを MHC に追加します。 Palm ユーザが最初に MHC を使い初めるときに有効でしょう。 -u Palm のデータのうち、更新されたデータのみを MHC に 追加します。 -n 実行の過程を示すだけで、実際の転送は行いません。 palm2mhc が何をするのかを見るのに有効でしょう。 -i インタラクティブに実行します。MHC にデータを追加する各々の データについて、ユーザに確認を行います。 -d dev Palm と繋っているシリアルポートを指定します。 デフォルトは /dev/pilot です。 (Cygwin ユーザは /dev/com1 等になるでしょう) -r dir MHC のデータを保存するディレクトリを指定します。 デフォルトは ~/Mail/schedule です。 ** adb2mhc の使い方 adb2mhc は、HP200LX のスケジュールソフト用データ (adb ファイル) を MHC にコンバートするプログラムです。 % adb2mhc --mhc-dir /tmp/schedule appt.adb のようにすると、/tmp/schedule 以下に MHC 形式のファイルが多数生成されます。 ** mhc2ol -- MHC のデータを Outlook に転送する mhc2ol は、MHC のスケジュールを、Microsoft 社のスケジュール管理ソフト Outlook に転送するスクリプトです。Outlook の OLE コントロールを利用し ているため、Windows マシンでしか動きません。 詳しくは、00readme.w32.jis を参照してください。 usage: mhc2ol [-a | -i | -N] [-n] [-r dir] [-c category] [YYYYMMDD-yyyymmdd] 以下のようなオプションがあります。 -v verbose mode. 実行時に色々な表示を行います。 -a Outlook に MHC のデータを追加 (Append) します。 つまり全ての Outlook 上のデータは保存されます。 -i Outlook に MHC のデータを導入 (Install) します。 つまり全ての Outlook 上のデータは消去されます。 -N スケジュールのタイムスタンプを比較して、必要最小限 のスケジュールを Outlook に転送します。通常はこの オプションを利用します。 -n 実行の過程を示すだけで、実際の転送は行いません。 mhc2ol が何をするのかを見るのに有効でしょう。 -c Outlook に転送する MHC スケジュールのカテゴリを、 Ruby の正規表現で指定します。 -r dir MHC のデータを保存しているディレクトリを指定します。 デフォルトは ~/Mail/schedule です。 YYYYMMDD-yyyymmdd MHC から転送するデータの範囲を指定します。 デフォルトは、3ヶ月前 〜 3ヶ月後です。 yoshinari-nomura-mhc-815a36a/adb2mhc.in000066400000000000000000000274151222073515200177550ustar00rootroot00000000000000#!@@MHC_RUBY_PATH@@ # -*- ruby -*- ## adb2mhc -- Convert ADB DB of HP200LX into MHC format. ## ## Author: Yoshinari Nomura ## ## Created: 1999/11/12 ## Revised: $Date: 2003/02/24 13:20:45 $ ## require 'mhc-date' require 'mhc-schedule' require 'kconv' class Appt WEEK = %w(Mon Tue Wed Thu Fri Sat Sun) MONTH = %w(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec) ORDER = %w(1st 2nd 3rd 4th last) REPEAT = %w(none daily weekly monthly yearly custom) def appt?; !todo? ; end def todo?; @appt_or_todo_flag & 16 != 0; end ################################################################ def initialize(raw_record) record_length, # 0 2 record length. category_offset, # 2 2 offset to category data in this record. location_offset, # 4 2 offset to location data in this record. repeat_offset, # 6 2 offset to repeat data in this record. @linked_note_number, # 8 2 linked note record no. previous_record_number, #10 2 always -1 (or 65535) ? next_record_number, #12 2 always -1 (or 65535) ? appt_or_todo_flag, #14 1 appointment or todo data. start_date, #15 3 packed 3 bytes (year-1900,month-1,day-1) difference, #18 8 used differently appoint from todo. repeat_status, #26 1 1:none, 2:daily, 4:monthly ... #27 * include description, category, location, # repeatinfo. trailer = raw_record .unpack("vvvvvvvCa3a8Ca*") @repeat_status = bit_to_string(repeat_status, REPEAT) @appt_or_todo_flag = appt_or_todo_flag @start_date = bit_to_date(start_date) @description, ## @category, ## @location, ## repeat_info = trailer .unpack(format("A%d A%d A%d a%d", category_offset - 27, location_offset - category_offset, repeat_offset - location_offset, record_length - repeat_offset)) # AppointOrTodoFlag is used like bellow # # Bit Appointment ToDo # # 0(LSB) Alarm Don't care # 1 MonthView Completed # 2 WeekView Carry forward # 3 # 4 This-record-is-TODO. # 5 This-record-is-Appointment. # if todo? ## The record is todo. @todo_priority , ## @todo_due_days, ## complete_date = difference .unpack("A2va3x") @todo_completed = (@appt_or_todo_flag & 2 != 0) @todo_complete_date = bit_to_date(complete_date) else ## The record is appointment start_time, #18 2 minute of the start time. hour is minute/60. consecutive, #20 2 no of consecutive days. end_time, #22 2 minute of the end time. hour is minute/60. #24 2 lead time in minute. appt_lead_time = difference .unpack("vvvv") @appt_lead_time = @appt_or_todo_flag & 1 != 0 ? appt_lead_time : nil @appt_start_time = bit_to_time(start_time) @appt_consecutive = consecutive + 1 @appt_end_time = bit_to_time(end_time) end ################################################################ ## unpack repeat info. if @repeat_status == 'none' return self end repeat_freqency, ## repeat_param1, ## repeat_param2, ## repeat_month, ## repeat_start_date, ## repeat_end_date, ## repeat_delete_count, ## repeat_delete_dates = repeat_info .unpack("cCCva3a3ca*") if @repeat_status != 'custom' @repeat_freqency = repeat_freqency end if repeat_param1 & 0x80 != 0 ## repeat by order and week. @repeat_day = bit_to_tag(repeat_param1, WEEK) @repeat_week = bit_to_tag(repeat_param2, ORDER) else ## repeat by day number. @repeat_day = repeat_param1 ## param2 is abandoned. end @repeat_month = bit_to_tag(repeat_month, MONTH) @repeat_start_date = bit_to_date(repeat_start_date) @repeat_end_date = bit_to_date(repeat_end_date) if repeat_delete_count > 0 len = repeat_delete_dates .length ary= repeat_delete_dates .unpack("a3x" * (len / 4)) @repeat_delete_dates = ary .collect{|a| bit_to_date(a)} end end def dump print "linked_note_number #{@linked_note_number} \n" ## Integer print "appt_or_todo_flag #{@appt_or_todo_flag} \n" ## Bitfield print "description #{@description} \n" ## String print "category #{@category} \n" ## String print "location #{@location} \n" ## String print "start_date #{@start_date} \n" ## MhcDate print "appt_consecutive #{@appt_consecutive} \n" ## Integer print "appt_start_time #{@appt_start_time} \n" ## MhcTime print "appt_end_time #{@appt_end_time} \n" ## MhcTime print "appt_lead_time #{@appt_lead_time} \n" ## Integer print "repeat_status #{@repeat_status} \n" ## String one of 'none', 'weekly' ... print "repeat_freqency #{@repeat_freqency} \n" ## Integer print "repeat_start_date #{@repeat_start_date} \n" ## MhcDate print "repeat_end_date #{@repeat_end_date} \n" ## MhcDate print "repeat_month #{@repeat_month} \n" ## Array of String 'Jan', 'Feb' ... print "repeat_week #{@repeat_week} \n" ## Array of String 'Sun', 'Mon' ... print "repeat_day #{@repeat_day} \n" ## Integer print "repeat_delete_dates #{@repeat_delete_dates} \n" ## Integer print "todo_complete_date #{@todo_complete_date} \n" ## MhcDate print "todo_due_days #{@todo_due_days} \n" ## Integer print "todo_priority #{@todo_priority} \n" ## String print "\n\n" end def to_mhc if todo? STDERR .print "Warn: Todo records are not supported... ignored.\n" return nil end if (@repeat_status && @repeat_status != 'daily') and (@repeat_freqency && @repeat_freqency > 1) STDERR .print "Warn: Records such as freqency > 1 are not supported... ignored.\n" return nil end if @description =~ /\|/ STDERR .print "Warn: Cron job is not supported... ignored.\n" return nil end ## X-SC-Subject: @description ## X-SC-Category: @category ## X-SC-Location: @location ## X-SC-Day: !@repeat_delete_date + ## @start_date if @repeat_status = 'none' ## X-SC-Time: @appt_start_time - @appt_end_time or '' ## X-SC-Cond: @repeat_month @repeat_week @repeat_day ## X-SC-Duration: @repeat_start_date - @repeat_end_date or '' x_sc_subject = Kconv::tojis(@description) x_sc_category = Kconv::tojis(@category) x_sc_alarm = @appt_lead_time ? @appt_lead_time .to_s + ' minute' : '' x_sc_time = @appt_start_time ? [@appt_start_time, @appt_end_time] .join('-') : '' x_sc_day = '' if @repeat_status == 'daily' && @repeat_freqency i = @repeat_start_date while (i <= @repeat_end_date) x_sc_day += "#{i} " i = i .succ(@repeat_freqency) end elsif @repeat_status == 'none' x_sc_day = @start_date .to_s end x_sc_day += ' ' + (@repeat_delete_dates ? @repeat_delete_dates .collect{|date| '!' + date .to_s} .join(' ') : '') x_sc_cond = ((@repeat_month || []) + (@repeat_week || []) + (@repeat_day || [])) .join(' ') x_sc_duration = (@repeat_start_date || @repeat_end_date) ? "#{@repeat_start_date}-#{@repeat_end_date}" : '' header = [ "X-SC-Subject: " + x_sc_subject, "X-SC-Category: " + x_sc_category, "X-SC-Day: " + x_sc_day, "X-SC-Time: " + x_sc_time, "X-SC-Cond: " + x_sc_cond, "X-SC-Alarm: " + x_sc_alarm, "X-SC-Duration: " + x_sc_duration ] .join("\n") + "\n" MhcScheduleItem .new(header, false) end ################################################################ ## private private def bit_to_tag(bit, tag) ret, i = [], 1 tag .each{|str| if bit & i != 0 ret << str end i <<= 1 } return ret end def bit_to_string(bit, tag) ret, i = [], 1 tag .each{|str| return str if bit & i != 0 i <<= 1 } return nil end def bit_to_time(bit) if bit == 65535 return nil else return MhcTime .new(bit / 60, bit % 60) end end def bit_to_date(bit) y, m, d = bit .unpack("CCC") return MhcDate .new(y + 1900, m + 1, d + 1) end end def usage(do_exit = true) STDERR .print "usage: adb2mhc [options] adb_files... Convert ADB DB of HP200LX into MHC format. --help show this message. --mhc-dir set repository dir of MHC. it is good idea to set empty dir. default: ~/Mail/schedule\n" exit if do_exit end ################################################################ ## main while ARGV[0] =~ /^-/ case (ARGV[0]) when /^--mhc-dir=(.+)/ mhc_dir = $1 ARGV .shift else usage() end end mhc_db = MhcScheduleDB .new(mhc_dir || File .expand_path("~/Mail/schedule")) adb_file = File .open(ARGV[0]) db_type = adb_file .read(4) .chop if db_type != 'hcD' STDERR .print "Error: Unknown file type #{db_type}... aborted.\n" exit end while (header = adb_file .read(6)) type, status, length, no = header .unpack("CCvv") exit if length <= 6 if ((field = adb_file .read(length - 6)) .length != length - 6) STDERR .print "Error: ADB file format error... aborted.\n" exit end next if status & 0x01 != 0 # This field is obsolete. ## print "#{type}, #{status}, #{length}, #{no}\n" case type when 9 STDERR .print "Warn: Attached note records are not supported... ignored.\n" ## Note reocrd. next when 11 appt_item = Appt .new(field) mhc_sch = appt_item .to_mhc if mhc_sch print "----------------------------------------------\n" print mhc_sch .dump mhc_db .add_sch(mhc_sch) end else next end end ### Copyright Notice: ## Copyright (C) 1999, 2000 Yoshinari Nomura. All rights reserved. ## Copyright (C) 2000 MHC developing team. All rights reserved. ## Redistribution and use in source and binary forms, with or without ## modification, are permitted provided that the following conditions ## are met: ## ## 1. Redistributions of source code must retain the above copyright ## notice, this list of conditions and the following disclaimer. ## 2. Redistributions in binary form must reproduce the above copyright ## notice, this list of conditions and the following disclaimer in the ## documentation and/or other materials provided with the distribution. ## 3. Neither the name of the team nor the names of its contributors ## may be used to endorse or promote products derived from this software ## without specific prior written permission. ## ## THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' ## AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ## LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ## FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ## THE TEAM OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ## INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ## (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ## SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ## HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, ## STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ## ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED ## OF THE POSSIBILITY OF SUCH DAMAGE. ### adb2mhc ends here yoshinari-nomura-mhc-815a36a/configure.rb000066400000000000000000000064411222073515200204270ustar00rootroot00000000000000#!/usr/local/bin/ruby ## configure.rb -- Guess values for system-dependent variables. ## ## Author: MIYOSHI Masanori ## Yoshinari Nomura ## Created: 2000/7/12 ## Revised: $Date: 2006/12/18 06:50:14 $ $LOAD_PATH .unshift('.') require 'mhc-make' include MhcMake ################################################################a ## local configuralbe flags. local_config_table = [ ['--disable-palm', '@@MHC_DISABLE_PALM@@', GetoptLong::NO_ARGUMENT, "do not require pilot-link", ''], ['--pilot-link-lib', '@@MHC_PILOT_LINK_LIB@@', GetoptLong::REQUIRED_ARGUMENT, "=DIR pilot-link lib in DIR", ''], ['--pilot-link-inc', '@@MHC_PILOT_LINK_INC@@', GetoptLong::REQUIRED_ARGUMENT, "=DIR pilot-link header in DIR", ''], ['--with-mew', '@@MHC_WITH_MEW@@', GetoptLong::NO_ARGUMENT, "use mhc with Mew.", ''], ['--with-wl', '@@MHC_WITH_WL@@', GetoptLong::NO_ARGUMENT, "use mhc with Wanderlust.", ''], ['--with-gnus', '@@MHC_WITH_GNUS@@', GetoptLong::NO_ARGUMENT, "use mhc with Gnus.", ''], ['--with-cmail', '@@MHC_WITH_CMAIL@@', GetoptLong::NO_ARGUMENT, "use mhc with cmail.", ''], ['--with-icondir', '@@MHC_XPM_PATH@@', GetoptLong::REQUIRED_ARGUMENT, "=DIR mhc icon directory.", ''] ] conf = MhcConfigure .new(local_config_table) .parse_argv # XXX: ukai if conf['@@MHC_XPM_PATH@@'] == '' conf['@@MHC_XPM_PATH@@'] = conf['@@MHC_LIBDIR@@'] + '/mhc/xpm' end ################################################################ ## command check conf .search_command('ruby', '@@MHC_RUBY_PATH@@', false, true) conf .search_command('emacs', '@@MHC_EMACS_PATH@@', false, false) conf .search_command('emacs', '@@MHC_FSF_EMACS_PATH@@', false, false) conf .search_command('xemacs', '@@MHC_XEMACS_PATH@@', false, false) conf .search_command('make', '@@MHC_MAKE_PATH@@', false, true) ################################################################ ## lib check lib_search_path = ['/usr/local/lib', '/usr/local/pilot/lib', '/usr/lib', '/usr/pkg/lib'] inc_search_path = ['/usr/local/include', '/usr/local/pilot/include', '/usr/include/libpisock', '/usr/include', '/usr/pkg/include'] if conf['@@MHC_DISABLE_PALM@@'] == '' conf .search_library(lib_search_path, 'pisock', 'pi_socket', '@@MHC_PILOT_LINK_LIB@@', false, false) conf .search_include(inc_search_path, 'pi-dlp.h', '@@MHC_PILOT_LINK_INC@@', false, false) end ################################################################ ## replace keywords. infile_list = [ 'mhc-sync.in:0755', 'mhc2palm.in:0755', 'palm2mhc.in:0755', 'adb2mhc.in:0755', 'gemcal.in:0755', 'make.rb.in:0755', 'today.in:0755', 'emacs/make.rb.in:0755', 'ruby-ext/lib/mhc-gtk.rb.in:0644', 'ruby-ext/extconf.rb.in:0755' ] if /cygwin|mingw32/ =~ RUBY_PLATFORM infile_list << 'mhc2ol.in:0755' end file = File .open('configure.log', 'w') conf .each_macro{|key, val| file .print format("%-30s => %s\n", key, val) } conf .replace_keywords(infile_list) print "In ruby-ext/\n" Dir .chdir('ruby-ext') #make_system('ruby extconf.rb') make_system("#{conf['@@MHC_RUBY_PATH@@']} extconf.rb") exit 0 yoshinari-nomura-mhc-815a36a/emacs/000077500000000000000000000000001222073515200172045ustar00rootroot00000000000000yoshinari-nomura-mhc-815a36a/emacs/MHC-MK000066400000000000000000000316751222073515200200570ustar00rootroot00000000000000;;; MHC-MK --- installer for MHC. -*-Emacs-Lisp-*- ;; Author: TSUCHIYA Masatoshi , ;; Yuuichi Teranishi ;; Created: 2000/06/13 ;; Revised: $Date: 2007/01/11 01:25:06 $ ;;; Commentary: ;; This is a installer for MHC. ;; To install MHC with UNIX like system, edit Makefile appropriately ;; and just type the following command: ;; ;; make install ;; ;; In the case when `make' is unusable, try this command: ;; ;; MeadowNT(95).exe -batch -q -no-site-file -l MHC-MK -f make-mhc-install ;; ;; It accepts some options, which are used to coordinate installation ;; path and so on. ;;; Options: ;; --with-lispdir=DIR ;; emacs lisp files go to DIR. ;; ;; --with-packagedir=DIR ;; emacs lisp files as package go to DIR. ;; ;; --with-addpath=PATH ;; add PATH, colon separated directories list, to `load-path' ;; to search additional emacs lisp libraries. ;; ;; --with-mew ;; use MHC with Mew. ;; ;; --with-wl ;; use MHC with Wanderlust. ;; ;; --with-gnus ;; use MHC with Gnus. ;;; Code: ;;; Configuration variables. (defvar make-mhc/module-prefix "mhc") (defvar make-mhc/module-alist '(("mhc" . t) ("mhc-calendar" . t) ("mhc-compat" . t) ("mhc-cvs" . t) ("mhc-date" . t) ("mhc-day" . t) ("mhc-db" . t) ("mhc-face" . t) ("mhc-file" . t) ("mhc-guess" . t) ("mhc-header" . t) ("mhc-logic" . t) ("mhc-minibuf" . t) ("mhc-misc" . t) ("mhc-parse" . t) ("mhc-ps" . t) ("mhc-record" . t) ("mhc-schedule" . t) ("mhc-slot" . t) ("mhc-summary" . t) ("mhc-sync" . t) ("mhc-vars" . t) ("mhc-draft" . t) ("mhc-e21" . (and (not (featurep 'xemacs)) (>= emacs-major-version 21))) ("mhc-bm" . (locate-library "bitmap")) ("mhc-xmas" . (featurep 'xemacs)) ("mhc-mew" . (and (locate-library "mew") make-mhc/with-mew)) ("mhc-wl" . (and (locate-library "wl") make-mhc/with-wl)) ("mhc-gnus" . (and (locate-library "gnus") make-mhc/with-gnus)) ("mhc-mime" . (or (and (locate-library "gnus") (locate-library "mime-edit") make-mhc/with-gnus) (and (locate-library "wl") make-mhc/with-wl))) ("nnmhc" . (and (locate-library "gnus") make-mhc/with-gnus)) )) (defvar make-mhc/lisp-directory (expand-file-name (concat (cond ((featurep 'meadow) "") ((and (not (featurep 'xemacs)) (or (>= emacs-major-version 20) (and (= emacs-major-version 19) (> emacs-minor-version 28)))) "share/") (t "lib/")) (cond ((featurep 'xemacs) (if (featurep 'mule) "xmule/" "xemacs/")) ((boundp 'MULE) "mule/") ((featurep 'meadow) "") (t "emacs/")) "site-lisp/" make-mhc/module-prefix) (cond ((featurep 'meadow) (expand-file-name "../.." exec-directory)) ((or (<= emacs-major-version 18) (featurep 'xemacs) (and (boundp 'system-configuration-options) ; 19.29 or later (string= system-configuration-options "NT"))) ; for NTEmacs (expand-file-name "../../.." exec-directory)) (t (expand-file-name "../../../.." data-directory))))) (defvar make-mhc/package-directory (if (boundp 'early-packages) (let ((dirs (append (if early-package-load-path early-packages) (if late-package-load-path late-packages) (if last-package-load-path last-packages))) dir) (while (not (file-exists-p (setq dir (car dirs)))) (setq dirs (cdr dirs))) dir))) (defvar make-mhc/source-directory default-directory) (defvar make-mhc/icon-source-directory (expand-file-name "../icons" make-mhc/source-directory)) (defvar make-mhc/with-mew nil) (defvar make-mhc/with-wl nil) (defvar make-mhc/with-gnus nil) (defvar make-mhc/debug nil) (defvar make-mhc/configured-p nil) (defun make-mhc/split-string (string &optional separators) (or separators (setq separators "[ \f\t\n\r\v]+")) (let (list (start 0)) (while (string-match separators string start) (or (= start (match-beginning 0)) (setq list (cons (substring string start (match-beginning 0)) list))) (setq start (match-end 0))) (nreverse (if (= start (length string)) list (cons (substring string start) list))))) (defun make-mhc/configure () (defvar command-line-args-left) ; Avoid 'free variable' warning (or make-mhc/configured-p (let (str) (setq make-mhc/configured-p t) (while (setq str (prog1 (car command-line-args-left) (setq command-line-args-left (cdr command-line-args-left)))) (cond ((string= "-n" str) (setq make-mhc/debug t)) ((string-match "^--with-lispdir=" str) (setq make-mhc/lisp-directory (substring str (match-end 0)))) ((string-match "^--with-packagedir=" str) (setq make-mhc/package-directory (substring str (match-end 0)))) ((string-equal "--with-mew" str) (setq make-mhc/with-mew t)) ((string-equal "--with-wl" str) (setq make-mhc/with-wl t)) ((string-equal "--with-gnus" str) (setq make-mhc/with-gnus t)) ((string-match "^--with-addpath=" str) (mapcar (lambda (dir) (if (file-directory-p dir) (or (member dir load-path) (setq load-path (cons dir load-path))))) (make-mhc/split-string (substring str (match-end 0)) ":"))) (t (error "Illegal option")))) ; (let ((gnus-path-file (expand-file-name "~/.lpath.el"))) ; (and make-mhc/with-gnus ; (file-exists-p gnus-path-file) ; (load-file (expand-file-name gnus-path-file)))) (setq load-path (cons make-mhc/source-directory load-path)) (or make-mhc/debug (setq make-mhc/debug (let ((flag (getenv "MAKEFLAGS")) (case-fold-search nil)) (if flag (string-match "^\\(\\(--[^ ]+ \\)+-\\|[^ =-]\\)*n" flag)))))))) (defun make-mhc-compile () (make-mhc/configure) ;; Delete old *.elc files. (mapcar (lambda (module) (let ((el-file (expand-file-name (concat module ".el") make-mhc/source-directory)) (elc-file (expand-file-name (concat module ".elc") make-mhc/source-directory))) (if (and (file-exists-p elc-file) (file-newer-than-file-p el-file elc-file)) (delete-file elc-file)))) (mapcar 'car make-mhc/module-alist)) ;; Byte compile all *.el files. (require 'mhc) (mapcar (lambda (module) (let ((el-file (expand-file-name (concat module ".el") make-mhc/source-directory)) (elc-file (expand-file-name (concat module ".elc") make-mhc/source-directory))) (if (or (not (file-exists-p elc-file)) (if (file-newer-than-file-p el-file elc-file) (progn (delete-file elc-file) t))) (if make-mhc/debug (princ (format "Byte compile: %s -> %s.\n" (file-name-nondirectory el-file) (file-name-nondirectory elc-file))) (byte-compile-file el-file))))) (delq nil (mapcar (lambda (pair) (if (eval (cdr pair)) (car pair))) make-mhc/module-alist)))) (defun make-mhc/make-directory (dirname) (if (file-directory-p dirname) t (if (make-mhc/make-directory (directory-file-name (file-name-directory (directory-file-name dirname)))) (progn (make-directory dirname) t)))) (defun make-mhc/install-file (in-file out-file) (if (file-exists-p in-file) (progn (princ (format "%s%s -> %s\n" (if make-mhc/debug "Install: " "") (file-name-nondirectory in-file) out-file)) (or make-mhc/debug (progn (if (file-exists-p out-file) (delete-file out-file)) (copy-file in-file out-file t t)))))) (defun make-mhc-install () (make-mhc-compile) (or make-mhc/debug (make-mhc/make-directory make-mhc/lisp-directory)) (mapcar (lambda (module) (make-mhc/install-file (expand-file-name (concat module ".el") make-mhc/source-directory) (expand-file-name (concat module ".el") make-mhc/lisp-directory)) (make-mhc/install-file (expand-file-name (concat module ".elc") make-mhc/source-directory) (expand-file-name (concat module ".elc") make-mhc/lisp-directory))) (mapcar 'car make-mhc/module-alist))) ;; For XEmacs package system. (defun make-mhc-compile-package () (make-mhc/configure) (setq make-mhc/lisp-directory (expand-file-name make-mhc/module-prefix (expand-file-name "lisp" make-mhc/package-directory))) (make-mhc-compile)) (defun make-mhc/update-package-files (package dir) (cond (make-mhc/debug (princ (format "Updating autoloads in directory %s..\n\n" dir)) (princ (format "Processing %s\n" dir)) (princ "Generating custom-load.el...\n\n") (princ (format "Compiling %s...\n" (expand-file-name "auto-autoloads.el" dir))) (princ (format "Wrote %s\n" (expand-file-name "auto-autoloads.elc" dir))) (princ (format "Compiling %s...\n" (expand-file-name "custom-load.el" dir))) (princ (format "Wrote %s\n" (expand-file-name "custom-load.elc" dir)))) (t (setq autoload-package-name package) (let ((command-line-args-left (list dir))) (batch-update-directory)) (let ((command-line-args-left (list dir))) (Custom-make-dependencies)) (byte-compile-file (expand-file-name "auto-autoloads.el" dir)) (byte-compile-file (expand-file-name "custom-load.el" dir))))) (defun make-mhc-install-package () (make-mhc-compile-package) (make-mhc/update-package-files make-mhc/module-prefix dir) (or make-mhc/debug (make-mhc/make-directory make-mhc/lisp-directory)) (mapcar (lambda (module) (make-mhc/install-file (expand-file-name (concat module ".el") make-mhc/source-directory) (expand-file-name (concat module ".el") make-mhc/lisp-directory)) (make-mhc/install-file (expand-file-name (concat module ".elc") make-mhc/source-directory) (expand-file-name (concat module ".elc") make-mhc/lisp-directory))) (append (mapcar 'car make-mhc/module-alist) ;; Add XEmacs package stuff. (list "auto-autoloads" "custom-load"))) ;; Install icons. (let ((icon-dir (expand-file-name make-mhc/module-prefix (expand-file-name "etc" make-mhc/package-directory)))) (or make-mhc/debug (make-mhc/make-directory icon-dir)) (mapcar (lambda (icon) (make-mhc/install-file icon (expand-file-name (file-name-nondirectory icon) icon-dir))) (directory-files make-mhc/icon-source-directory t "^.*\\.xpm$")))) ;;; Copyright Notice: ;; Copyright (C) 2000 MHC developing team. All rights reserved. ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of the team nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' ;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ;; THE TEAM OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, ;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED ;; OF THE POSSIBILITY OF SUCH DAMAGE. ;;; MHC-MK ends here yoshinari-nomura-mhc-815a36a/emacs/Makefile000066400000000000000000000016611222073515200206500ustar00rootroot00000000000000# -*- Makefile -*- # MEW_OPTS = --with-mew # WL_OPTS = --with-wl # GNUS_OPTS = --with-gnus ## To change install directory. # INST_OPTS = --with-lispdir=/usr/local/share/emacs/site-lisp/mhc ## To add paths of additional emacs-lisp libraries. # INST_OPTS = --with-addpath=/foo:/bar:/baz EMACS = emacs XEMACS = xemacs FLAGS = -batch -q -no-site-file -l MHC-MK OPTS = $(INST_OPTS) $(MEW_OPTS) $(WL_OPTS) $(GNUS_OPTS) elc: $(EMACS) $(FLAGS) -f make-mhc-compile $(OPTS) install: $(EMACS) $(FLAGS) -f make-mhc-install $(OPTS) # $(MAKE) package: $(XEMACS) $(FLAGS) -f make-mhc-compile-package $(OPTS) install-package: $(XEMACS) $(FLAGS) -f make-mhc-install-package $(OPTS) # $(MAKE) clean: -rm -f *.elc auto-autoloads.el custom-load.el ### Suffix rules .SUFFIXES: .elc .el .el.elc: -rm -f $@ $(EMACS) -batch -q -no-site-file \ -eval '(setq load-path (cons default-directory load-path))' \ -l mhc.el -f batch-byte-compile $< yoshinari-nomura-mhc-815a36a/emacs/README.ja000066400000000000000000000423061222073515200204620ustar00rootroot00000000000000################################################################ README.ja ################################################################ Created: 1999-04-07 Revised: 2002-12-01 mhc の使いかた 0. はじめに mhc は、仕事や、遊びの予定がメールで入ってくる人のための、「メール から直にスケジュール登録ができないか ?」 という要求を満たすための ものです。 mhc は、Mew や Wanderlust, Gnus に寄生するマイナーモードです。 1. インストール # perl script の mscan は ver 0.23 から必要なくなりました。 1. *.el をロードパスの通ったところに置きます。 2. スケジュールを入れるフォルダを作成します。 例えば mkdir -p ~/Mail/schedule としたとします。 Mew 等からはこの場所が +schedule というフォルダに見えるとします。 3. .emacs に以下のように記述します。 Mew (1.94以降) のユーザ: (autoload 'mhc-mew-setup "mhc-mew") (add-hook 'mew-init-hook 'mhc-mew-setup) Wanderlust (2.2.10以降) のユーザ: (autoload 'mhc-wl-setup "mhc-wl") (add-hook 'wl-init-hook 'mhc-wl-setup) Gnus のユーザ: (autoload 'mhc-gnus-setup "mhc-gnus") (add-hook 'gnus-startup-hook 'mhc-gnus-setup) を加えます。また、ディレクトリ構成に設定に応じて、必要であれば、 (setq mhc-base-folder "+schedule") (setq mhc-mail-path (expand-file-name "/home/hoge/Mail")) のように、ベースとなるフォルダとメールディレクトリを設定します。 mhc は mhc-base-folder 以下をスケジュールの保存に使います。 4. 必要なら sample として付属している、日本の祝日を記述した DOT.schedule.sample をコピーします。 cp somewhere/DOT.schedule.sample ~/.schedule 5. 念のために emacs を立ち上げなおします。 2. 使い方 mew から、メールを読みながら、以下のような記事に遭遇したとします。 行こうと思っているので、忘れないようにスケジュールにつけたいとしま す。 ----------------------------------------------------------------------- WIDE-July'94 研究会プログラム ---------------------------- 1. 日時： 1994年 7月 9日(土) 10:00 - 17:00 2. 場所： 早稲田大学 大久保キャンパス 55号館N棟 1F 大会議室 3. プログラム： 10:00 - 10:40 トンネリングを含んだネットワークにおける 経路制御について (30) : ----------------------------------------------------------------------- C-c. | を入力してみてください。この記事でいいかどうか聞かれた後、 日付を推測してくれます。その際、本文の日付部分が反転します。 間違っていたら C-n か C-p で反転部分を移動します。 minibuffer には対応する日付けが入力された状態になります。 そのまま minibuffer に日付けを入力することもできます。 日付けの入力の仕方は、「3. 日付入力の方法」 を参照してください。 最後に、見出しを入力した所でドラフトが用意されます。 ドラフトでそのまま C-cC-c で登録されます。 今月の予定を見てみましょう。C-c. . を入力してください。さっき入力し たスケジュールが入っているはずです。そこまでポイントをもっていって、 . や SPC を押すと詳しい内容が表示されるでしょう。 この状態から、 C-c. . 今月の予定を見る C-c. n 次の月の予定を見る C-c. p 前の月の予定を見る C-c. g 好きな月にジャンプ C-c. s その月をスキャンしなおす で、各種移動を行うことができます。 当然、メールからではなく、直にスケジュールを入力したいこともあるで しょう。今月の 15日に歯医者に行くのを入力するときは、 C-c. . で今月の予定表フォルダに行って、15日のところにポインタをあわ せます。 C-c. e を入力します。時間を入力します。X-SC-Subject に見出しを付け て、あとは、好きなことを書いてください。 C-c C-c で登録されました。 一度入力したものに対して、修正を加えたい場合があります。その時は、 C-c. e のかわりに、C-c. m を入力してください。あとは、C-c C-c で修正 されます。 キー操作をまとめると、以下のようになります C-c. . 今月の予定を見る C-c. n 次の月の予定を見る C-c. p 前の月の予定を見る C-c. g 好きな月にジャンプ C-c. s その月をスキャンしなおす C-c. f 今日にカーソルを合わせる (今月の予定を表示中のみに有効) C-c. R mhc をリセットして、初期化する C-c. | 表示中のメールをスケジュールに登録 C-c. d カーソル行のスケジュールを消去する C-c. m カーソル行のスケジュールに変更を加える C-c. e スケジュールの新規入力 C-c. c カテゴリーの指定 (後述) C-c. P スケジュールの PostScript データを作成する C-c. t 3ヶ月カレンダーの表示をトグルする C-c. ? Emacs 標準の Calender like な3ヶ月カレンダーを表示する (mhc-calendar-mode といいます。この mode の説明は xxxxx とりあえず、M-x describe-mode して調べてください ^^;) C-c.T ONLINE/OFFLINE の状態を切り替える C-c.S 他の mhc データと同期する Ruby Script の mhc-sync または cvs が利用できる C-c.p C-c.n は prefix arg で、何ヶ月進む/戻るを指定できます。 C-c.s は prefix arg で、Private カテゴリのサブジェクトを別な文字列 に変えることができます。 上述のキー操作の 'C-c.' の部分は mhc-prefix-key という変数で指定する ことができます。もし、'C-c.' で今月の予定が見たい、'C-ce' でスケジュー ルの新規入力がしたいという様に prefix を 'C-c' にしたいときは、~ /.emacs に以下の行を書いてください。 (setq mhc-prefix-key "\C-c") 3. 日付入力の方法 draft-buffer から X-SC-* を直に編集: X-SC-Day: X-SC-Time: X-SC-Duration: X-SC-Cond: X-SC-Alarm: X-SC-Day: には、19990409 のように、日付をスペースで区切って、 複数入力することができるようになっています。 X-SC-Day: 19990409 19990413 … 1999年4月9日と 13日 X-SC-Time: には 12:00-13:00 や 19:00 のように時間を入力します。 祝日のように時間が指定できないイベントは、空白にしておくことも できます。 X-SC-Duration: には、19990409-19990430 のように、 期間を入力できるようになっています。 終わりか始めのどちらかを省略してもかまいません。 (例: 19991121-) ただしこれで指定した期間は、 X-SC-Day: X-SC-Cond: で指定した条件をより限定するために使われ るので、X-SC-Duration: だけではイベントを記述できません。 空白にしておくと特に Duration では制限を設けないことを意味します。 X-SC-Cond: は、以下のキーワードを記述することができます。 00-31 月の内の日を表す数字 1st 2nd 3rd 4th 5th Last 週を表す序数 Sun Mon ... Sat 曜日を表す Jan Feb ... Dec 月を表す X-SC-Cond: Tue Fri 毎週火曜と金曜 X-SC-Cond: 31 Aug 毎年 8月 31日 X-SC-Cond: 1st 3rd Fri 第1,3 金曜日 X-SC-Cond: Fri X-SC-Day: !19990409 毎週金曜日。ただし 4/9 は除く X-SC-Cond: Fri 13 13日の金曜日ではなくて、 毎月13日と毎週金曜日 minibuffer から: Date: (yyyy/mm/dd): の場所では、 1999/4/5 のように入力できます。スペースで区切って、複数を入力 することができます。yyyy や mm を省略した場合は、 先頭の日付に関しては、現在の 年と月が仮定されます。 2番目以降は、1つ前の日付の年と月が仮定されます。 `-' で区切って連続する何日かを指定することも可能です。 minibuffer からは、 繰り返しの条件等を入力できません。 とりあえず開始時間を適当に入れて、draft-buffer で編集して下さい。 .schedule に記述 祝日や記念日のように、おそらく変更がないようなイベントは、 ~/.schedule に入力しておくこともできます。 X-SC-Cond: Sep 19 X-SC-Subject: 結婚記念日 sample として、DOT.schedule.sample を付けています。 4. スケジュール情報の保存場所 通常のスケジュールの情報は、+schedule/yyyy/mm に保存されるよう になっています。(例えば +schedule/1999/04) しかし、月にまたがるような繰り返しのスケジュールを +schedule/yyyy/mm に入れてしまうと、他の月をスキャンしたときに 見えなくなってしまうので、月をまたがるようなスケジュールは、 +schedule/intersect というフォルダに全部入れることになっていま す。したがって、 yyyy年 mm月のスケジュールは、 ~/.schedule +schedule/yyyy/mm +schedule/intersect の 3箇所から検索します。 +schedule/yyyy/mm と +schedule/intersect のどっちに入れ るかは、C-cC-c したときに X-SC-Date: や X-SC-Cond: をパー ズして決定してやるようになっています。 5. スケジュールの消去 C-c. d でスケジュールの消去をすると、現在のところ、 +schedule/trash に移動するようになっています。 繰り返しのスケジュールの場合、'y' 'y' と答えると、 全部がいっぺんに見えなくなってし まうので、気を付けてください。 1回分だけ消したい場合は、'y' 'n' と答えましょう。 C-c. m して、X-SC-Day: に外したい日に該当する !yyyymmdd を追加した状態になります。 6. X-SC-Category: X-SC-Category: には、空白で区切ったキーワードを入力することが できます。ユーザが自由に設定できます。大文字小文字の区別はあり ません。 現在は、DOT.schedule.sample の中で Holiday というカテゴリ名を 使っています。 C-c.c で、mhc が表示する項目をカテゴリによって限定することができます。 Private や Leisure というカテゴリを設定している人は、 (setq mhc-default-category "!(private || leasure)") と書いておくと、普段は private と leasure についての表示を Summary に出しません。仕事に生きる人は、 (setq mhc-default-category "work") としておくとよいでしょう。:-) Private というカテゴリは C-uC-c.s のときに特別な意味を発揮します。 Private というカテゴリのスケジュールがあるバッファで C-uC-c.s してみましょう。他人に見せたくないサブジェクト が違う文字列に変わったはずです。 7. X-SC-Alarm: mhc.el 自体は Alarm によって何かを知らせてくれたりは (まだ) し ませんが、付属の gemcal という GUI が画面にメッセージを表示し てくれます。X-SC-Alarm: は現在はそのために役に立っています。 また mhc2palm で Palm に転送する際にはこの情報が重要になること もあるでしょう。 X-SC-Alarm: は 1-99 までの数 + minute, hour, day で指定するこ とができます。 X-SC-Alarm: 10 minute -- 10分前 X-SC-Alarm: 3 hour -- 3時間前 X-SC-Alarm: 3 day -- 3日前 8. その他のカスタマイズ可能な変数など mhc-summary-language mhc の表示言語を選択します。'english, 'japanese があります。 mhc-default-category サマリバッファに表示するスケジュールのカテゴリを文字列で 指定します。デフォルトは nil で全てのカテゴリの スケジュールをを表示します。 ! && || () を使った条件式を書くことができます。 書式の例は、6. X-SC-Category: を参照。 mhc-start-day-of-week 週の始まりの曜日を指定します。0 で日曜日開始、1 で月曜日開始を 意味します。 mhc-use-wide-scope 前月/先月の表示方法を決定します。 nil で表示しません。 'week は月初、月末の週を一週間分必ず表示します。 'wide は 'week の機能に加えて、月初、月末の週が月の区切りでも その前後の表示をします mhc-use-week-separator サマリバッファで、週の区切りに '------------------' を 入れるかどうかです。nil で入れません。0..6 で 日..土 の後に入ります。デフォルトは 6 mhc-summary-use-cw Calendar week number を表示します mhc-schedule-file 祝日等を記述した ~/.schedle を変更します。 mhc-insert-calendar サマリバッファに縦に入る3ヶ月カレンダを表示するかどうかです。 nil 以外で表示。C-c.t でトグルできます。 mhc-mode-hook mhc-draft-mode-hook それぞれのモードの hook です。 mhc-summary-string-conflict スケジュールが競合したときにサマリのサブジェクトの前に表示する [C] という文字を変更します。 mhc-summary-string-secret C-uC-c.s で Private なスケジュールを隠したときに代りに表示する文字 列を指定します。デフォルトは [SECRET] mhc-symbol-face-alist mhc をロードしたときにセットアップされるサマリバッファ上の face (色やフォント) を指定する連想リストです。連想リストの各要素は、 (FACE-SYMBOL . (PARENT FG BG UNDERLINED FONT STIPPLE)) のような形をしています。FACE-SYMBOL には以下の種類があります。 それぞれのデフォルト値と共に示します。 (mhc-calendar-face-saturday . (nil "blue" nil)) (mhc-calendar-face-sunday . (nil "red" nil)) (mhc-summary-face-saturday . (nil "blue" nil)) (mhc-summary-face-sunday . (nil "red" nil)) (mhc-summary-face-today . (nil "black" "chocolate")) (mhc-summary-face-separator . (nil "gray" nil)) (mhc-summary-face-time . (nil "yellowgreen" nil)) (mhc-summary-face-location . (nil "black" "paleturquoise")) (mhc-summary-face-conflict . (nil "white" "purple")) (mhc-summary-face-secret . (nil "gray" nil)) (mhc-minibuf-face-candidate . (nil nil "yellow")) (mhc-category-face-holiday . (nil "red" nil)))) mhc-symbol-face-alist で全てのシンボルを定義する必要はありません。 定義がないシンボルについては、mhc-symbol-face-alist-internal によって安全に定義されます。 mhc-category-face-alist サマリバッファ上のサブジェクトを X-SC-Category: の値によって 色を変えるための連想リストです。連想リストの各要素は、 (CATEGORY-STRING . (PARENT FG BG UNDERLINED FONT STIPPLE)) のような形をしています。ちなみに、僕の mhc-category-face-alist は以下のようになっています。 (setq mhc-category-face-alist '( ("Work" . (bold "black" nil)) ;; お仕事一般 ("Lecture" . (nil "black" "gray")) ;; 講議 ("Seminar" . (nil "black" "orange")) ;; ゼミ ("Party" . (nil "brown" "pink")) ;; 宴会 ("Private" . (nil "tan" nil)))) ;; プライベート まだあるかもしれません。みつけた方は御一報を。 yoshinari-nomura-mhc-815a36a/emacs/make.rb.in000066400000000000000000000021731222073515200210560ustar00rootroot00000000000000#!@@MHC_RUBY_PATH@@ # -*- ruby -*- $LOAD_PATH .unshift('@@MHC_TOPDIR@@') opt = '' opt += ' --with-lispdir=@@MHC_LISPDIR@@' if '@@MHC_LISPDIR@@' != '' opt += ' --with-packagedir=@@MHC_XEMACS_PACKAGE_DIR@@' if '@@MHC_XEMACS_PACKAGE_DIR@@' != '' opt += ' --with-addpath=@@MHC_EMACS_ADD_PATH@@' if '@@MHC_EMACS_ADD_PATH@@' != '' opt += ' --with-mew' if '@@MHC_WITH_MEW@@' != '' opt += ' --with-wl' if '@@MHC_WITH_WL@@' != '' opt += ' --with-gnus' if '@@MHC_WITH_GNUS@@' != '' opt += ' --with-cmail' if '@@MHC_WITH_CMAIL@@' != '' OPT = opt require 'mhc-make' include MhcMake EMACS = '@@MHC_EMACS_PATH@@' XEMACS = '@@MHC_XEMACS_PATH@@' OPTION = '-batch -q -no-site-file -l MHC-MK' ENV['PWD'] = Dir .pwd() if /cygwin|mingw32/ =~ RUBY_PLATFORM def default make_system("#{EMACS} #{OPTION} -f make-mhc-compile", OPT) end def package make_system("#{XEMACS} #{OPTION} -f make-mhc-compile-package", OPT) end def clean Dir .glob("*.elc auto-autoloads.el custom-load.el make.rb") .each{|file| print "removing: " + file + "\n" File .delete(file) } end def install make_system("#{EMACS} #{OPTION} -f make-mhc-install", OPT) end doit() yoshinari-nomura-mhc-815a36a/emacs/mhc-bm.el000066400000000000000000000163541222073515200207020ustar00rootroot00000000000000;;; mhc-bm.el -- Bitmap stuff for MHC. ;; Author: Yuuichi Teranishi ;; ;; Created: 2000/05/27 ;; Revised: $Date: 2002/11/11 05:27:14 $ (require 'bitmap) (require 'mhc-face) (defcustom mhc-bm-icon-alist '(("Conflict" . ("Conflict.xbm" "Yellow")) ("Recurrence" . ("Recurrence.xbm" "Green")) ("Private" . ("Private.xbm" "HotPink")) ("Holiday" . ("Holiday.xbm" "OrangeRed" "White")) ("Todo" .("CheckBox.xbm" "Red")) ("Done" . ("CheckedBox.xbm" "Red")) ("Link" . ("Link.xbm" "Gray"))) "*Alist to define icons. Each element should have the form (NAME . (ICON-FILE FG BG)) It defines icon named NAME with FG and BG color created from ICON-FILE. FG and BG can be omitted (default color is used). Example: '((\"Holiday\" . (\"Holiday.xbm\" \"OrangeRed\" \"White\")) (\"Work\" . (\"Business.xbm\" \"Tan\")) (\"Private\" . (\"Private.xbm\" \"HotPink\")) (\"Anniversary\" . (\"Anniversary.xbm\" \"SkyBlue\")) (\"Birthday\" . (\"Birthday.xbm\")) (\"Other\" . (\"Other.xbm\" \"Red\")) (\"Todo\" .(\"CheckBox.xbm\" \"Red\")) (\"Done\" . (\"CheckedBox.xbm\" \"Red\")) (\"Conflict\" . (\"Conflict.xbm\" \"Yellow\")))" :group 'mhc :type '(repeat :inline t (cons (string :tag "Icon Name") (list (string :tag "XBM File Name") (choice (string :tag "Set FG Color") (const :tag "Default FG Color" nil)) (choice (string :tag "Set BG Color") (const :tag "Default BG Color" nil)))))) (defcustom mhc-icon-function-alist '(("Todo" . mhc-todo-set-as-done) ("Done" . mhc-todo-set-as-not-done) ("Link" . mhc-browse-x-url)) "*Alist to define callback function for icons. Each element should have the form (NAME . FUNCTION) If the icon named NAME is clicked, then FUNCTION is invoked at icon line." :group 'mhc :type '(repeat :inline t (cons (string :tag "Icon Name") (function :tag "Function")))) ;; internal variable. (defvar mhc-bm/icon-bmstr-alist nil) (defvar mhc-bm/icon-function-alist nil) (defvar mhc-bm-icon-keymap nil) (if (null mhc-bm-icon-keymap) (setq mhc-bm-icon-keymap (make-sparse-keymap))) (define-key mhc-bm-icon-keymap [mouse-1] 'mhc-bm-icon-call-function) (define-key mhc-bm-icon-keymap [mouse-2] 'mhc-bm-icon-call-function) (defun mhc-bm-icon-call-function (event) (interactive "e") (save-excursion (mouse-set-point event) (if (get-text-property (point) 'mhc-bm-icon-function) (call-interactively (get-text-property (point) 'mhc-bm-icon-function))))) (defun mhc-bm/create-rectangle (file) (with-temp-buffer (insert-file-contents file) (let* ((cmp (bitmap-decode-xbm (bitmap-read-xbm-buffer (current-buffer)))) (len (length cmp)) (i 0) bitmap) (while (< i len) (setq bitmap (cons (bitmap-compose (aref cmp i)) bitmap)) (setq i (+ i 1))) (nreverse bitmap)))) (defsubst mhc-bm/setup-icons () (let ((alist mhc-bm-icon-alist) bmstr) (while alist ;; Only the first element of the rectangle is used. (setq bmstr (car (mhc-bm/create-rectangle (expand-file-name (car (cdr (car alist))) mhc-icon-path)))) (put-text-property 0 (length bmstr) 'face (mhc-face-make-face-from-string (concat "mhc-bm-icon-" (downcase (car (car alist))) "-face") (list nil (nth 0 (cdr (cdr (car alist)))) (nth 1 (cdr (cdr (car alist)))))) bmstr) (setq mhc-bm/icon-bmstr-alist (cons (cons (downcase (car (car alist))) bmstr) mhc-bm/icon-bmstr-alist)) (setq alist (cdr alist))) (setq mhc-bm/icon-function-alist (mapcar (lambda (pair) (cons (downcase (car pair)) (cdr pair))) mhc-icon-function-alist)))) ;; Icon interface (defun mhc-icon-setup () "Initialize MHC icons." (interactive) (if (interactive-p) (setq mhc-bm/icon-bmstr-alist nil)) (or mhc-bm/icon-bmstr-alist (progn (message "Initializing MHC icons...") (mhc-bm/setup-icons) (run-hooks 'mhc-icon-setup-hook) (message "Initializing MHC icons...done")))) (defun mhc-use-icon-p () "Returns t if MHC displays icon." (and window-system mhc-use-icon mhc-icon-path)) (defun mhc-icon-exists-p (name) "Returns non-nil if icon with NAME exists." (cdr (assoc (downcase name) mhc-bm/icon-bmstr-alist))) (defun mhc-put-icon (icons) "Put ICONS on current buffer. Icon is defined by `mhc-bm-icon-alist'." (let (icon pos func overlay) (while icons (setq icon (cdr (assoc (downcase (car icons)) mhc-bm/icon-bmstr-alist))) (setq pos (point)) (and icon (insert icon)) (when (setq func (cdr (assoc (downcase (car icons)) mhc-bm/icon-function-alist))) (put-text-property pos (point) 'mhc-bm-icon-function func) (put-text-property pos (point) 'local-map mhc-bm-icon-keymap) (setq overlay (make-overlay pos (point))) (overlay-put overlay 'face (get-text-property 0 'face icon)) (overlay-put overlay 'mouse-face 'highlight)) (setq icons (cdr icons))))) (provide 'mhc-bm) ;;; Copyright Notice: ;; Copyright (C) 1999, 2000 Yoshinari Nomura. All rights reserved. ;; Copyright (C) 2000 MHC developing team. All rights reserved. ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of the team nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' ;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ;; THE TEAM OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, ;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED ;; OF THE POSSIBILITY OF SUCH DAMAGE. ;;; mhc-bm.el ends here yoshinari-nomura-mhc-815a36a/emacs/mhc-calendar.el000066400000000000000000002033321222073515200220470ustar00rootroot00000000000000;;; -*- emacs-lisp -*- ;; mhc-calendar.el -- MHC Mini calendar ;; ;; Author: Hideyuki SHIRAI ;; MIYOSHI Masanori ;; ;; Created: 05/12/2000 ;; Reviesd: $Date: 2008/03/06 09:40:12 $ ;;; Configration Variables: (defcustom mhc-calendar-language 'english "*Language of the calendar." :group 'mhc :type '(choice (const :tag "English" english) (const :tag "Japanese" japanese))) (defcustom mhc-calendar-separator ?| "*Character of the separator between Summary and Vertical calendar." :group 'mhc :type 'character) (defcustom mhc-calendar-use-cw nil "*Displayed style of `Calendar week number'." :group 'mhc :type '(choice (const :tag "No" nil) (const :tag "Month" month) (const :tag "Week" week))) (defcustom mhc-calendar-cw-indicator (if (eq mhc-calendar-language 'japanese) "週" "Cw") "*Indicator of Calendar week." :group 'mhc :type 'string) (defcustom mhc-calendar-day-strings (if (eq mhc-calendar-language 'japanese) '["日" "月" "火" "水" "木" "金" "土"] '["Su" "Mo" "Tu" "We" "Th" "Fr" "Sa"]) "*Vector of \"day of week\" for 3-month calendar header." :group 'mhc :type '(list string string string string string string string)) (defcustom mhc-calendar-header-function (if (eq mhc-calendar-language 'japanese) 'mhc-calendar-make-header-ja 'mhc-calendar-make-header) "*Function of \"make calendar header\" for 3-month calendar. Assigned function must have one option \"date\" and must return string like \" December 2000\"." :group 'mhc :type '(radio (function-item :tag "English" mhc-calendar-make-header) (function-item :tag "Japanese" mhc-calendar-make-header-ja) (function :tag "Other"))) (defvar mhc-calendar-inserter-date-list '(((yy mm02 dd02) . "-") ((yy "/" mm02 "/" dd02) . "-") ((mm02 "/" dd02 "/" yy "(" ww-string ")") . "-") ((yy "." mm02 "." dd02 "(" ww-string ")") . " - ") ((yy "-" mm02 "-" dd02 "(" ww-string ")") . " - ") ((dd02 "-" mm-string "-" yy "(" ww-string ")") . " - ") ((ww-string ", " dd02 " " mm-string " " yy) . " - ") ((yy "年" mm2 "月" dd2 "日(" ww-japanese ")") . ("〜" " - ")) ((mm "月" dd2 "日(" ww-japanese ")") . ("〜" " - ")) ((nengo mm2 "月" dd2 "日(" ww-japanese ")") . ("〜" " - "))) "*List of date inserters. Each cell has a cons cell, car slot has a format of 'date modifier funcitons' and cdr slot has a which 'concatenate string' or its list for the duration. E.g., if date equal \"Mon, 01 May 2000\", symbol return a string described below, yy => \"2000\" nengo => \"平成12年\" mm => \"7\" mm2 => \" 7\" mm02 => \"07\" mm-string => \"Jul\" mm-string-long => \"July\" dd => \"1\" dd2 => \" 1\" dd02 => \"01\" ww => \"6\" ww-string => \"Sat\" ww-string-long => \"Saturday\" ww-japanese => \"土\" ww-japanese-long => \"土曜日\" ") (defcustom mhc-calendar-mode-hook nil "*Hook called in mhc-calendar-mode." :group 'mhc :type 'hook) (defcustom mhc-calendar-create-buffer-hook nil "*Hook called in mhc-calendar-create-buffer." :group 'mhc :type 'hook) (defcustom mhc-calendar-start-column 2 "*Size of left margin." :group 'mhc :type 'integer) (defcustom mhc-calendar-height (cond ((and (featurep 'xemacs) window-system) 12) ((and (not (featurep 'xemacs)) (>= emacs-major-version 21)) 10) (t 9)) "*Height of next month start column (greater or equal 9)." :group 'mhc :type 'integer) (defcustom mhc-calendar-height-offset (cond ((and (featurep 'xemacs) window-system) 4) ((and (not (featurep 'xemacs)) (>= emacs-major-version 21)) 3) (t 1)) "*Offset of window height." :group 'mhc :type 'integer) (defcustom mhc-calendar-view-summary nil "*View day's summary if *non-nil*." :group 'mhc :type 'boolean) (defcustom mhc-calendar-link-hnf nil "*Support HNF(Hyper Nikki File) mode if *non-nil*." :group 'mhc :type 'boolean) (defcustom mhc-calendar-use-mouse-highlight t "*Highlight mouse pointer." :group 'mhc :type 'boolean) (defcustom mhc-calendar-use-help-echo t "*Display schedule within help-echo." :group 'mhc :type 'boolean) (defcustom mhc-calendar-use-duration-show (if window-system 'mixed 'modeline) "*Show 'duration' mode." :group 'mhc :type '(choice (const :tag "none" nil) (const :tag "modeline" modeline) (const :tag "face" face) (const :tag "mixed" mixed))) (defcustom mhc-calendar-view-file-hook nil "*Hook called in mhc-calendar-view-file." :group 'mhc :type 'hook) ;; internal variables. Don't modify. (defvar mhc-calendar/buffer "*mhc-calendar*") (defvar mhc-calendar-date nil) (defvar mhc-calendar-view-date nil) (defvar mhc-calendar-mode-map nil) (defvar mhc-calendar-mode-menu-spec nil) (defvar mhc-calendar/week-header nil) (defvar mhc-calendar/separator-str nil) (defvar mhc-calendar/inserter-call-buffer nil) (defvar mhc-calendar/inserter-type nil) (defvar mhc-calendar/inserter-for-minibuffer '(((yy "/" mm02 "/" dd02) . "-"))) (defvar mhc-calendar/inserter-for-draft '(((yy mm02 dd02) . "-"))) (defvar mhc-calendar/mark-date nil) ;; mhc-calendar functions ;; macros (defmacro mhc-calendar-p () `(eq major-mode 'mhc-calendar-mode)) (defmacro mhc-calendar/in-date-p () ;; return 'date from 01/01/1970' `(get-text-property (point) 'mhc-calendar/date-prop)) (defmacro mhc-calendar/in-summary-p () ;; return 'schedule filename' `(or (get-text-property (point) 'mhc-calendar/summary-prop) (save-excursion (beginning-of-line) (get-text-property (point) 'mhc-calendar/summary-prop)))) (defmacro mhc-calendar/in-summary-hnf-p () ;; return 'title count' `(or (get-text-property (point) 'mhc-calendar/summary-hnf-prop) (save-excursion (beginning-of-line) (get-text-property (point) 'mhc-calendar/summary-hnf-prop)))) (defmacro mhc-calendar/cw-week () `(and (or (eq mhc-calendar-use-cw 'week) (eq mhc-calendar-use-cw t)) (eq mhc-start-day-of-week 1))) (defcustom mhc-calendar-next-offset (if (mhc-calendar/cw-week) 27 23) "*Offset of next month start column (greater or equal 23)." :group 'mhc :type 'integer) (defvar mhc-calendar-width (if (mhc-calendar/cw-week) 28 24)) (defmacro mhc-calendar/cw-string (cw) `(let (ret) (if (stringp ,cw) (setq ret ,cw) (setq ret (format "%2d." ,cw))) (mhc-face-put ret 'mhc-calendar-face-cw) ret)) (defmacro mhc-calendar/get-date-colnum (col) `(cond ((< ,col (+ mhc-calendar-next-offset mhc-calendar-start-column)) -1) ((< ,col (+ (* mhc-calendar-next-offset 2) mhc-calendar-start-column)) 0) (t 1))) (defmacro mhc-calendar/buffer-substring-to-num (pos) `(string-to-number (buffer-substring (match-beginning ,pos) (match-end ,pos)))) ;; Avoid warning of byte-compiler. (eval-when-compile (defvar yy) (defvar mm) (defvar dd) (defvar ww) (defvar hnf-diary-dir) (defvar hnf-diary-year-directory-flag) (defvar view-exit-action) (defvar mhc-calendar-mode-menu)) (eval-and-compile (autoload 'easy-menu-add "easymenu") (autoload 'hnf-mode "hnf-mode")) ;; Compatibilities between emacsen (if (fboundp 'text-property-any) (defsubst mhc-calendar/tp-any (beg end prop value) (text-property-any beg end prop value)) (defsubst mhc-calendar/tp-any (beg end prop value) (while (and beg (< beg end) (not (eq value (get-text-property beg prop)))) (setq beg (next-single-property-change beg prop nil end))) (if (eq beg end) nil beg))) (if (fboundp 'event-buffer) (defalias 'mhc-calendar/event-buffer 'event-buffer) (defun mhc-calendar/event-buffer (event) (window-buffer (posn-window (event-start event))))) (if (fboundp 'event-point) (defalias 'mhc-calendar/event-point 'event-point) (defun mhc-calendar/event-point (event) (posn-point (event-start event)))) ;; map/menu (unless mhc-calendar-mode-map (setq mhc-calendar-mode-map (make-sparse-keymap)) (define-key mhc-calendar-mode-map "." 'mhc-calendar-goto-today) (define-key mhc-calendar-mode-map "g" 'mhc-calendar-goto-month) (define-key mhc-calendar-mode-map "r" 'mhc-calendar-rescan) (define-key mhc-calendar-mode-map "R" 'mhc-reset) (define-key mhc-calendar-mode-map "=" 'mhc-calendar-get-day) (define-key mhc-calendar-mode-map " " 'mhc-calendar-get-day-insert) (define-key mhc-calendar-mode-map "\C-m" 'mhc-calendar-get-day-insert-quit) (define-key mhc-calendar-mode-map "-" 'mhc-calendar-count-days-region) (define-key mhc-calendar-mode-map "s" 'mhc-calendar-scan) (define-key mhc-calendar-mode-map "E" 'mhc-calendar-edit) (define-key mhc-calendar-mode-map "M" 'mhc-calendar-modify) (define-key mhc-calendar-mode-map "D" 'mhc-calendar-delete) (define-key mhc-calendar-mode-map "H" 'mhc-calendar-hnf-edit) (define-key mhc-calendar-mode-map "v" 'mhc-calendar-goto-view) (define-key mhc-calendar-mode-map "h" 'mhc-calendar-goto-home) (define-key mhc-calendar-mode-map "f" 'mhc-calendar-next-day) (define-key mhc-calendar-mode-map "b" 'mhc-calendar-prev-day) (define-key mhc-calendar-mode-map "n" 'mhc-calendar-next-week) (define-key mhc-calendar-mode-map "p" 'mhc-calendar-prev-week) (define-key mhc-calendar-mode-map "N" 'mhc-calendar-next-month) (define-key mhc-calendar-mode-map "P" 'mhc-calendar-prev-month) (define-key mhc-calendar-mode-map ">" 'mhc-calendar-inc-month) (define-key mhc-calendar-mode-map "<" 'mhc-calendar-dec-month) (define-key mhc-calendar-mode-map "\M-\C-n" 'mhc-calendar-next-year) (define-key mhc-calendar-mode-map "\M-\C-p" 'mhc-calendar-prev-year) (define-key mhc-calendar-mode-map "\C-@" 'mhc-calendar-set-mark-command) (cond ((featurep 'xemacs) (define-key mhc-calendar-mode-map "\C- " 'mhc-calendar-set-mark-command) (define-key mhc-calendar-mode-map [(button1)] 'mhc-calendar-day-at-mouse) (define-key mhc-calendar-mode-map [(button2)] 'mhc-calendar-day-at-mouse)) (t (define-key mhc-calendar-mode-map [?\C- ] 'mhc-calendar-set-mark-command) (define-key mhc-calendar-mode-map [mouse-1] 'mhc-calendar-day-at-mouse) (define-key mhc-calendar-mode-map [mouse-2] 'mhc-calendar-day-at-mouse))) (define-key mhc-calendar-mode-map "\C-x\C-x" 'mhc-calendar-exchange-point-and-mark) (define-key mhc-calendar-mode-map "q" 'mhc-calendar-quit) (define-key mhc-calendar-mode-map "Q" 'mhc-calendar-exit) (define-key mhc-calendar-mode-map "?" 'describe-mode)) (unless mhc-calendar-mode-menu-spec (setq mhc-calendar-mode-menu-spec '("Mhc-Calendar" ["Toggle view area" mhc-calendar-goto-home t] ["Goto today" mhc-calendar-goto-today t] ["Goto next month" mhc-calendar-inc-month t] ["Goto prev month" mhc-calendar-dec-month t] ["Goto month" mhc-calendar-goto-month t] ("Goto" ["Next day" mhc-calendar-next-day t] ["Prev day" mhc-calendar-prev-day t] ["Next week" mhc-calendar-next-week t] ["Prev week" mhc-calendar-prev-week t] ["Next month" mhc-calendar-next-month t] ["Prev month" mhc-calendar-prev-month t] ["Next year" mhc-calendar-next-year t] ["Prev year" mhc-calendar-prev-year t]) ["Rescan" mhc-calendar-rescan t] ["MHC summary scan" mhc-calendar-scan t] "----" ["Save to kill ring" mhc-calendar-get-day t] ["Insert" mhc-calendar-get-day-insert t] ["Insert/Quit" mhc-calendar-get-day-insert-quit t] ["Mark set" mhc-calendar-set-mark-command t] ["Exchange point & mark" mhc-calendar-exchange-point-and-mark mhc-calendar/mark-date t] ["Count days in region" mhc-calendar-count-days-region mhc-calendar/mark-date t] "----" ["Goto view area" mhc-calendar-goto-view (not (or (mhc-calendar/in-summary-p) (mhc-calendar/in-summary-hnf-p)))] ["Schedule view" mhc-calendar-goto-view (or (mhc-calendar/in-summary-p) (mhc-calendar/in-summary-hnf-p))] ("Schedule edit" ["Schedule addition" mhc-calendar-edit (or (mhc-calendar/in-date-p) (mhc-calendar/in-summary-p))] ["Schedule modify" mhc-calendar-modify (mhc-calendar/in-summary-p)] ["Schedule delete" mhc-calendar-delete (mhc-calendar/in-summary-p)] ["HNF file edit" mhc-calendar-hnf-edit (and mhc-calendar-link-hnf (or (mhc-calendar/in-date-p) (mhc-calendar/in-summary-p) (mhc-calendar/in-summary-hnf-p)))]) "----" ("Misc" ["Reset" mhc-reset t] ["Quit" mhc-calendar-quit t] ["Kill" mhc-calendar-exit t] ["Help" describe-mode t])))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; make rectangle like calendar.el (defun mhc-calendar-toggle-insert-rectangle (&optional hide-private) "Toggle 3 month calendar." (interactive "P") (setq mhc-insert-calendar (not mhc-insert-calendar)) (mhc-rescan-month hide-private)) (defun mhc-calendar-setup () (setq mhc-calendar/week-header nil) (setq mhc-calendar/separator-str (char-to-string mhc-calendar-separator)) (mhc-face-put mhc-calendar/separator-str 'mhc-summary-face-separator) (if (mhc-calendar/cw-week) (when (< mhc-calendar-next-offset 27) (setq mhc-calendar-next-offset 27)) (when (< mhc-calendar-next-offset 23) (setq mhc-calendar-next-offset 23))) (setq mhc-calendar-width (if (mhc-calendar/cw-week) 28 24)) (when (mhc-calendar/cw-week) (setq mhc-calendar/week-header (mhc-calendar/cw-string (format "%s " mhc-calendar-cw-indicator)))) (let ((days (copy-sequence (nthcdr mhc-start-day-of-week (append mhc-calendar-day-strings mhc-calendar-day-strings nil)))) (i 0) day) (while (< i 7) (setq day (car days)) (cond ((= (% (+ i mhc-start-day-of-week) 7) 0) (mhc-face-put day 'mhc-calendar-face-sunday)) ((= (% (+ i mhc-start-day-of-week) 7) 6) (mhc-face-put day 'mhc-calendar-face-saturday)) (t (mhc-face-put day 'mhc-calendar-face-default))) (setq mhc-calendar/week-header (concat mhc-calendar/week-header (if mhc-calendar/week-header " ") day)) (setq days (cdr days)) (setq i (1+ i))))) (defun mhc-calendar-insert-rectangle-at (date col &optional months) (let ((m nil) (rect nil) (center nil)) (save-excursion (setq date (mhc-date-mm-first date)) (put-text-property (point-min) (point-max) 'rear-nonsticky t) (goto-char (point-min)) (when mhc-use-wide-scope (mhc-summary-search-date date)) (beginning-of-line) (mhc-misc-move-to-column col) (if (consp months) (setq m (car months) center (- m (cdr months))) (setq m (or months 3)) (setq center (/ (1+ m) 2))) (while (> m 0) (setq rect (nconc rect (mhc-calendar/make-rectangle (mhc-date-mm- date (- m center)) mhc-calendar/separator-str) (if (> m 1) (list (concat mhc-calendar/separator-str " "))))) (setq m (1- m))) (mhc-misc-insert-rectangle rect)))) (defun mhc-calendar-make-header (date) (let ((ret (mhc-date-format date "%s %04d" (mhc-date-digit-to-mm-string mm t) yy)) cw) (when (eq mhc-calendar-use-cw 'month) (setq cw (mhc-calendar/cw-string (format "w%d" (mhc-date-cw (mhc-date-mm-first date))))) ;; (length "September 2002 w35") => 18 ;; (length "Mo Tu We Th Fr Sa Su") => 20 (setq cw (concat (make-string (- 18 (length ret) (length cw)) ? ) cw))) (if (mhc-date-yymm= (mhc-date-now) date) (mhc-face-put ret (mhc-face-get-today-face 'mhc-calendar-face-saturday)) (mhc-face-put ret 'mhc-calendar-face-saturday)) (concat " " (if (mhc-calendar/cw-week) " " "") ret cw))) (defun mhc-calendar-make-header-ja (date) (let ((ret (mhc-date-format date "%04d年%2d月" yy mm)) (cw "")) (when (eq mhc-calendar-use-cw 'month) (setq cw (mhc-calendar/cw-string (format " (%d)" (mhc-date-cw (mhc-date-mm-first date)))))) (if (mhc-date-yymm= (mhc-date-now) date) (mhc-face-put ret (mhc-face-get-today-face 'mhc-calendar-face-saturday)) (mhc-face-put ret 'mhc-calendar-face-saturday)) (concat " " (if (mhc-calendar/cw-week) " " "") ret cw))) (defun mhc-calendar/make-rectangle (&optional date separator) (let* ((today (mhc-date-now)) (month (list (concat separator " " mhc-calendar/week-header) (concat separator " " (funcall mhc-calendar-header-function (or date today))))) (mm (mhc-date-mm (or date today))) (days (mhc-db-scan-month (mhc-date-yy (or date today)) mm t)) (separator (if separator separator mhc-calendar/separator-str)) (start (mhc-day-day-of-week (car days))) (i 0) week color cw day cdate map) (when (mhc-calendar/cw-week) (setq cw (mhc-date-cw (mhc-day-date (car days)))) (setq week (cons (mhc-calendar/cw-string cw) week))) (unless (= (mhc-end-day-of-week) 6) (setq start (+ start 6)) (when (> start 6) (setq start (- start 7)))) (while (< i start) (setq week (cons " " week)) (setq i (1+ i))) (while days (setq cdate (mhc-day-date (car days))) (when (and (null week) (mhc-calendar/cw-week)) (if (or (eq mm 1) (eq mm 12)) (setq cw (mhc-date-cw cdate)) (setq cw (1+ cw))) (setq week (cons (mhc-calendar/cw-string cw) week))) (setq color (cond ((= 0 (mhc-day-day-of-week (car days))) 'mhc-calendar-face-sunday) ((mhc-day-holiday (car days)) (mhc-face-category-to-face "Holiday")) ((= 6 (mhc-day-day-of-week (car days))) 'mhc-calendar-face-saturday) (t 'mhc-calendar-face-default))) (when (mhc-date= today cdate) (setq color (mhc-face-get-today-face color))) (when (mhc-day-busy-p (car days)) (setq color (mhc-face-get-busy-face color))) (setq day (format "%2d" (mhc-day-day-of-month (car days)))) (when color (mhc-face-put day color)) (add-text-properties 0 (length day) `(mhc-calendar/date-prop ,cdate mouse-face ,(if mhc-calendar-use-mouse-highlight 'highlight nil) help-echo ,(if mhc-calendar-use-help-echo (mhc-calendar/get-contents cdate) nil)) day) (setq week (cons day week)) (when (= (mhc-end-day-of-week) (mhc-day-day-of-week (car days))) (setq month (cons (mapconcat (function identity) (cons separator (nreverse week)) " ") month) week nil)) (setq days (cdr days))) (when week (setq month (cons (mapconcat (function identity) (cons separator (nreverse week)) " ") month))) (nreverse month))) (defun mhc-calendar-mouse-goto-date-view (event) (interactive "e") (mhc-calendar-mouse-goto-date event 'view)) (eval-and-compile (if (featurep 'xemacs) (defun mhc-calendar-mouse-icon-function (event) (mhc-xmas-icon-call-function event)) (defun mhc-calendar-mouse-icon-function (event) (mhc-e21-icon-call-function event)))) (defun mhc-calendar-mouse-goto-date (event &optional view) (interactive "e") (let (cdate dayinfo pos cpos func) (save-excursion (set-buffer (mhc-calendar/event-buffer event)) (goto-char (mhc-calendar/event-point event)) (setq cdate (get-text-property (point) 'mhc-calendar/date-prop))) (cond (cdate (unless (= (mhc-current-date-month) (mhc-date-let cdate (mhc-date-new yy mm 1))) (mhc-goto-month cdate mhc-default-hide-private-schedules)) (setq pos (point)) (goto-char (point-min)) (setq cpos (point)) (catch 'detect (while (setq cpos (next-single-property-change cpos 'mhc-dayinfo)) (when (and (setq dayinfo (get-text-property cpos 'mhc-dayinfo)) (= cdate (mhc-day-date dayinfo))) (setq pos cpos) (throw 'detect t)))) (goto-char pos) (funcall (mhc-get-function 'goto-message) view)) (t (unless (mhc-calendar-mouse-icon-function event) (setq func (or (lookup-key (current-local-map) (this-command-keys)) (lookup-key (current-global-map) (this-command-keys)))) (when func (call-interactively func event))))))) ;; function (defun mhc-calendar-mode () "\\ MHC Calendar mode:: major mode to view calendar and select day. The keys that are defined for mhc-calendar-mode are: \\[mhc-calendar-goto-home] Recover positioning and toggle show 'view area'. \\[mhc-calendar-goto-today] Jump to today. \\[mhc-calendar-inc-month] Slide to the next month. \\[mhc-calendar-dec-month] Slide to the previous month. \\[mhc-calendar-goto-month] Jump to your prefer month. \\[mhc-calendar-rescan] Rescan current calendar. \\[mhc-calendar-scan] Scan the point day's schedule summary with MUA. If '\\[mhc-calendar-scan]' executed with 'prefix argument', hide private category. \\[mhc-calendar-next-day] Goto the next day. \\[mhc-calendar-prev-day] Goto the previous day. \\[mhc-calendar-next-week] Goto the next week or goto the next summary. \\[mhc-calendar-prev-week] Goto previous week or goto the previous summary. \\[mhc-calendar-next-month] Goto next month. \\[mhc-calendar-prev-month] Goto previous month. \\[mhc-calendar-next-year] Goto next year. \\[mhc-calendar-prev-year] Goto previous year. '\\[mhc-calendar-next-day]' '\\[mhc-calendar-prev-day]' '\\[mhc-calendar-next-week]' '\\[mhc-calendar-prev-week]' '\\[mhc-calendar-next-month]' '\\[mhc-calendar-prev-month]' '\\[mhc-calendar-inc-month]' '\\[mhc-calendar-dec-month]' '\\[mhc-calendar-next-year]' '\\[mhc-calendar-prev-year]' effected by 'prefix argument(integer number)'. \\[mhc-calendar-day-at-mouse] Day positioning or view schedule file. \\[mhc-calendar-set-mark-command] Duration start point set. \\[mhc-calendar-exchange-point-and-mark] Duration start point exchange. \\[mhc-calendar-count-days-region] Count days in region. \\[mhc-calendar-get-day] Get day at point to save kill ring. \\[mhc-calendar-get-day-insert] Get day at point to insert call buffer. \\[mhc-calendar-get-day-insert-quit] Get day at point to insert call buffer, quit. if '\\[mhc-calendar-get-day]' '\\[mhc-calendar-get-day-insert]' '\\[mhc-calendar-get-day-insert-quit]' executed with 'prefix argument', means to treat the duration. \\[mhc-calendar-goto-view] Goto summary view position or view schedule file. \\[mhc-calendar-edit] Create new schdule file. If optional argument IMPORT-BUFFER is specified, import its content. \\[mhc-calendar-modify] Edit the schdule on the cursor point. \\[mhc-calendar-delete] Delete the schdule on the cursor point. \\[mhc-calendar-hnf-edit] Edit the Hyper Nikki File. \\[mhc-reset] Reset MHC. \\[mhc-calendar-quit] Quit and calendar buffer bury. \\[mhc-calendar-exit] Quit and calendar buffer kill. \\[describe-mode] Show mode help. " (interactive) (kill-all-local-variables) (use-local-map mhc-calendar-mode-map) (make-local-variable 'mhc-calendar-date) (make-local-variable 'mhc-calendar-view-date) (make-local-variable 'mhc-calendar/mark-date) (make-local-variable 'indent-tabs-mode) (setq major-mode 'mhc-calendar-mode) (setq mode-name "mhc-calendar") (setq indent-tabs-mode nil) (setq truncate-lines t) (when (featurep 'xemacs) (easy-menu-add mhc-calendar-mode-menu)) (unless (memq 'mhc-calendar/duration-show post-command-hook) (add-hook 'post-command-hook 'mhc-calendar/duration-show)) (run-hooks 'mhc-calendar-mode-hook)) (defun mhc-calendar (&optional date) "Display 3-month mini calendar." (interactive) (setq date (or date (mhc-current-date) (mhc-calendar-get-date))) (when (and (get-buffer mhc-calendar/buffer) (set-buffer mhc-calendar/buffer)) (setq date (or date mhc-calendar-view-date)) (unless (mhc-date-yymm= date mhc-calendar-date) (mhc-calendar/create-buffer date))) (mhc-calendar/goto-date (or date (mhc-date-now)))) (defun mhc-calendar-goto-today () (interactive) (mhc-calendar (mhc-date-now))) (defun mhc-calendar/goto-date (date) (let ((mhc-calendar-view-summary nil) pos) (unless (memq 'mhc-calendar/duration-show post-command-hook) (add-hook 'post-command-hook 'mhc-calendar/duration-show)) (unless (get-buffer mhc-calendar/buffer) (mhc-calendar/create-buffer date)) (set-buffer (get-buffer mhc-calendar/buffer)) (pop-to-buffer mhc-calendar/buffer) (while (not pos) (setq pos (mhc-calendar/tp-any (point-min) (point-max) 'mhc-calendar/date-prop date)) (or pos (mhc-calendar/create-buffer date))) (goto-char (1+ pos))) (setq mhc-calendar-view-date date) (save-excursion (mhc-calendar/view-summary-delete) (when mhc-calendar-view-summary (mhc-calendar/view-summary-insert) (and mhc-calendar-link-hnf (mhc-calendar/hnf-summary-insert)) (mhc-calendar/put-property-summary))) (mhc-calendar/shrink-window)) (defun mhc-calendar/view-summary-delete () (goto-char (point-min)) (when (re-search-forward "^--" nil t) (let ((buffer-read-only nil)) (beginning-of-line) (forward-char -1) (set-text-properties (point) (point-max) nil) (delete-region (point) (point-max)) (set-buffer-modified-p nil)))) (defun mhc-calendar/view-summary-insert () (let ((date mhc-calendar-view-date) (buffer-read-only nil) (mhc-use-week-separator nil)) (goto-char (point-max)) (insert "\n") (mhc-summary/insert-separator nil nil (min (1- (window-width)) (* mhc-calendar-next-offset 3))) (mhc-summary-make-contents date date 'mhc-calendar) (delete-char -1) (set-buffer-modified-p nil))) (defun mhc-calendar/put-property-summary () (condition-case nil (when mhc-calendar-use-mouse-highlight (let ((buffer-read-only nil) beg) (goto-char (point-min)) (when (re-search-forward "^--" nil t) (forward-line) (while (not (eobp)) (setq beg (point)) (end-of-line) (put-text-property beg (point) 'mouse-face 'highlight) (forward-line)))) (set-buffer-modified-p nil)) (error nil))) (defun mhc-calendar/shrink-window () (or (one-window-p t) (/= (frame-width) (window-width)) (let ((winh (+ (count-lines (point-min) (point-max)) mhc-calendar-height-offset))) (cond ((< winh mhc-calendar-height) (setq winh mhc-calendar-height)) ((< winh window-min-height) (setq winh window-min-height))) (shrink-window (- (window-height) winh))))) (defun mhc-calendar/create-buffer (date) (set-buffer (get-buffer-create mhc-calendar/buffer)) (setq buffer-read-only t) (unless (eq major-mode 'mhc-calendar-mode) (mhc-calendar-mode) (buffer-disable-undo)) (or (mhc-date-p date) (setq date (mhc-date-now))) (let ((buffer-read-only nil) (caldate (mhc-date-mm+ date -1)) (col mhc-calendar-start-column) (prefix " +|") (i 3)) (mhc-calendar/delete-overlay) (set-text-properties (point-min) (point-max) nil) (erase-buffer) (message "mhc-calendar create...") (while (> i 0) (goto-char (point-min)) (mhc-misc-move-to-column col) (mhc-misc-insert-rectangle (mhc-calendar/make-rectangle caldate (if (= i 3) "" "|"))) (setq caldate (mhc-date-mm+ caldate 1)) (setq col (- (+ col mhc-calendar-next-offset) (if (= i 3) 1 0))) (setq i (1- i))) (goto-char (point-min)) (while (re-search-forward prefix nil t) (delete-region (match-end 0) (match-beginning 0)) (insert (make-string (- (match-end 0) (match-beginning 0)) ?\ ))) (setq mhc-calendar-date date) ;; (mhc-calendar/put-property-date) (and mhc-calendar-link-hnf (mhc-calendar/hnf-mark-diary-entries)) (run-hooks 'mhc-calendar-create-buffer-hook) (set-buffer-modified-p nil) (message "mhc-calendar create...done"))) (defvar mhc-calendar/date-format nil) (defun mhc-calendar/get-contents (date) (unless mhc-calendar/date-format (setq mhc-calendar/date-format (if (eq mhc-calendar-language 'japanese) "%04d年%2d月%2d日(%s)\n" "%04d-%02d-%02d (%s)\n"))) (with-temp-buffer (let* ((dayinfo (car (mhc-db-scan date date))) (schedules (mhc-day-schedules dayinfo)) schedule begin end subject location) (mhc-date-let (mhc-day-date dayinfo) (insert (format mhc-calendar/date-format yy mm dd (aref mhc-calendar-day-strings ww)))) (when schedules (insert "\n")) (while (setq schedule (car schedules)) (setq schedules (cdr schedules)) (setq begin (mhc-schedule-time-begin schedule)) (setq end (mhc-schedule-time-end schedule)) (setq subject (or (mhc-schedule-subject schedule) "")) (setq location (or (mhc-schedule-location schedule) "")) (when (> (length location) 0) (setq location (concat " [" location "]"))) (when (or begin end subject location) (insert (format "%s%s%s%s%s\n" (if begin (format "%02d:%02d" (/ begin 60) (% begin 60)) "") (if end (format "-%02d:%02d" (/ end 60) (% end 60)) "") (if (or begin end) " " "") subject location)))) (buffer-substring-no-properties (point-min) (point-max))))) (defun mhc-calendar-edit () (interactive) (if (or (mhc-calendar/in-date-p) (mhc-calendar/in-summary-p)) (progn (mhc-window-push) (mhc-edit nil) (delete-other-windows)) (message "Nothing to do in this point."))) (defun mhc-calendar-delete () (interactive) (let ((filename (mhc-calendar/in-summary-p)) key) (if (null filename) (message "Nothing to do in this point.") (setq key (mhc-slot-directory-to-key (directory-file-name (file-name-directory filename)))) (mhc-delete-file (assoc filename (mhc-slot-records (mhc-slot-get-month-schedule key))))))) (defun mhc-calendar-modify () (interactive) (if (mhc-calendar/in-summary-p) (mhc-modify-file (mhc-calendar/in-summary-p)) (message "Nothing to do in this point."))) (defun mhc-calendar-toggle-view () (interactive) (setq mhc-calendar-view-summary (not mhc-calendar-view-summary)) (mhc-calendar/goto-date (mhc-calendar-get-date))) (defun mhc-calendar-goto-view () (interactive) (cond ((mhc-calendar/in-summary-p) (mhc-calendar/view-file (mhc-calendar/in-summary-p))) ((mhc-calendar/in-summary-hnf-p) (mhc-calendar/hnf-view)) (t (setq mhc-calendar-view-summary t) (mhc-calendar/goto-date (mhc-calendar-get-date)) (goto-char (next-single-property-change (point) 'mhc-calendar/summary-prop))))) (defun mhc-calendar/view-file (file) (if (and (stringp file) (file-exists-p file)) (let ((newname (mhc-date-format mhc-calendar-view-date "+%04d/%02d/%02d" yy mm dd))) (mhc-window-push) (view-file-other-window file) ;; eword decode (mhc-calendar/view-file-decode-header) (setq view-exit-action 'mhc-calendar-view-exit-action) (set-visited-file-name nil) (rename-buffer newname 'unique) (run-hooks 'mhc-calendar-view-file-hook) (set-buffer-modified-p nil) (setq buffer-read-only t)) (message "File does not exist (%s)." file))) (defun mhc-calendar/view-file-decode-header () (let ((buffer-read-only nil)) (goto-char (point-min)) (mhc-decode-header) (mhc-highlight-message))) ;; insert function (defun mhc-calendar-get-day (&optional arg) (interactive "P") (let (str) (if (null arg) (setq str (mhc-calendar/get-day)) (setq str (mhc-calendar/get-day-region))) (kill-new str) (message "\"%s\" to the latest kill in the kill ring." str))) (defun mhc-calendar-get-day-insert-quit (&optional arg) (interactive "P") (when (mhc-calendar-get-day-insert arg) (mhc-calendar-quit))) (defun mhc-calendar-get-day-insert (&optional arg) (interactive "P") (let ((callbuf mhc-calendar/inserter-call-buffer) (type mhc-calendar/inserter-type) (defbuff (buffer-name (car (delete (get-buffer mhc-calendar/buffer) (buffer-list))))) str) ;; in mhc-calendar/buffer (if (null arg) (setq str (mhc-calendar/get-day type)) (setq str (mhc-calendar/get-day-region type))) (kill-new str) (unless (and callbuf (get-buffer callbuf) (buffer-name callbuf)) (setq callbuf (read-buffer "Insert buffer? " defbuff t))) ;; in mhc-clendar-call-buffer (if (not (get-buffer callbuf)) (message "No buffer detect \"%s\"" callbuf) (set-buffer (get-buffer callbuf)) (pop-to-buffer callbuf) (cond ((window-minibuffer-p) (insert str) t) (t (condition-case err (progn (insert str) (message "\"%s\" insert done." str) t) (error (pop-to-buffer (get-buffer mhc-calendar/buffer)) (message "\"%s\" insert failed." str) nil))))))) (defun mhc-calendar/get-day (&optional type) (let ((date (mhc-calendar-get-date)) datelst rlst) (cond ((eq type 'minibuffer) (setq datelst mhc-calendar/inserter-for-minibuffer)) ((or (eq type 'duration) (eq type 'day)) (setq datelst mhc-calendar/inserter-for-draft)) (t (setq datelst mhc-calendar-inserter-date-list))) (setq rlst (mhc-calendar/get-day-list date datelst)) (mhc-calendar/get-day-select rlst))) (defun mhc-calendar/get-day-region (&optional type) (let (cat datebeg dateend datetmp datelst rlst) (if (not (mhc-date-p mhc-calendar/mark-date)) (error "No mark set in this buffer") (setq dateend (mhc-calendar-get-date)) (setq datebeg mhc-calendar/mark-date) ;; swap (when (mhc-date> datebeg dateend) (setq datetmp dateend) (setq dateend datebeg) (setq datebeg datetmp)) (if (eq type 'day) ;; for X-SC-Day: (20000101 200000102 ... 20000131) (progn (setq datetmp nil) (while (mhc-date<= datebeg dateend) (setq datetmp (cons datebeg datetmp)) (setq datebeg (mhc-date++ datebeg))) (mapconcat (lambda (x) (mhc-date-format x "%04d%02d%02d" yy mm dd)) (nreverse datetmp) " ")) (cond ((eq type 'minibuffer) (setq datelst mhc-calendar/inserter-for-minibuffer)) ((eq type 'duration) (setq datelst mhc-calendar/inserter-for-draft)) (t (setq datelst mhc-calendar-inserter-date-list))) (setq rlst (mhc-calendar/get-day-list datebeg datelst dateend)) (mhc-calendar/get-day-select rlst))))) (defun mhc-calendar/get-day-select (lst) (cond ((= (length lst) 0) (error "Something error occur.")) ((= (length lst) 1) (car lst)) (t (let ((i 0) (completion-ignore-case nil) alst hist cell input) (while lst (setq cell (format "%d: %s" i (car lst))) (setq hist (cons cell hist)) (setq alst (cons (cons cell (car lst)) alst)) (setq i (1+ i)) (setq lst (cdr lst))) (setq hist (nreverse hist)) (setq alst (nreverse alst)) (setq mhc-calendar/select-alist alst) ;; for completion (setq input (mhc-calendar/select-comp "Select format: " 'active)) (when (string= input "") (setq input (cdr (car alst)))) (when (string-match "^\\([0-9]+\\)$" input) (setq i (string-to-number input)) (when (> (length alst) i) (setq input (cdr (nth i alst))))) (when (string-match "^[0-9]+:[ \t]*" input) (setq input (substring input (match-end 0)))) input)))) (defun mhc-calendar-count-days-region () (interactive) (let ((mark mhc-calendar/mark-date) (date (mhc-calendar-get-date))) (if (null mark) (error "No mark set in this buffer") (setq date (mhc-date++ (mhc-date- (max mark date) (min mark date)))) (kill-new (int-to-string date)) (if (< date 7) (message "%d days in region." date) (if (= (% date 7) 0) (message "%d days (%d weeks) in region." date (/ date 7)) (message "%d days (%d weeks + %d days) in region." date (/ date 7) (% date 7))))))) ;; selector (defvar mhc-calendar/select-alist nil) (defvar mhc-calendar/select-hist nil) (defvar mhc-calendar/select-map nil) (defvar mhc-calendar/select-buffer "*Completions*") (if mhc-calendar/select-map () (setq mhc-calendar/select-map (make-sparse-keymap)) (define-key mhc-calendar/select-map "\t" 'mhc-calendar/select-comp-window) (define-key mhc-calendar/select-map "\r" 'exit-minibuffer) (define-key mhc-calendar/select-map "\n" 'exit-minibuffer) (define-key mhc-calendar/select-map "\C-g" 'abort-recursive-edit) (define-key mhc-calendar/select-map "\M-s" 'next-matching-history-element) (define-key mhc-calendar/select-map "\M-p" 'previous-history-element) (define-key mhc-calendar/select-map "\M-n" 'next-history-element) (define-key mhc-calendar/select-map "\M-v" 'switch-to-completions)) (defun mhc-calendar/select-comp-setup () (mhc-calendar/select-comp-window "")) (defun mhc-calendar/select-comp-window (&optional word) (interactive) (let ((completion-ignore-case nil) outp pos) (when (not word) (setq word (buffer-substring-no-properties (save-excursion (beginning-of-line) (point)) (point-max))) (setq outp (try-completion word mhc-calendar/select-alist)) (when (and (stringp outp) (window-minibuffer-p (get-buffer-window (current-buffer)))) (beginning-of-line) (delete-region (point) (point-max)) (insert outp))) (with-output-to-temp-buffer mhc-calendar/select-buffer (display-completion-list (all-completions word mhc-calendar/select-alist))))) (defvar mhc-calendar/select-comp-active nil) (defadvice choose-completion-string (around mhc-calendar-select activate) ad-do-it (when mhc-calendar/select-comp-active (select-window (active-minibuffer-window)))) (defun mhc-calendar/select-comp (&optional prompt active) (let ((minibuffer-setup-hook minibuffer-setup-hook) (ret "")) (unless prompt (setq prompt "Select: ")) (unwind-protect (progn ;; Select minibuffer forcibly (setq mhc-calendar/select-comp-active t) ;; completion buffer setup (when active (add-hook 'minibuffer-setup-hook 'mhc-calendar/select-comp-setup)) (setq ret (read-from-minibuffer prompt nil mhc-calendar/select-map nil 'mhc-calendar/select-hist))) (setq mhc-calendar/select-comp-active nil) (remove-hook 'minibuffer-setup-hook 'mhc-calendar/select-comp-setup) (and (buffer-live-p (get-buffer mhc-calendar/select-buffer)) (kill-buffer mhc-calendar/select-buffer)) ret))) ;; inserter (defun mhc-calendar/get-day-list-func (form) (let (func) (cond ((stringp form) form) ((symbolp form) (setq func (intern-soft (concat "mhc-calendar/inserter-" (symbol-name form)))) (and func (funcall func)))))) (defun mhc-calendar/inserter-yy () (format "%4d" yy)) (defun mhc-calendar/inserter-nengo () (if (> yy 1987) (format "平成%2d年" (- yy 1988)) (if (> yy 1924) (format "昭和%2d年" (- yy 1925)) "昔々"))) (defun mhc-calendar/inserter-mm () (format "%d" mm)) (defun mhc-calendar/inserter-mm02 () (format "%02d" mm)) (defun mhc-calendar/inserter-mm2 () (format "%2d" mm)) (defun mhc-calendar/inserter-mm-string () (mhc-date-digit-to-mm-string mm)) (defun mhc-calendar/inserter-mm-string-long () (mhc-date-digit-to-mm-string mm t)) (defun mhc-calendar/inserter-dd () (format "%d" dd)) (defun mhc-calendar/inserter-dd02 () (format "%02d" dd)) (defun mhc-calendar/inserter-dd2 () (format "%2d" dd)) (defun mhc-calendar/inserter-ww () (format "%d" ww)) (defun mhc-calendar/inserter-ww-string () (mhc-date-digit-to-ww-string ww)) (defun mhc-calendar/inserter-ww-string-long () (mhc-date-digit-to-ww-string ww t)) (defun mhc-calendar/inserter-ww-japanese () (mhc-date-digit-to-ww-japanese-string ww)) (defun mhc-calendar/inserter-ww-japanese-long () (mhc-date-digit-to-ww-japanese-string ww t)) (defun mhc-calendar/get-day-list (date &optional datelst dateend) (let (lst-org formlst retlst retlst2 ret con) (setq lst-org (or datelst mhc-calendar-inserter-date-list)) (setq datelst lst-org) ;; begin (mhc-date-let date (while datelst (setq formlst (car (car datelst))) (setq ret nil) (while formlst (setq ret (concat ret (mhc-calendar/get-day-list-func (car formlst)))) (setq formlst (cdr formlst))) (setq retlst (cons ret retlst)) (setq datelst (cdr datelst)))) (setq retlst (nreverse retlst)) (if (not dateend) retlst ;; return ;; duration (setq datelst lst-org) (mhc-date-let dateend (while datelst (setq con (cdr (car datelst))) (if (listp con) ;; multiple connectoer (while con (setq formlst (car (car datelst))) (setq ret (car con)) (while formlst (setq ret (concat ret (mhc-calendar/get-day-list-func (car formlst)))) (setq formlst (cdr formlst))) (setq retlst2 (cons (concat (car retlst) ret) retlst2)) (setq con (cdr con))) (setq formlst (car (car datelst))) (setq ret (cdr (car datelst))) (while formlst (setq ret (concat ret (mhc-calendar/get-day-list-func (car formlst)))) (setq formlst (cdr formlst))) (setq retlst2 (cons (concat (car retlst) ret) retlst2))) (setq retlst (cdr retlst)) (setq datelst (cdr datelst)))) (nreverse retlst2)))) ;; scan & move functions (defun mhc-calendar-scan (&optional hide-private) (interactive "P") (let ((date (mhc-calendar-get-date))) (mhc-calendar-quit) (mhc-goto-month date hide-private) (goto-char (point-min)) (if (mhc-summary-search-date date) (progn (beginning-of-line) (if (not (pos-visible-in-window-p (point))) (recenter)))))) (defun mhc-calendar-quit () (interactive) (let ((win (get-buffer-window mhc-calendar/buffer)) (buf (get-buffer mhc-calendar/buffer))) (save-excursion (set-buffer buf) (mhc-calendar/delete-overlay)) (if (null win) () (bury-buffer buf) (if (null (one-window-p)) (delete-windows-on buf) (set-window-buffer win (other-buffer)) (select-window (next-window)))))) (defun mhc-calendar-input-exit () (setq mhc-calendar/inserter-type nil) (setq mhc-calendar/inserter-call-buffer nil)) (defun mhc-calendar-exit () (interactive) (mhc-calendar-quit) (remove-hook 'post-command-hook 'mhc-calendar/duration-show) (kill-buffer (get-buffer mhc-calendar/buffer))) (defun mhc-calendar-goto-month (&optional date) (interactive) (mhc-calendar/goto-date (if (integerp date) date (mhc-input-month "Month ")))) (defun mhc-calendar-rescan () (interactive) (set-buffer (get-buffer mhc-calendar/buffer)) (let ((cdate mhc-calendar-date) (pdate (mhc-calendar-get-date))) (setq mhc-calendar-date nil) (mhc-calendar/create-buffer cdate) (mhc-calendar/goto-date pdate))) (defun mhc-calendar-goto-home () (interactive) (setq mhc-calendar-view-summary (not (and (eq last-command 'mhc-calendar-goto-home) mhc-calendar-view-summary))) (mhc-calendar/goto-date (mhc-calendar-get-date)) (set-window-start (selected-window) (point-min))) (defun mhc-calendar-next-day (&optional arg) (interactive "p") (let ((date (mhc-calendar-get-date))) (mhc-calendar/goto-date (+ date arg)))) (defun mhc-calendar-prev-day (&optional arg) (interactive "p") (mhc-calendar-next-day (- arg))) (defun mhc-calendar-next-week (&optional arg) (interactive "p") (if (or (mhc-calendar/in-summary-p) (mhc-calendar/in-summary-hnf-p)) (let ((pos (point))) (forward-line) (if (eobp) (goto-char pos))) (mhc-calendar-next-day (* arg 7)))) (defun mhc-calendar-prev-week (&optional arg) (interactive "p") (if (or (mhc-calendar/in-summary-p) (mhc-calendar/in-summary-hnf-p)) (let ((pos (point))) (forward-line -1) (if (or (mhc-calendar/in-summary-p) (mhc-calendar/in-summary-hnf-p)) () (goto-char pos))) (mhc-calendar-next-day (- (* arg 7))))) (defun mhc-calendar-next-month (&optional arg) (interactive "p") (mhc-calendar/goto-date (mhc-date-mm+ (mhc-calendar-get-date) arg))) (defun mhc-calendar-prev-month (&optional arg) (interactive "p") (mhc-calendar-next-month (- arg))) (defun mhc-calendar-next-year (&optional arg) (interactive "p") (mhc-calendar/goto-date (mhc-date-yy+ (mhc-calendar-get-date) arg))) (defun mhc-calendar-prev-year (&optional arg) (interactive "p") (mhc-calendar-next-year (- arg))) (defun mhc-calendar-inc-month (&optional arg) (interactive "p") (set-buffer (get-buffer mhc-calendar/buffer)) (let* ((dnew (mhc-date-mm+ mhc-calendar-date arg)) (ddold (mhc-date-dd (mhc-calendar-get-date))) (dnew2 (mhc-date-let dnew (if (mhc-date/check yy mm ddold) (mhc-date-new yy mm ddold) (mhc-date-new yy mm (mhc-date/last-day-of-month yy mm)))))) (mhc-calendar/create-buffer dnew) (mhc-calendar/goto-date dnew2))) (defun mhc-calendar-dec-month (&optional arg) (interactive "p") (mhc-calendar-inc-month (- arg))) (defun mhc-calendar-get-date () (when (mhc-calendar-p) (if (mhc-calendar/in-date-p) (mhc-calendar/in-date-p) (if (or (mhc-calendar/in-summary-p) (mhc-calendar/in-summary-hnf-p)) mhc-calendar-view-date (let* ((pos (point)) (col (current-column)) (colnum (mhc-calendar/get-date-colnum col)) (line (+ (count-lines (point-min) (point)) (if (= col 0) 1 0))) (date (mhc-date-mm+ mhc-calendar-date colnum)) (date1 (mhc-date-mm-first date)) (datelast (mhc-date-mm-last date)) daypos) (cond ((< line 3) date1) ((> line 9) datelast) (t (setq daypos (next-single-property-change (point) 'mhc-calendar/date-prop)) (if daypos (progn (goto-char daypos) (if (= colnum (mhc-calendar/get-date-colnum (current-column))) (mhc-calendar/in-date-p) (goto-char pos) (if (or (and (goto-char (previous-single-property-change (point) 'mhc-calendar/date-prop)) (mhc-calendar/in-date-p)) (and (goto-char (previous-single-property-change (point) 'mhc-calendar/date-prop)) (mhc-calendar/in-date-p))) (if (= colnum (mhc-calendar/get-date-colnum (current-column))) (mhc-calendar/in-date-p) datelast) datelast))) datelast)))))))) (defun mhc-calendar-view-date () (and (mhc-calendar-p) mhc-calendar-view-date)) ;; mouse function (defun mhc-calendar-day-at-mouse (event) (interactive "e") (set-buffer (mhc-calendar/event-buffer event)) (pop-to-buffer (mhc-calendar/event-buffer event)) (goto-char (mhc-calendar/event-point event)) (cond ((mhc-calendar/in-date-p) (mhc-calendar-goto-home)) ((mhc-calendar/in-summary-p) (mhc-calendar/view-file (mhc-calendar/in-summary-p))) ((mhc-calendar/in-summary-hnf-p) (mhc-calendar/hnf-view)) (t (message "Nothing to do in this point.")))) ;; mark (defun mhc-calendar-set-mark-command (arg) (interactive "P") (if (null arg) (progn (setq mhc-calendar/mark-date (mhc-calendar-get-date)) (message "Mark set")) (setq mhc-calendar/mark-date nil) (mhc-calendar/duration-show) (message "Mark unset"))) (defun mhc-calendar-exchange-point-and-mark () (interactive) (let ((mark mhc-calendar/mark-date) (date (mhc-calendar-get-date))) (if (null mark) (error "No mark set in this buffer") (setq mhc-calendar/mark-date date) (mhc-calendar/goto-date mark) (mhc-calendar/duration-show)))) ;; post-command-hook (defun mhc-calendar/duration-show () (when (eq this-command 'keyboard-quit) (setq mhc-calendar/mark-date nil)) (if (not (mhc-calendar-p)) (remove-hook 'post-command-hook 'mhc-calendar/duration-show) (when (mhc-calendar-p) (mhc-calendar/delete-overlay) (setq mode-name "mhc-calendar") (when (and mhc-calendar-use-duration-show mhc-calendar/mark-date) (let ((datebeg mhc-calendar/mark-date) (dateend (point)) datetmp pos) (save-excursion (goto-char dateend) (setq dateend (mhc-calendar-get-date)) (when (and datebeg dateend (not (mhc-date= datebeg dateend))) (when (mhc-date> datebeg dateend) (setq datetmp dateend) (setq dateend datebeg) (setq datebeg datetmp)) (when (or (eq mhc-calendar-use-duration-show 'modeline) (eq mhc-calendar-use-duration-show 'mixed)) (setq mode-name (format "mhc-calendar %s-%s" (mhc-date-format datebeg "%04d/%02d/%02d(%s)" yy mm dd (mhc-date-digit-to-ww-string ww)) (mhc-date-format dateend "%04d/%02d/%02d(%s)" yy mm dd (mhc-date-digit-to-ww-string ww))))) (when (or (eq mhc-calendar-use-duration-show 'face) (eq mhc-calendar-use-duration-show 'mixed)) (goto-char (point-min)) (setq datetmp (mhc-calendar-get-date)) (if (mhc-date< datebeg datetmp) (setq datebeg datetmp)) (setq pos t) (while (and pos (mhc-date<= datebeg dateend)) (setq pos (mhc-calendar/tp-any (point-min) (point-max) 'mhc-calendar/date-prop datebeg)) (when pos (overlay-put (make-overlay pos (+ pos 2)) 'face 'mhc-calendar-face-duration)) (setq datebeg (mhc-date++ datebeg))))))) (when (or (eq mhc-calendar-use-duration-show 'modeline) (eq mhc-calendar-use-duration-show 'mixed)) (force-mode-line-update)))))) ;; misc (defun mhc-calendar/delete-overlay () (when (or (eq mhc-calendar-use-duration-show 'face) (eq mhc-calendar-use-duration-show 'mixed)) (let ((ovlin (overlays-in (point-min) (point-max)))) (while ovlin (delete-overlay (car ovlin)) (setq ovlin (cdr ovlin)))))) (defun mhc-calendar/delete-region (yy mm dd pos) (condition-case err (if (mhc-date/check yy mm dd) (progn (delete-region (point) pos) (mhc-date-new yy mm dd)) nil) (error nil))) (defun mhc-calendar-view-exit-action (buff) (kill-buffer buff) (and (get-buffer mhc-calendar/buffer) (mhc-window-pop))) ;; mhc-minibuffer support (defun mhc-minibuf-insert-calendar () (interactive) (let ((yy 1) (mm 1) (dd 1) date pos) (setq mhc-calendar/inserter-type 'minibuffer) (setq mhc-calendar/inserter-call-buffer (current-buffer)) (save-excursion (setq pos (point)) (skip-chars-backward "0-9/") (cond ((looking-at "\\([12][0-9][0-9][0-9]\\)/\\([0-2][0-9]\\)/\\([0-3][0-9]\\)") (setq yy (mhc-calendar/buffer-substring-to-num 1)) (setq mm (mhc-calendar/buffer-substring-to-num 2)) (setq dd (mhc-calendar/buffer-substring-to-num 3)) (setq date (mhc-calendar/delete-region yy mm dd pos))) ((looking-at "\\([12][0-9][0-9][0-9]\\)/\\([0-2][0-9]\\)/?") (setq yy (mhc-calendar/buffer-substring-to-num 1)) (setq mm (mhc-calendar/buffer-substring-to-num 2)) (setq date (mhc-calendar/delete-region yy mm dd pos))) ((looking-at "\\([12][0-9][0-9][0-9]\\)/?") (setq yy (mhc-calendar/buffer-substring-to-num 1)) (setq date (mhc-calendar/delete-region yy mm dd pos))))) (mhc-calendar date))) ;; mhc-draft support (defun mhc-draft-insert-calendar () (interactive) (let ((yy 1) (mm 1) (dd 1) (case-fold-search t) date pos) (setq mhc-calendar/inserter-call-buffer (current-buffer)) (setq mhc-calendar/inserter-type nil) (save-excursion (setq pos (point)) (goto-char (point-min)) (if (and (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$\\|^$") nil t) (< pos (point))) (progn (setq mhc-calendar/inserter-type 'duration) (save-excursion (goto-char pos) (and (re-search-backward "x-[^:]+: " nil t) (looking-at "^x-sc-day: ") (setq mhc-calendar/inserter-type 'day))))) (goto-char pos) (skip-chars-backward "0-9") (cond ((looking-at "\\([12][0-9][0-9][0-9]\\)\\([0-2][0-9]\\)\\([0-3][0-9]\\)") (setq yy (mhc-calendar/buffer-substring-to-num 1)) (setq mm (mhc-calendar/buffer-substring-to-num 2)) (setq dd (mhc-calendar/buffer-substring-to-num 3)) (setq date (mhc-calendar/delete-region yy mm dd pos))) ((looking-at "\\([12][0-9][0-9][0-9]\\)\\([0-2][0-9]\\)") (setq yy (mhc-calendar/buffer-substring-to-num 1)) (setq mm (mhc-calendar/buffer-substring-to-num 2)) (setq date (mhc-calendar/delete-region yy mm dd pos))) ((looking-at "\\([12][0-9][0-9][0-9]\\)") (setq yy (mhc-calendar/buffer-substring-to-num 1)) (setq date (mhc-calendar/delete-region yy mm dd pos))))) (mhc-calendar date))) ;; hnf-mode interface (defun mhc-calendar/hnf-get-filename (date) (expand-file-name (mhc-date-format date "d%04d%02d%02d.hnf" yy mm dd) (if hnf-diary-year-directory-flag (expand-file-name (mhc-date-format date "%04d" yy) hnf-diary-dir) hnf-diary-dir))) (defun mhc-calendar/hnf-file-list (date) (let ((i -1) flst) (setq date (mhc-date-mm+ date -1)) (while (< i 2) (let* ((dir (if hnf-diary-year-directory-flag (expand-file-name (mhc-date-format date "%04d" yy) hnf-diary-dir) (expand-file-name hnf-diary-dir))) (fnexp (mhc-date-format date "d%04d%02d[0-3][0-9]\\.hnf" yy mm))) (if (file-directory-p dir) (setq flst (append (directory-files dir nil fnexp 'no-sort) flst)) (setq flst nil)) (setq date (mhc-date-mm+ date 1)) (setq i (1+ i)))) flst)) (defvar mhc-calendar/hnf-ignore-categories nil) (defun mhc-calendar-hnf-edit (&optional args) (interactive "P") (if (not mhc-calendar-link-hnf) (message "Nothing to do.") (let ((hnffile (mhc-calendar/hnf-get-filename (mhc-calendar-get-date))) (mhcfile (mhc-calendar/in-summary-p)) (count (mhc-calendar/in-summary-hnf-p)) cats subj uri lst) (save-excursion (when (and args mhcfile (file-readable-p mhcfile)) (unless mhc-calendar/hnf-ignore-categories (setq lst mhc-icon-function-alist) (while lst (setq mhc-calendar/hnf-ignore-categories (cons (downcase (car (car lst))) mhc-calendar/hnf-ignore-categories)) (setq lst (cdr lst)))) (with-temp-buffer (insert-file-contents mhcfile) (mhc-decode-header) (mhc-header-narrowing (setq cats (mhc-header-get-value "x-sc-category")) (setq subj (mhc-header-get-value "x-sc-subject")) (setq lst (mhc-misc-split cats)) (when (member "Link" lst) (setq uri (or (mhc-header-get-value "x-uri") (mhc-header-get-value "x-url")))) (setq cats nil) (while lst (unless (member (downcase (car lst)) mhc-calendar/hnf-ignore-categories) (setq cats (cons (car lst) cats))) (setq lst (cdr lst))) (setq cats (nreverse cats)))))) (find-file-other-window hnffile) (hnf-mode) (and (integerp count) (mhc-calendar/hnf-search-title count)) (when subj (goto-char (point-max)) (insert "\n") (when cats (insert (format "CAT %s\n" (mapconcat 'identity cats " ")))) (if uri (insert (format "LNEW %s %s\n" uri subj)) (insert (format "NEW %s\n" subj))))))) ;; xxxxx (defun mhc-calendar/hnf-view () (interactive) (let ((fname (mhc-calendar/hnf-get-filename (mhc-calendar-get-date))) (count (mhc-calendar/in-summary-hnf-p))) (if (not (file-readable-p fname)) (message "File does not exist (%s)." fname) (mhc-window-push) (view-file-other-window fname) (setq view-exit-action 'mhc-calendar-view-exit-action) (and (integerp count) (mhc-calendar/hnf-search-title count))))) (defun mhc-calendar/hnf-search-title (count) (goto-char (point-min)) (while (and (> count 0) (not (eobp))) (re-search-forward "^\\(L?NEW\\|L?SUB\\)[ \t]+" nil t) (setq count (1- count))) (beginning-of-line) (recenter (/ (window-height) 4))) (defun mhc-calendar/hnf-mark-diary-entries () (let ((cdate (mhc-date-mm-first (mhc-date-mm+ mhc-calendar-date -1))) (edate (mhc-date-mm-last (mhc-date-mm+ mhc-calendar-date 1))) (flst (mhc-calendar/hnf-file-list mhc-calendar-date)) (mark "'")) (mhc-face-put mark 'mhc-calendar-hnf-face-mark) (while (<= cdate edate) (if (member (mhc-date-format cdate "d%04d%02d%02d.hnf" yy mm dd) flst) (progn (goto-char (+ 2 (mhc-calendar/tp-any (point-min) (point-max) 'mhc-calendar/date-prop cdate))) (insert mark) (if (eq (char-after (point)) ?\ ) (delete-char 1)))) (setq cdate (1+ cdate))))) (defun mhc-calendar/hnf-summary-insert () (let ((fname (mhc-calendar/hnf-get-filename mhc-calendar-view-date)) (buffer-read-only nil) (newmark "#") (sub "＠") (cat "") (count 1) (ncount 1) new summary str uri) (if (not (file-readable-p fname)) () (goto-char (point-max)) (with-temp-buffer ;; hnf-mode.el require APEL :-) (insert-file-contents fname) (goto-char (point-min)) (mhc-face-put sub 'mhc-calendar-hnf-face-subtag) (while (not (eobp)) (cond ;; CAT ((looking-at "^CAT[ \t]+\\(.*\\)$") (setq cat (buffer-substring (match-beginning 1) (match-end 1))) (while (string-match "[ \t]+" cat) (setq cat (concat (substring cat 0 (match-beginning 0)) "][" (substring cat (match-end 0))))) (setq cat (concat "[" cat "]")) (mhc-face-put cat 'mhc-calendar-hnf-face-cat) (setq cat (concat cat " "))) ;; NEW ((looking-at "^NEW[ \t]+\\(.*\\)$") (setq str (buffer-substring (match-beginning 1) (match-end 1))) (mhc-face-put str 'mhc-calendar-hnf-face-new) (setq new (format "%s%d" newmark ncount)) (mhc-face-put new 'mhc-calendar-hnf-face-newtag) (setq str (concat " " new " " cat str "\n")) (put-text-property 0 (length str) 'mhc-calendar/summary-hnf-prop count str) (setq summary (concat summary str) count (1+ count) ncount (1+ ncount) cat "")) ;; LNEW ((looking-at "^LNEW[ \t]+\\([^ \t]+\\)[ \t]+\\(.*\\)$") (setq uri (concat "<" (buffer-substring (match-beginning 1) (match-end 1)) ">")) (mhc-face-put uri 'mhc-calendar-hnf-face-uri) (setq str (buffer-substring (match-beginning 2) (match-end 2))) (mhc-face-put str 'mhc-calendar-hnf-face-new) (setq new (format "%s%d" newmark ncount)) (mhc-face-put new 'mhc-calendar-hnf-face-newtag) (setq str (concat " " new " " cat str " " uri "\n")) (put-text-property 0 (length str) 'mhc-calendar/summary-hnf-prop count str) (setq summary (concat summary str) count (1+ count) ncount (1+ ncount) cat "")) ;; SUB ((looking-at "^SUB[ \t]+\\(.*\\)$") (setq str (buffer-substring (match-beginning 1) (match-end 1))) (mhc-face-put str 'mhc-calendar-hnf-face-sub) (setq str (concat " " sub " " cat str "\n")) (put-text-property 0 (length str) 'mhc-calendar/summary-hnf-prop count str) (setq summary (concat summary str) count (1+ count) cat "")) ;; LSUB ((looking-at "^LSUB[ \t]+\\([^ \t]+\\)[ \t]+\\(.*\\)$") (setq uri (concat "<" (buffer-substring (match-beginning 1) (match-end 1)) ">")) (mhc-face-put uri 'mhc-calendar-hnf-face-uri) (setq str (buffer-substring (match-beginning 2) (match-end 2))) (mhc-face-put str 'mhc-calendar-hnf-face-sub) (setq str (concat " " sub " " cat str " " uri "\n")) (put-text-property 0 (length str) 'mhc-calendar/summary-hnf-prop count str) (setq summary (concat summary str) count (1+ count) cat ""))) (forward-line))) (if summary (insert "\n" summary)) (delete-char -1) (set-buffer-modified-p nil)))) (defun mhc-calendar-hnf-face-setup () (interactive) (let ((ow (interactive-p))) (mhc-face-setup-internal mhc-calendar-hnf-face-alist ow) (mhc-face-setup-internal mhc-calendar-hnf-face-alist-internal nil))) ;;; Pseudo MUA Backend Methods: (defun mhc-calendar-insert-summary-contents (inserter) (let ((beg (point)) (name (or (mhc-record-name (mhc-schedule-record mhc-tmp-schedule)) "Dummy"))) (funcall inserter) (put-text-property beg (point) 'mhc-calendar/summary-prop name) (insert "\n"))) (provide 'mhc-calendar) (put 'mhc-calendar 'insert-summary-contents 'mhc-calendar-insert-summary-contents) ;;; Copyright Notice: ;; Copyright (C) 1999, 2000 Yoshinari Nomura. All rights reserved. ;; Copyright (C) 2000 MHC developing team. All rights reserved. ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of the team nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' ;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ;; THE TEAM OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, ;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED ;; OF THE POSSIBILITY OF SUCH DAMAGE. ;; mhc-calendar.el ends here yoshinari-nomura-mhc-815a36a/emacs/mhc-cmail.el000066400000000000000000000321531222073515200213640ustar00rootroot00000000000000;;; -*- mode: Emacs-Lisp; coding: utf-8 -*- ;; Author: Yoshinari Nomura ;; Created: 2000/07/18 ;; Revised: $Date: 2008/02/21 03:29:51 $ ;; (autoload 'mhc-cmail-setup "mhc-cmail") ;; (add-hook 'cmail-startup-hook 'mhc-cmail-setup) ;;; Commentary: ;; This file is a part of MHC, includes MUA backend methods for cmail. ;;; Code: (require 'cmail) (condition-case nil (progn (require 'mime-edit) (require 'eword-decode)) (error)) (if (and (featurep 'mime-edit) (featurep 'eword-decode)) (require 'mhc-mime)) ;;; Customize variables: (defcustom mhc-cmail-dummy-file (cond ((file-readable-p "nul") "nul") ((file-readable-p "/dev/null") "/dev/null")) "*Null file name (Ex. \"/dev/null\")." :group 'mhc :type 'file) ;; Internal Variables: (defconst mhc-cmail/summary-filename-regex ".*\r *\\([^ \t\r\n]+\\)") (defconst mhc-cmail/header-string (let ((str "0 | ")) (put-text-property 0 (length str) 'invisible t str) str)) ;; (defconst mhc-cmail/header-string-review ;; (let ((str (concat "0" (char-to-string cmail-mark-review) "| "))) ;; (put-text-property 0 (length str) 'invisible t str) str)) (defconst mhc-cmail/summary-message-alist '((cmail-summary-mode . cmail-readmail-mode))) ;; Setup function: ;;;###autoload (defun mhc-cmail-setup () (interactive) (require 'mhc) (setq mhc-mailer-package 'cmail) (mhc-setup) (add-hook 'cmail-summary-mode-hook 'mhc-mode) (add-hook 'cmail-folders-mode-hook 'mhc-mode) (add-hook 'cmail-quit-hook 'mhc-exit)) ;; Backend methods: (defun mhc-cmail-summary-filename () (save-excursion (beginning-of-line) (if (looking-at mhc-cmail/summary-filename-regex) (buffer-substring-no-properties (match-beginning 1) (match-end 1))))) (defun mhc-cmail-summary-display-article () "Display the article on the current." (cmail-read-contents (cmail-get-page-number-from-summary))) (defun mhc-cmail-get-import-buffer (get-original) ;; (if get-original (cmail-summary-display-asis)) ;; xxx (save-excursion (cmail-show-contents (cmail-get-page-number-from-summary)) (set-buffer *cmail-mail-buffer) (current-buffer))) (defun mhc-cmail-mime-get-raw-buffer () (let ((page (cmail-get-page-number-from-summary)) beg end) (save-excursion (cmail-get-folder) (cmail-n-page page) (setq beg (point)) (setq end (cmail-page-max)) (narrow-to-region beg end) (current-buffer)))) (defun mhc-cmail-mime-get-mime-structure () (let ((page (cmail-get-page-number-from-summary)) beg end) (save-excursion (cmail-get-folder) (cmail-n-page page) (setq beg (point)) (setq end (cmail-page-max)) (narrow-to-region beg end) (get-text-property (point) 'mime-view-entity)))) (defun mhc-cmail/date-to-buffer (date) "**cmail-summary**") (defun mhc-cmail-generate-summary-buffer (date) (switch-to-buffer (set-buffer (mhc-get-buffer-create (mhc-cmail/date-to-buffer date)))) (kill-all-local-variables) (setq inhibit-read-only t buffer-read-only nil selective-display t selective-display-ellipses nil indent-tabs-mode nil) (widen) (delete-region (point-min) (point-max))) (defun mhc-cmail/schedule-foldermsg (schedule) (let ((path (mhc-record-name (mhc-schedule-record schedule)))) (concat "\r " (or path mhc-cmail-dummy-file)))) (defun mhc-cmail-insert-summary-contents (inserter) (insert mhc-cmail/header-string) (funcall inserter) (insert (mhc-cmail/schedule-foldermsg mhc-tmp-schedule) "\n")) (defun mhc-cmail-summary-mode-setup (date) (setq cmail-current-folder (mhc-date-format date "MHC:%04d-%02d" yy mm)) (setq *cmail-disp-thread nil) (let ((cmail-highlight-mode nil)) (cmail-summary-mode) ;; moved code partially from cmail-mode-line-update (setq mode-line-buffer-identification (format "cmail: << %s >>" cmail-current-folder))) (setq selective-display t selective-display-ellipses nil indent-tabs-mode nil) (make-local-variable 'cmail-highlight-mode) (setq cmail-highlight-mode nil) (delete-other-windows)) ;; override cmail functions. (defun cmail-n-page (nth) "NTH番目のメイルの先頭のポインタの値を返す. ポインタも移動する." (if (not (integerp nth)) (progn (mhc-insert-file-contents-as-coding-system *cmail-file-coding-system nth) (goto-char (point-min))) (cmail-rebuild-index) (goto-char (nth nth *cmail-pagelist)))) ;; cmail-get-page-number-from-summary now gets an absolute file name ;; which is in a trail of line. \r path-name. (defun cmail-get-page-number-from-summary (&optional no-err) "サマリからカーソル位置のmailのページ番号を拾う." (cmail-fixcp) (save-excursion (beginning-of-line) (cond ((looking-at mhc-cmail/summary-filename-regex) (buffer-substring (match-beginning 1) (match-end 1))) ((looking-at "^[ +]*\\([0-9]+\\)") (string-to-number (buffer-substring (match-beginning 1) (match-end 1)))) (no-err nil) ((and (boundp 'mhc-mode) mhc-mode) mhc-cmail-dummy-file) (t (cmail-error-resource 'get-page-number-from-summary))))) (fset 'cmail-show-contents-orig (symbol-function 'cmail-show-contents)) ;; if page-or-path is an integer, it works same as original. ;; if not, it includes an MH style file into mail-buffer. ;; (defun cmail-show-contents (page-or-path &optional all-headers) "FOLDERのPAGE番目のメイルを表示する." (interactive (list (cmail-get-page-number-from-summary))) (if (integerp page-or-path) (cmail-show-contents-orig page-or-path all-headers) (setq *cmail-current-folder cmail-current-folder) (setq *cmail-current-page page-or-path) (save-excursion (cmail-select-buffer *cmail-summary-buffer)) (cmail-select-buffer *cmail-mail-buffer) (setq buffer-read-only nil) (erase-buffer) (mhc-insert-file-contents-as-coding-system *cmail-file-coding-system page-or-path) (goto-char (point-min)) (let ((code (detect-coding-region (point-min) (point-max)))) (if (listp code) (setq code (car code))) (decode-coding-region (point-min) (point-max) code)) (setq *cmail-have-all-headers (or all-headers *cmail-show-all-headers)) (or *cmail-have-all-headers (cmail-ignore-headers)) (run-hooks 'cmail-show-contents-hook) (cmail-readmail-mode) (cmail-select-buffer *cmail-summary-buffer))) ;; diffs are only 2 lines: use (equal page) instead of (= page). ;; page may be an absolute filename of MH style file. (defun cmail-read-contents (page) "FOLDERのPAGE番目のメイルを表示・スクロールさせる. 終りまで読むと次のメイルを表示する." (interactive (list (cmail-get-page-number-from-summary))) (let ((disp (get-buffer-window *cmail-mail-buffer))) (if (equal page 0) (progn (setq *cmail-current-folder "") (setq *cmail-current-page 0) (cmail-error-resource 'read-contents-1))) (cmail-select-buffer *cmail-mail-buffer) (cmail-select-buffer *cmail-summary-buffer) (if (or (null disp) (not (string= cmail-current-folder *cmail-current-folder)) (not (equal page *cmail-current-page))) (cmail-show-contents page) (let* ((win (get-buffer-window *cmail-mail-buffer)) (wh (window-height win)) (mbll (save-excursion (set-buffer *cmail-mail-buffer) (count-lines (window-start win) (point-max)))) (cp (/ wh 2)) (swin (get-buffer-window *cmail-summary-buffer)) (swh (window-height swin)) (scp (/ swh 2)) (ccp (count-lines (point-min) (point))) (sll (- swh (count-lines (window-start swin) (point-max))))) (if (or (>= mbll wh) (not (save-window-excursion (select-window (get-buffer-window *cmail-mail-buffer)) (pos-visible-in-window-p (point-max))))) (cmail-scroll-up nil win) (set-buffer *cmail-mail-buffer) (goto-char (point-max)) (widen) (if (/= (point) (point-max)) (progn (forward-line 2) (cmail-narrow-to-page)) (cmail-narrow-to-page) (set-buffer *cmail-summary-buffer) (let ((p (point))) (if (and (< sll 2) (>= ccp scp)) (scroll-up 1)) (and (= p (point)) (forward-line 1))) (if (eobp) (cmail-message-resource 'read-contents-2) (cmail-show-contents (cmail-get-page-number-from-summary))))) (set-buffer *cmail-summary-buffer))) (cmail-fixcp))) (defun mhc-cmail-draft-setup-new () (goto-char (point-min)) (insert mail-header-separator "\n")) (defun mhc-cmail-draft-reedit-buffer (buffer original) ;; If current buffer is specified as buffer, no need to replace. (unless (eq (current-buffer) buffer) (erase-buffer) (insert-buffer buffer)) (goto-char (point-min)) (and (re-search-forward "^$" nil t) (insert mail-header-separator))) (defun mhc-cmail-draft-reedit-file (file) (erase-buffer) (mhc-insert-file-contents-as-coding-system mhc-default-coding-system file) (goto-char (point-min)) (and (re-search-forward "^$" nil t) (insert mail-header-separator))) (defun mhc-cmail-draft-translate () (save-excursion (goto-char (point-min)) (if (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$") nil t) (delete-region (match-beginning 0) (match-end 0))))) (defun mhc-cmail-goto-message (&optional view) "Go to a view position on summary buffer." (when view (cmail-show-contents (cmail-get-page-number-from-summary)))) (provide 'mhc-cmail) (put 'mhc-cmail 'summary-filename 'mhc-cmail-summary-filename) (put 'mhc-cmail 'summary-display-article 'mhc-cmail-summary-display-article) (put 'mhc-cmail 'draft-mode 'mhc-cmail-draft-mode) (put 'mhc-cmail 'generate-summary-buffer 'mhc-cmail-generate-summary-buffer) (put 'mhc-cmail 'insert-summary-contents 'mhc-cmail-insert-summary-contents) (put 'mhc-cmail 'summary-search-date 'mhc-cmail-summary-search-date) (put 'mhc-cmail 'summary-mode-setup 'mhc-cmail-summary-mode-setup) (put 'mhc-cmail 'goto-message 'mhc-cmail-goto-message) (if (featurep 'mhc-mime) (progn (put 'mhc-cmail 'get-import-buffer 'mhc-mime-get-import-buffer) (put 'mhc-cmail 'mime-get-raw-buffer 'mhc-cmail-mime-get-raw-buffer) (put 'mhc-cmail 'mime-get-mime-structure 'mhc-cmail-mime-get-mime-structure) (put 'mhc-cmail 'draft-setup-new 'mhc-mime-draft-setup-new) (put 'mhc-cmail 'draft-reedit-buffer 'mhc-mime-draft-reedit-buffer) (put 'mhc-cmail 'draft-reedit-file 'mhc-mime-draft-reedit-file) (put 'mhc-cmail 'draft-translate 'mhc-mime-draft-translate) (put 'mhc-cmail 'eword-decode-string 'mhc-mime-eword-decode-string)) (put 'mhc-cmail 'get-import-buffer 'mhc-cmail-get-import-buffer) (put 'mhc-cmail 'highlight-message 'mhc-summary/true) (put 'mhc-cmail 'draft-setup-new 'mhc-cmail-draft-setup-new) (put 'mhc-cmail 'draft-reedit-buffer 'mhc-cmail-draft-reedit-buffer) (put 'mhc-cmail 'draft-reedit-file 'mhc-cmail-draft-reedit-file) (put 'mhc-cmail 'draft-translate 'mhc-cmail-draft-translate) (put 'mhc-cmail 'eword-decode-string 'identity)) ;;; Copyright Notice: ;; Copyright (C) 1999, 2000 Yoshinari Nomura. All rights reserved. ;; Copyright (C) 2000 MHC developing team. All rights reserved. ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of the team nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' ;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ;; THE TEAM OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, ;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED ;; OF THE POSSIBILITY OF SUCH DAMAGE. ;;; mhc-cmail.el ends here. yoshinari-nomura-mhc-815a36a/emacs/mhc-compat.el000066400000000000000000000073641222073515200215700ustar00rootroot00000000000000;;; -*- mode: Emacs-Lisp; coding: utf-8 -*- ;; Author: Yoshinari Nomura , ;; TSUCHIYA Masatoshi ;; Created: 2000/05/01 ;; Revised: $Date$ ;;; Commentary: ;; This file is a part of MHC, and includes definitions to absorb ;; incompatibilities between emacsen. ;;; Code: (if (fboundp 'insert-file-contents-as-coding-system) (defalias 'mhc-insert-file-contents-as-coding-system 'insert-file-contents-as-coding-system) (defun mhc-insert-file-contents-as-coding-system (coding-system filename &optional visit beg end replace) "Like `insert-file-contents', q.v., but CODING-SYSTEM the first arg will be applied to `coding-system-for-read'." (let ((coding-system-for-read coding-system) (file-coding-system-for-read coding-system)) (insert-file-contents filename visit beg end replace)))) (if (fboundp 'write-region-as-coding-system) (defalias 'mhc-write-region-as-coding-system 'write-region-as-coding-system) (defun mhc-write-region-as-coding-system (coding-system start end filename &optional append visit lockname) "Like `write-region', q.v., but CODING-SYSTEM the first arg will be applied to `coding-system-for-write'." (let ((coding-system-for-write coding-system) (file-coding-system coding-system)) (write-region start end filename append visit)))) (if (and (fboundp 'regexp-opt) (not (featurep 'xemacs))) (defalias 'mhc-regexp-opt 'regexp-opt) (defun mhc-regexp-opt (strings &optional paren) "Return a regexp to match a string in STRINGS. Each string should be unique in STRINGS and should not contain any regexps, quoted or not. If optional PAREN is non-nil, ensure that the returned regexp is enclosed by at least one regexp grouping construct." (let ((open-paren (if paren "\\(" "")) (close-paren (if paren "\\)" ""))) (concat open-paren (mapconcat 'regexp-quote strings "\\|") close-paren)))) (if (fboundp 'string-to-char-list) (defalias 'mhc-string-to-char-list 'string-to-char-list) (defun mhc-string-to-char-list (string) (string-to-list string))) (provide 'mhc-compat) ;;; Copyright Notice: ;; Copyright (C) 1999, 2000 Yoshinari Nomura. All rights reserved. ;; Copyright (C) 2000 MHC developing team. All rights reserved. ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of the team nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' ;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ;; THE TEAM OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, ;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED ;; OF THE POSSIBILITY OF SUCH DAMAGE. ;;; mhc-compat.el ends here yoshinari-nomura-mhc-815a36a/emacs/mhc-cvs.el000066400000000000000000000547011222073515200210750ustar00rootroot00000000000000;;; -*- mode: Emacs-Lisp; coding: utf-8 -*- ;; Author: TSUCHIYA Masatoshi , ;; Hideyuki SHIRAI ;; Created: 2000/04/25 ;; Revised: $Date$ ;;; Commentary: ;; This file is a part of MHC, includes backend functions to ;; manipulate schedule files with CVS. ;; これは、スケジュールファイルを CVS を通して管理するためのバックエン ;; ドである。CVS を通して管理することによって、複数の PC に分散してい ;; るスケジュールファイルの同期を容易に取ること出来る。 ;;; Usage: ;; スケジュールファイルが既に存在している場合は、既存のスケジュールファ ;; イルを管理するプロジェクトを作成し、スケジュールファイルを削除して ;; おく。 ;; ;; % cd ~/Mail/schedule ;; % cvs import -m 'Initial Schdule' -I '.*' -I trash schedule name start ;; % cd .. ;; % rm -rf schedule ;; ;; スケジュールファイルが存在しない場合は、空のプロジェクトを作っておく。 ;; ;; % mkdir schedule ;; % cd schedule ;; % cvs import -m "Initial Schdule" schedule name start ;; % cd .. ;; % rmdir schedule ;; ;; 更に、以下の設定を ~/.emacs などの適当な場所に追加しておく。 ;; ;; (setq mhc-file-method 'mhc-cvs) ;; ;; これらの準備を行ってから、普通に mhc を呼び出す。そうすると、初回起 ;; 動時に CVS レポジトリの所在を問い合わせるので、適切に入力すると、ス ;; ケジュールファイルを CVS を通して管理するようになる。 ;; もし、決まった CVS レポジトリがあり、標準的な場所でないのなら ;; ;; (setq mhc-cvs-repository-path ":ext:user@server:/cvsroot") ;; ;; のように ~/.emacs に書いておけば、そちらが優先する。また、CVS の ;; module 名が "schedule" (mhc-base-folder 参照) でないのなら、その名前を ;; ;; (setq mhc-cvs-module-name "foo/schedule") ;; ;; のように設定しておくとよい。 ;;; Customize Variables: (defcustom mhc-cvs-rsh (or (getenv "CVS_RSH") "ssh") "*The name of the remote shell command to use when starting a CVS server." :group 'mhc :type '(choice (const :tag "No specification" nil) (const :tag "Use SSH" "ssh") (const :tag "Use RSH" "rsh") (string :tag "Alternative program"))) (defcustom mhc-cvs-global-options (if mhc-default-network-status '("-f" "-w") '("-f" "-w" "-z9")) "*Global options are used when calling CVS." :group 'mhc :type '(repeat (string))) (defcustom mhc-cvs-directory-separator '("/" . "_") "*Separator string for directories" :group 'mhc :type '(cons (string :tag "Directory Separator ") (string :tag "Escape Character "))) (defcustom mhc-cvs-default-update-duration nil "*Default update months duration for mhc-cvs. If 'nil', update all directories. '(-2 . 11) means the duration from 'month before last' to 'this month next year'." :group 'mhc :type '(choice (const :tag "All directories" nil) (cons :tag "Duration" (integer :tag "start month offset" -2) (integer :tag "end month offset " 11)))) (defcustom mhc-cvs-repository-path nil "*CVS repository path." :group 'mhc :type 'string) (defcustom mhc-cvs-module-name nil "*MHC module name." :group 'mhc :type 'string) ;;; Internal Variable: (defvar mhc-cvs/default-directory nil) ;;; Codes: (defconst mhc-cvs/tmp-buffer-name " *mhc-cvs*") (defsubst mhc-cvs/backend (options) "指定されたオプションを付け加えて CVS を実行する関数" (let* ((buffer (mhc-get-buffer-create mhc-cvs/tmp-buffer-name)) (current-buffer (current-buffer)) (ret (unwind-protect (progn (set-buffer buffer) (delete-region (point-min) (point-max)) (let ((default-directory (file-name-as-directory mhc-cvs/default-directory)) (process-environment (copy-sequence process-environment))) (setenv "CVS_RSH" mhc-cvs-rsh) (apply #'call-process "cvs" nil t nil (append mhc-cvs-global-options options)))) (set-buffer current-buffer)))) (if (numberp ret) ret (message "error: mhc-cvs/backend: %s" ret) -1))) (defun mhc-cvs/open (&optional offline) "ネットワークの状態に依存する開始処理関数" (setq mhc-cvs/default-directory (mhc-summary-folder-to-path mhc-base-folder)) (if offline (and (file-directory-p mhc-cvs/default-directory) (file-directory-p (expand-file-name "CVS" mhc-cvs/default-directory))) (if (file-directory-p mhc-cvs/default-directory) (mhc-cvs/sync) (let ((module (file-name-nondirectory (mhc-summary-folder-to-path mhc-base-folder))) (mhc-cvs/default-directory (mhc-summary-folder-to-path ""))) (if mhc-cvs-module-name (mhc-cvs/backend (list"-d" (mhc-cvs/read-repository-path) "checkout" "-d" module mhc-cvs-module-name)) (mhc-cvs/backend (list "-d" (mhc-cvs/read-repository-path) "checkout" module))))))) (defun mhc-cvs/read-repository-path () "CVSレポジトリのパス名を入力する関数" (or mhc-cvs-repository-path (let* ((default (catch 'found (mapcar (lambda (dir) (and (stringp dir) (throw 'found dir))) (list (getenv "CVSROOT") (expand-file-name "~/cvsroot") (expand-file-name "~/CVS"))) nil)) ; 候補が見つからなかった場合 (dir (read-from-minibuffer (if default (format "Input CVS repository path (default %s): " default) "Input CVS repository path: ")))) (if (not (string< "" dir)) default dir)))) (defun mhc-cvs/shrink-file-name (file) "ファイル名の相対パスを得る関数" (file-relative-name (expand-file-name file) (mhc-summary-folder-to-path mhc-base-folder))) (defun mhc-cvs/close (&optional offline) "ネットワークの状態に依存する終了処理関数" (or offline (= 0 (mhc-cvs/backend (list "commit" "-m" ""))))) (defun mhc-cvs/sync (&optional full) "リモートのスケジュールファイルとローカルのスケジュールファイルの同期を取る関数" (mhc-cvs/delay-add-and-remove (mhc-summary-folder-to-path mhc-base-folder)) (mhc-cvs/update full) ;; rescan if mhc (or (and (mhc-summary-buffer-p) (mhc-rescan-month mhc-default-hide-private-schedules)) (and (mhc-calendar-p) (mhc-calendar-rescan))) t) ; return value (defun mhc-cvs/delay-add-and-remove (directory) (let* ((entries (directory-files directory nil nil t)) (dir-entries entries)) (while dir-entries ;; オフライン状態の時に追加されたディレクトリを実際に追加する (when (string-match (concat "^\\.mhc-cvs-added-\\(.*" (regexp-quote (cdr mhc-cvs-directory-separator)) "\\)$") (car dir-entries)) (mhc-cvs/add (expand-file-name (mhc-cvs/recover-directory-separator (substring (car dir-entries) (match-beginning 1) (match-end 1))) directory)) (setq entries (delete (car dir-entries) entries))) (setq dir-entries (cdr dir-entries))) (while entries (cond ;; オフライン状態の時に追加されたファイルを実際に追加する ((string-match "^\\.mhc-cvs-added-" (car entries)) (mhc-cvs/add (expand-file-name (mhc-cvs/recover-directory-separator (substring (car entries) (match-end 0))) directory))) ;; オフライン状態の時に削除されたファイルを実際に削除する ((string-match "^\\.mhc-cvs-removed-" (car entries)) (mhc-cvs/remove (expand-file-name (mhc-cvs/recover-directory-separator (substring (car entries) (match-end 0))) directory)))) (setq entries (cdr entries))))) (defun mhc-cvs/recover-directory-separator (filename) (mapconcat 'identity (mapcar (lambda (s) (mapconcat 'identity (mhc-misc-split s (cdr mhc-cvs-directory-separator)) (car mhc-cvs-directory-separator))) (mhc-misc-split filename (concat (cdr mhc-cvs-directory-separator) (cdr mhc-cvs-directory-separator)))) (cdr mhc-cvs-directory-separator))) (defun mhc-cvs/escape-directory-separator (filename) (mapconcat 'identity (mapcar (lambda (s) (mapconcat 'identity (mhc-misc-split s (car mhc-cvs-directory-separator)) (cdr mhc-cvs-directory-separator))) (mhc-misc-split filename (cdr mhc-cvs-directory-separator))) (concat (cdr mhc-cvs-directory-separator) (cdr mhc-cvs-directory-separator)))) (defun mhc-cvs/get-added-flag-file-name (filename) (let ((dir (mhc-summary-folder-to-path mhc-base-folder))) (expand-file-name (format ".mhc-cvs-added-%s" (mhc-cvs/escape-directory-separator (file-relative-name filename dir))) dir))) (defun mhc-cvs/get-removed-file-name (filename) (let ((dir (mhc-summary-folder-to-path mhc-base-folder))) (expand-file-name (format ".mhc-cvs-removed-%s" (mhc-cvs/escape-directory-separator (file-relative-name filename dir))) dir))) (defun mhc-cvs/add (filename &optional offline) "ファイルを追加する関数" (let ((added (mhc-cvs/get-added-flag-file-name filename)) (removed (mhc-cvs/get-removed-file-name filename))) (if (file-exists-p removed) (delete-file removed)) (if offline (if (file-directory-p filename) (not (write-region "add directory" nil added nil 'nomsg)) (not (copy-file filename added t))) (if (file-exists-p added) (delete-file added)) (and (= 0 (mhc-cvs/backend (list "add" (mhc-cvs/shrink-file-name filename)))) (mhc-cvs/modify filename))))) (defun mhc-cvs/remove (filename &optional offline) "ファイルを削除する関数" (let ((added (mhc-cvs/get-added-flag-file-name filename)) (removed (mhc-cvs/get-removed-file-name filename)) (new-path (expand-file-name "trash" (mhc-summary-folder-to-path mhc-base-folder)))) (or (file-directory-p new-path) (make-directory new-path)) (if offline (progn (if (file-exists-p added) (progn (delete-file added) (rename-file filename (mhc-misc-get-new-path new-path))) (copy-file filename (mhc-misc-get-new-path new-path)) (rename-file filename removed t)) t) ;; return value (if (file-exists-p added) (delete-file added)) (if (file-exists-p removed) (delete-file removed)) (if (file-exists-p filename) (rename-file filename (mhc-misc-get-new-path new-path))) (and (= 0 (mhc-cvs/backend (list "remove" (mhc-cvs/shrink-file-name filename)))) (mhc-cvs/modify filename))))) (defun mhc-cvs/modify (filename &optional offline) "ファイルを変更する関数" (or offline (prog1 (= 0 (mhc-cvs/backend (list "commit" "-m" "" (mhc-cvs/shrink-file-name filename)))) (let ((modes (file-modes filename))) (when modes (set-file-modes filename (logior ?\200 modes))))))) ;;; CVS Backend Function (defsubst mhc-cvs/touch-directory (directory) (mhc-misc-touch-directory directory) (mhc-slot-destruct-cache directory)) (defun mhc-cvs/update-dirs () "mhc-cvs-default-update-duration で指定された範囲の directory を返す" (when mhc-cvs-default-update-duration (let ((cdate (or (mhc-current-date) (mhc-calendar-get-date) (mhc-date-now))) (i (- (cdr mhc-cvs-default-update-duration) (car mhc-cvs-default-update-duration))) dirs schdir) (when (file-directory-p (expand-file-name "intersect" mhc-cvs/default-directory)) (setq dirs (cons "intersect" dirs))) (setq cdate (mhc-date-mm+ cdate (car mhc-cvs-default-update-duration))) (while (>= i 0) (setq schdir (mhc-date-format cdate "%04d/%02d" yy mm)) (when (file-directory-p (expand-file-name schdir (mhc-summary-folder-to-path mhc-base-folder))) (setq dirs (cons schdir dirs))) (setq cdate (mhc-date-mm++ cdate)) (setq i (1- i))) (nreverse dirs)))) (defun mhc-cvs/update (&optional full) "cvs update を実行した結果を解析する関数" ;; ローカルのスケジュールファイルを update する (prog1 (mhc-cvs/backend (append (list "update" "-d" "-I" ".*" "-I" "trash") (and (null full) (mhc-cvs/update-dirs)))) (let (modified-files conflict-files updated-files commit-fault-files unknown-files) ;; update の結果を解析する (let ((buffer (get-buffer mhc-cvs/tmp-buffer-name)) (current-buffer (current-buffer))) (unwind-protect (let ((current-folder)) (set-buffer buffer) (goto-char (point-min)) (while (not (eobp)) (cond ((looking-at "\\? ") (setq unknown-files (cons (buffer-substring (match-end 0) (progn (end-of-line) (point))) unknown-files))) ((looking-at "[AMR] ") (setq modified-files (cons (buffer-substring (match-end 0) (progn (end-of-line) (point))) modified-files))) ((looking-at "C ") (setq conflict-files (cons (buffer-substring (match-end 0) (progn (end-of-line) (point))) conflict-files))) ((looking-at "[UP] ") (setq updated-files (cons (buffer-substring (match-end 0) (progn (end-of-line) (point))) updated-files))) ((looking-at "cvs\\(\.exe\"\\)? \\(update:\\|server:\\) Updating ") (setq current-folder (buffer-substring (match-end 0) (progn (end-of-line) (point))))) ((looking-at "cvs\\(\.exe\"\\)? \\(update:\\|server:\\) warning:") (mhc-cvs/touch-directory (expand-file-name current-folder (mhc-summary-folder-to-path mhc-base-folder))))) (forward-line 1))) (set-buffer current-buffer))) ;; 変更のあったディレクトリの .mhc-mtime を更新しておく (while updated-files (mhc-cvs/touch-directory (file-name-directory (expand-file-name (car updated-files) (mhc-summary-folder-to-path mhc-base-folder)))) (setq updated-files (cdr updated-files))) ;; 修正されているファイルは、即座に commit する (while modified-files (or (= 0 (mhc-cvs/backend (list "commit" "-m" "" (car modified-files)))) (setq commit-fault-files (cons (car modified-files) commit-fault-files))) (setq modified-files (cdr modified-files))) ;; 手動で書いたと思われるファイルを扱う。MHC のデータとして完成していないといけない。 (when unknown-files (mhc-cvs/unknown-file unknown-files)) (if commit-fault-files (message "File(s) are fault to commit: %s" (mapconcat (lambda (s) s) commit-fault-files ","))) ;; 修正が conflict を起こしているファイルは修正して貰う (if conflict-files (mhc-cvs-edit-conflict-file (mapcar (lambda (file) (expand-file-name file (mhc-summary-folder-to-path mhc-base-folder))) conflict-files)))))) (defun mhc-cvs-edit-conflict-file (&optional files) (if (setq files (or files (get 'mhc-cvs-edit-conflict-file 'conflict-files))) (progn (put 'mhc-cvs-edit-conflict-file 'conflict-files (cdr files)) (message "Conflict has been occured. file=%s" (car files)) (mhc-modify-file (car files))) (put 'mhc-cvs-edit-conflict-file 'conflict-files nil))) (defun mhc-cvs/unknown-file (unknowns) (let (dirs files dir file expf char loop mhcp record) (while unknowns (setq expf (expand-file-name (car unknowns) (mhc-summary-folder-to-path mhc-base-folder))) (cond ((and (file-directory-p expf) (or (string-match "^[12][0-9][0-9][0-9]/[01][0-9]$" (car unknowns)) (string-match "^[12][0-9][0-9][0-9]$" (car unknowns)) (string-match "^intersect$" (car unknowns)))) (setq dirs (cons (car unknowns) dirs))) ((and (file-regular-p expf) (or (string-match "^[12][0-9][0-9][0-9]/[01][0-9]/[1-9][0-9]*$" (car unknowns)) (string-match "^intersect/[1-9][0-9]*$" (car unknowns)))) (setq files (cons (car unknowns) files)))) (setq unknowns (cdr unknowns))) (while (setq dir (car dirs)) (setq dirs (cdr dirs)) (mhc-cvs/backend (list "add" dir)) (save-excursion (set-buffer mhc-cvs/tmp-buffer-name) (goto-char (point-min)) (when (looking-at "\\? ") (setq file (buffer-substring (match-end 0) (progn (end-of-line) (point)))) (setq expf (expand-file-name file (mhc-summary-folder-to-path mhc-base-folder))) (cond ((and (file-directory-p expf) (string-match "^[12][0-9][0-9][0-9]/[01][0-9]$" file)) (setq dirs (cons file dirs))) ((and (file-regular-p expf) (or (string-match "^[12][0-9][0-9][0-9]/[01][0-9]/[1-9][0-9]*$" file) (string-match "^intersect/[1-9][0-9]*$" file))) (setq files (cons file files))))))) (while (setq file (car files)) (setq expf (expand-file-name file (mhc-summary-folder-to-path mhc-base-folder))) (with-temp-buffer (insert-file-contents expf) (setq mhcp (mhc-header-narrowing (and (mhc-header-valid-p "x-sc-subject") (mhc-header-valid-p "x-sc-record-id") (or (mhc-header-valid-p "x-sc-day") (mhc-header-valid-p "x-sc-cond"))))) (when mhcp (setq record (mhc-parse-buffer (mhc-record-new expf))))) (when mhcp (setq loop t) (while loop (message "[file: %s] ? A)dd CVS repository, R)emove immediately, M)ove to trash" file) (condition-case nil (setq char (read-char)) (error (setq char ?Z))) ;; dummy set (cond ((memq char '(?a ?A)) (setq loop nil) (message "[file: %s] Add CVS repository..." file) (mhc-record/append-log record 'add) (and (= 0 (mhc-cvs/backend (list "add" file))) (mhc-cvs/modify expf)) (message "[file: %s] Add CVS repository...done" file)) ((memq char '(?r ?R)) (setq loop nil) (message "") (delete-file expf)) ((memq char '(?m ?M)) (setq loop nil) (message "") (rename-file expf (mhc-misc-get-new-path (expand-file-name "trash" (mhc-summary-folder-to-path mhc-base-folder)))))))) (setq files (cdr files))))) (add-hook 'mhc-draft-finish-hook 'mhc-cvs-edit-conflict-file) (provide 'mhc-cvs) (put 'mhc-cvs 'open 'mhc-cvs/open) (put 'mhc-cvs 'close 'mhc-cvs/close) (put 'mhc-cvs 'sync 'mhc-cvs/sync) (put 'mhc-cvs 'add 'mhc-cvs/add) (put 'mhc-cvs 'modify 'mhc-cvs/modify) (put 'mhc-cvs 'remove 'mhc-cvs/remove) ;;; Copyright Notice: ;; Copyright (C) 1999, 2000 Yoshinari Nomura. All rights reserved. ;; Copyright (C) 2000 MHC developing team. All rights reserved. ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of the team nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' ;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ;; THE TEAM OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, ;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED ;; OF THE POSSIBILITY OF SUCH DAMAGE. ;;; mhc-cvs.el ends here. yoshinari-nomura-mhc-815a36a/emacs/mhc-date.el000066400000000000000000000506411222073515200212160ustar00rootroot00000000000000;;; mhc-date.el -- Digit style Date Calculation Lib. ;; Author: Yoshinari Nomura , ;; TSUCHIYA Masatoshi ;; ;; Created: 2000/06/14 ;; Revised: $Date: 2004/05/06 16:35:13 $ ;;; ;;; Commentary: ;;; ;; ;; mhc-date format is simple. It expresses a date by ;; days from 1970/1/1 ;; ;; for example: ;; ;; (mhc-date-new 1970 1 1) -> 0 ;; (mhc-date-new 2000 6 14) -> 11122 ;; ;; mhc-time is also simple. It expresses a time by minits from midnight. ;;; ;;; Code: ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; mhc-time (defsubst mhc-time/check (HH MM) (and (integerp HH) (>= HH 0) (<= HH 99) (integerp MM) (>= MM 0) (<= MM 59))) (defmacro mhc-time-HH (time) `(/ ,time 60)) (defmacro mhc-time-MM (time) `(% ,time 60)) ;; All constructors emit error signal if args are illegal. ;; In case called with noerror is t, return nil quietly. (defsubst mhc-time-new (HH MM &optional noerror) (if (mhc-time/check HH MM) (+ (* HH 60) MM) (if noerror nil (error "mhc-time-new: arg error (%s,%s)" HH MM)))) (defsubst mhc-time-new-from-string (str &optional noerror regexp) (let (ret (match (match-data))) (if (string-match (or regexp "^\\([0-9][0-9]\\):\\([0-9][0-9]\\)$") str) (setq ret (mhc-time-new (mhc-date/substring-to-int str 1) (mhc-date/substring-to-int str 2) t))) (store-match-data match) (if (or noerror ret) ret (error "mhc-time-new-from-string: format error (%s)" str)))) (defsubst mhc-time-now () (let* ((now (decode-time (current-time))) (HH (nth 2 now)) (MM (nth 1 now))) (mhc-time-new HH MM))) ;; xxx: use defmacro for speed !! (defalias 'mhc-time-max 'max) (defalias 'mhc-time-min 'min) (defalias 'mhc-time< '<) (defalias 'mhc-time= '=) (defalias 'mhc-time<= '<=) (defalias 'mhc-time> '>) (defalias 'mhc-time>= '>=) (defun mhc-time-sort (time-list) (sort time-list (function mhc-time<))) (defmacro mhc-time-let (time &rest form) (let ((tempvar (make-symbol "tempvar"))) `(let* ((,tempvar ,time) (hh (mhc-time-HH ,tempvar)) (mm (mhc-time-MM ,tempvar))) ,@form))) (put 'mhc-time-let 'lisp-indent-function 1) (put 'mhc-time-let 'edebug-form-spec '(form body)) (defmacro mhc-time-to-string (time) `(mhc-time-let ,time (format "%02d:%02d" hh mm))) (defsubst mhc-time-to-list (time) (list (mhc-time-HH time) (mhc-time-MM time))) (defalias 'mhc-time+ '+) (defalias 'mhc-time- '-) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; mhc-date ;; ;; special form. ;; (defmacro mhc-date-let (date &rest form) "\ This special form converts DATE, as the number of days since 1970/01/01, to following local variables, and evaluates FORM. yy The year, an integer typically greater than 1900. mm The month of the year, as an integer between 1 and 12. dd The day of the month, as an integer between 1 and 31. ww The day of week, as an integer between 0 and 6, where 0 stands for Sunday. " (let ((tempvar (make-symbol "tempvar"))) `(let* ((,tempvar (mhc-date-to-list ,date)) (yy (nth 0 ,tempvar)) (mm (nth 1 ,tempvar)) (dd (nth 2 ,tempvar)) (ww (nth 3 ,tempvar))) ,@form))) (put 'mhc-date-let 'lisp-indent-function 1) (put 'mhc-date-let 'edebug-form-spec '(form body)) (defmacro mhc-date-let-for-month (date &rest form) "\ This special form converts DATE, as the number of days since 1970/01/01, to following local variables, and evaluates FORM. yy The year, an integer typically greater than 1900. mm The month of the year, as an integer between 1 and 12. dd The day of the month, as an integer between 1 and 31. ww The day of week, as an integer between 0 and 6, where 0 stands for Sunday. oo The order of week, as an integer between 0 and 4. last-p Predicate to check if the dd is in the last week. " (let ((tempvar (make-symbol "tempvar"))) `(let* ((,tempvar (mhc-date-to-list ,date)) (yy (nth 0 ,tempvar)) (mm (nth 1 ,tempvar)) (dd 1) (ww (nth 3 ,tempvar)) (end (mhc-date/last-day-of-month yy mm)) (days ,date) (last-p nil)) (while (<= dd end) ,@form (setq days (mhc-date++ days) dd (1+ dd) oo (/ (1- dd) 7) ww (% (1+ ww) 7) last-p (< (- end 7) dd)))))) (put 'mhc-date-let-for-month 'lisp-indent-function 1) (put 'mhc-date-let-for-month 'edebug-form-spec '(form body)) ;; ;; private ;; (defsubst mhc-date/leap-year-p (yy) (and (zerop (% yy 4)) (or (not (zerop (% yy 100))) (zerop (% yy 400))))) (defsubst mhc-date/last-day-of-month (yy mm) (if (and (= mm 2) (mhc-date/leap-year-p yy)) 29 (aref '[0 31 28 31 30 31 30 31 31 30 31 30 31] mm))) (defsubst mhc-date/check (yy mm dd) (and (integerp yy) (>= yy 1000) (integerp mm) (>= mm 1) (<= mm 12) (integerp dd) (>= dd 1) (<= dd (mhc-date/last-day-of-month yy mm)) t)) (defmacro mhc-date/day-number (yy mm dd) `(if (mhc-date/leap-year-p ,yy) (+ (aref '[0 0 31 60 91 121 152 182 213 244 274 305 335] ,mm) ,dd) (+ (aref '[0 0 31 59 90 120 151 181 212 243 273 304 334] ,mm) ,dd))) (defsubst mhc-date/absolute-from-epoch (yy mm dd) (let ((xx (1- yy))) (+ (mhc-date/day-number yy mm dd) (* xx 365) (/ xx 4) (/ xx -100) (/ xx 400) -719163))) (defsubst mhc-date/iso-week-days (yday wday) (- yday -3 (% (- yday wday -382) 7))) (defmacro mhc-date/substring-to-int (str pos) `(string-to-number (substring ,str (match-beginning ,pos) (match-end ,pos)))) ;; according to our current time zone, ;; convert timezone string into offset minutes ;; ;; for example, if current time zone is in Japan, ;; convert "GMT" or "+0000" into 540. (defun mhc-date/string-to-timezone-offset (timezone) (let ((tz (or (cdr (assoc timezone '(("PST" . "-0800") ("PDT" . "-0700") ("MST" . "-0700") ("MDT" . "-0600") ("CST" . "-0600") ("CDT" . "-0500") ("EST" . "-0500") ("EDT" . "-0400") ("AST" . "-0400") ("NST" . "-0300") ("UT" . "+0000") ("GMT" . "+0000") ("BST" . "+0100") ("MET" . "+0100") ("EET" . "+0200") ("JST" . "+0900")))) timezone)) min offset) (if (string-match "\\([-+]\\)\\([0-9][0-9]\\)\\([0-9][0-9]\\)" tz) (progn (setq min (* (+ (* 60 (mhc-date/substring-to-int tz 2)) (mhc-date/substring-to-int tz 3)) (if (string= "+" (substring tz (match-beginning 1) (match-end 1))) 1 -1)) offset (- (/ (car (current-time-zone)) 60) min)))))) ;; ;; conversion. ;; (defsubst mhc-date-to-second (date) ;; It has workaround in case of 28 bit integer. (let (high low) (setq low (* (+ date (if (< (nth 0 (current-time-zone)) 0) 1 0)) 240) high (/ low 65536) low (* (% low 65536) 360) high (+ (* high 360) (/ low 65536)) low (% low 65536)) (list high low 0))) (defsubst mhc-date/to-list1 (date) (let ((lst (decode-time (mhc-date-to-second date)))) (list (nth 5 lst) (nth 4 lst) (nth 3 lst) (nth 6 lst)))) (defsubst mhc-date/to-list2 (date) (let (x b c d e w dom) (setq w (% (+ date 25568) 7) date (+ date 2440588) x (floor (/ (- date 1867216.25) 36524.25)) b (- (+ date 1525 x) (floor (/ x 4.0))) c (floor (/ (- b 122.1) 365.25)) d (floor (* 365.25 c)) e (floor (/ (- b d) 30.6001)) dom (- b d (floor (* 30.6001 e)))) (if (<= e 13) (list (- c 4716) (1- e) dom w) (list (- c 4715) (- e 13) dom w)))) (defsubst mhc-date-to-list (date) (if (and (<= 0 date) (<= date 24837)) (mhc-date/to-list1 date) (mhc-date/to-list2 date))) ;; ;; constructor. ;; ;; All constructors emit error signal if args are illegal. ;; In case called with noerror is t, return nil quietly. ;; new from 3 digits. (defsubst mhc-date-new (yy mm dd &optional noerror) (if (mhc-date/check yy mm dd) (mhc-date/absolute-from-epoch yy mm dd) (if noerror nil (error "mhc-date-new: arg error (%s,%s,%s)" yy mm dd)))) ;; new from emacs style time such as (14654 3252 689999). (defsubst mhc-date-new-from-second (&optional second) (let ((now (decode-time (or second (current-time))))) (mhc-date/absolute-from-epoch (nth 5 now) (nth 4 now) (nth 3 now)))) ;; new from current time. (defalias 'mhc-date-now 'mhc-date-new-from-second) ;; new from string. 19990101 (defsubst mhc-date-new-from-string (str &optional noerror) (let (ret (match (match-data))) (if (string-match "^\\([0-9][0-9][0-9][0-9]\\)\\([0-9][0-9]\\)\\([0-9][0-9]\\)$" str) (setq ret (mhc-date-new (mhc-date/substring-to-int str 1) (mhc-date/substring-to-int str 2) (mhc-date/substring-to-int str 3) t))) (store-match-data match) (if (or noerror ret) ret (error "mhc-date-new-from-string: format error (%s)" str)))) ;; new from string. [[yyyy/]mm]/dd (defsubst mhc-date-new-from-string2 (str &optional base-date noerror) (mhc-date-let (or base-date (mhc-date-now)) (let ((match (match-data)) fail ret) (cond ((string-match "^\\([0-9][0-9][0-9][0-9]\\)\\([0-9][0-9]\\)\\([0-9][0-9]\\)$" str) (setq yy (mhc-date/substring-to-int str 1) mm (mhc-date/substring-to-int str 2) dd (mhc-date/substring-to-int str 3))) ((string-match "^\\([0-9]+\\)/\\([0-9]+\\)/\\([0-9]+\\)$" str) (setq yy (mhc-date/substring-to-int str 1) mm (mhc-date/substring-to-int str 2) dd (mhc-date/substring-to-int str 3))) ((string-match "^\\([0-9]+\\)/\\([0-9]+\\)$" str) (setq mm (mhc-date/substring-to-int str 1) dd (mhc-date/substring-to-int str 2))) ((string-match "^\\([0-9]+\\)$" str) (setq dd (mhc-date/substring-to-int str 1))) (t (setq fail t))) (store-match-data match) (if (not fail) (setq ret (mhc-date-new yy mm dd t))) (if (or noerror ret) ret (error "mhc-date-new-from-string2: format error (%s)" str))))) ;; regexp for rfc822 Date: field. (defconst mhc-date/rfc822-date-regex ;; assuming ``Tue, 9 May 2000 12:15:12 -0700 (PDT)'' (concat "\\([0-9]+\\)[ \t]+" ;; day "\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|" ;; "Jul\\|Aug\\|Sep\\|Oct\\|Nov\\|Dec\\)[ \t]+" ;; month "\\([0-9]+\\)[ \t]+" ;; year "\\([0-9]+\\):\\([0-9]+\\)\\(:\\([0-9]+\\)\\)?[ \t]*" ;; hh:mm(:ss)? "\\([A-Z][A-Z][A-Z]\\|[-+][0-9][0-9][0-9][0-9]\\)" ;; JST or +0900 )) ;; new from rfc822 Date: field. (defun mhc-date-new-from-string3 (string) (if (and (stringp string) (string-match mhc-date/rfc822-date-regex string)) (let ((dd (mhc-date/substring-to-int string 1)) (mm nil) (mon (substring string (match-beginning 2) (match-end 2))) (yy (mhc-date/substring-to-int string 3)) (MM (+ (* 60 (mhc-date/substring-to-int string 4)) (mhc-date/substring-to-int string 5))) (tz (substring string (match-beginning 8) (match-end 8))) tz-offset) (setq yy (cond ((< yy 50) (+ yy 2000)) ((< yy 100) (+ yy 1900)) (t yy)) mm (1+ (/ (string-match mon "JanFebMarAprMayJunJulAugSepOctNovDec") 3)) tz-offset (mhc-date/string-to-timezone-offset tz) MM (+ MM tz-offset)) (car (cond ((< MM 0) (setq MM (+ MM 1440)) (list (mhc-date-- (mhc-date-new yy mm dd)) (mhc-time-new (/ MM 60) (% MM 60)) tz-offset)) ((>= MM 1440) (setq MM (- MM 1440)) (list (mhc-date++ (mhc-date-new yy mm dd)) (mhc-time-new (/ MM 60) (% MM 60)) tz-offset)) (t (list (mhc-date-new yy mm dd) (mhc-time-new (/ MM 60) (% MM 60)) tz-offset))))))) ;; ;; manipulate yy, mm, dd. ;; (defmacro mhc-date-yy (date) `(nth 0 (mhc-date-to-list ,date))) (defmacro mhc-date-mm (date) `(nth 1 (mhc-date-to-list ,date))) (defmacro mhc-date-dd (date) `(nth 2 (mhc-date-to-list ,date))) (defmacro mhc-date-ww (date) `(nth 3 (mhc-date-to-list ,date))) (defmacro mhc-date-oo (date) `(/ (1- (mhc-date-dd ,date)) 7)) (defsubst mhc-date-cw (date) (mhc-date-let date (let* ((yday (mhc-date/day-number yy mm dd)) (days (mhc-date/iso-week-days yday ww)) (d)) (if (< days 0) (setq days (mhc-date/iso-week-days (+ yday 365 (if (mhc-date/leap-year-p (1- yy)) 1 0)) ww)) (setq d (mhc-date/iso-week-days (- yday 365 (if (mhc-date/leap-year-p yy) 1 0)) ww)) (if (<= 0 d) (setq days d))) (1+ (/ days 7))))) ;; ;; compare. ;; (defalias 'mhc-date= '= ) (defalias 'mhc-date< '< ) (defalias 'mhc-date<= '<= ) (defalias 'mhc-date> '> ) (defalias 'mhc-date>= '>= ) (defalias 'mhc-date-max 'max) (defalias 'mhc-date-min 'min) (defmacro mhc-date-sort (date-list) `(sort ,date-list (function mhc-date<))) (defsubst mhc-date-yy= (d1 d2) (= (mhc-date-yy d1) (mhc-date-yy d2))) (defsubst mhc-date-yy< (d1 d2) (< (mhc-date-yy d1) (mhc-date-yy d2))) (defsubst mhc-date-yy<= (d1 d2) (<= (mhc-date-yy d1) (mhc-date-yy d2))) (defsubst mhc-date-yy> (d1 d2) (mhc-date-yy< d2 d1)) (defsubst mhc-date-yy>= (d1 d2) (mhc-date-yy<= d2 d1)) (defsubst mhc-date-yymm= (d1 d2) (and (mhc-date-yy= d1 d2) (= (mhc-date-mm d1) (mhc-date-mm d2)))) (defsubst mhc-date-yymm< (d1 d2) (or (mhc-date-yy< d1 d2) (and (mhc-date-yy= d1 d2) (< (mhc-date-mm d1) (mhc-date-mm d2))))) (defmacro mhc-date-yymm> (d1 d2) `(mhc-date-yymm< ,d2 ,d1)) (defmacro mhc-date-yymm<= (d1 d2) `(not (mhc-date-yymm> ,d1 ,d2))) (defmacro mhc-date-yymm>= (d1 d2) `(mhc-date-yymm<= ,d2 ,d1)) ;; ;; increment, decrement. ;; (defalias 'mhc-date+ '+ ) (defalias 'mhc-date- '- ) (defalias 'mhc-date++ '1+) (defalias 'mhc-date-- '1-) (defsubst mhc-date-mm+ (date c) (mhc-date-let date (let (xx pp) (setq xx (+ mm c)) (setq pp (if (< 0 xx ) (/ (- xx 1) 12) (/ (- xx 12) 12))) (setq yy (+ yy pp) mm (- xx (* 12 pp))) (if (mhc-date/check yy mm dd) (mhc-date-new yy mm dd) (mhc-date-new yy mm (mhc-date/last-day-of-month yy mm)))))) (defmacro mhc-date-mm- (date c) `(mhc-date-mm+ ,date (- ,c))) (defmacro mhc-date-mm++ (date) `(mhc-date-mm+ ,date 1)) (defmacro mhc-date-mm-- (date) `(mhc-date-mm- ,date 1)) (defsubst mhc-date-yy+ (date c) (mhc-date-let date (setq yy (+ yy c)) (if (mhc-date/check yy mm dd) (mhc-date-new yy mm dd) (mhc-date-new yy mm (mhc-date/last-day-of-month yy mm))))) (defmacro mhc-date-yy- (date c) `(mhc-date-yy+ ,date (- ,c))) (defmacro mhc-date-yy++ (date) `(mhc-date-yy+ ,date 1)) (defmacro mhc-date-yy-- (date) `(mhc-date-yy- ,date 1)) ;; ;; get meaninful date. ;; (defmacro mhc-date-mm-first (date) "Return the number of days since 1970/01/01 to the first day of month, DATE." `(mhc-date-let ,date (mhc-date-new yy mm 1 t))) (defmacro mhc-date-mm-last (date) "Return the number of days since 1970/01/01 to the last day of month, DATE." `(mhc-date-let ,date (mhc-date-new yy mm (mhc-date/last-day-of-month yy mm) t))) ;; ;; predicate ;; ;; check if the date is in the last week of a month. (defsubst mhc-date-oo-last-p (date) (< (- (mhc-date/last-day-of-month (mhc-date-yy date) (mhc-date-mm date)) 7) (mhc-date-dd date))) (defalias 'mhc-date-p 'integerp) ;; ;; miscellaneous. ;; (defmacro mhc-end-day-of-week () `(nth mhc-start-day-of-week '(6 0 1 2 3 4 5))) ;; ;; to string. ;; ;; (mhc-date-format date "%04d%02d%02d" yy mm dd) (defmacro mhc-date-format (date format &rest vars) `(mhc-date-let ,date (format ,format ,@vars))) (defun mhc-date-digit-to-mm-string (mm &optional long) (if long (aref '[nil "January" "February" "March" "April" "May" "June" "July" "August" "September" "October" "November" "December"] mm) (aref [nil "Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"] mm))) (defun mhc-date-digit-to-ww-string (ww &optional long) (if long (aref ["Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"] ww) (aref ["Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat"] ww))) (defun mhc-date-digit-to-ww-japanese-string (ww &optional long) (if long (aref ["日曜日" "月曜日" "火曜日" "水曜日" "木曜日" "金曜日" "土曜日"] ww) (aref ["日" "月" "火" "水" "木" "金" "土"] ww))) (defun mhc-date-digit-to-oo-string (oo &optional long) (aref ["1st" "2nd" "3rd" "4th" "5th"] oo)) ;; format-time-string subset (but has enough spec) (defun mhc-date-format-time-string (format date) (mhc-date-let date (let (head match (ret "") char) (while (string-match "%." format) (setq head (substring format 0 (match-beginning 0)) match (match-string 0 format) format (substring format (match-end 0)) char (aref match 1)) (cond ((eq char ?Y) ;; 100年単位の年 (setq match (format "%d" yy))) ((eq char ?y) ;; 年の下2桁 (00-99) (setq match (format "%02d" (% yy 100)))) ((or (eq char ?b) (eq char ?h)) ;; 月 略称 (setq match (mhc-date-digit-to-mm-string mm))) ((eq char ?B) ;; 月 名称 (setq match (mhc-date-digit-to-mm-string mm t))) ((eq char ?m) ;; 月 (01-12) (setq match (format "%02d" mm))) ((eq char ?d) ;; 日 (ゼロ padding) (setq match (format "%02d" dd))) ((eq char ?e) ;; 日 (空白 padding) (setq match (format "%2d" dd))) ((eq char ?a) ;; 曜日 略称 (setq match (mhc-date-digit-to-ww-string ww))) ((eq char ?A) ;; 曜日 名称 (setq match (mhc-date-digit-to-ww-string ww t)))) (setq ret (concat ret head match))) (concat ret format)))) (provide 'mhc-date) ;;; Copyright Notice: ;; Copyright (C) 1999, 2000 Yoshinari Nomura. All rights reserved. ;; Copyright (C) 2000 MHC developing team. All rights reserved. ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of the team nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' ;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ;; THE TEAM OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, ;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED ;; OF THE POSSIBILITY OF SUCH DAMAGE. ;;; mhc-date.el ends here. yoshinari-nomura-mhc-815a36a/emacs/mhc-day.el000066400000000000000000000117521222073515200210560ustar00rootroot00000000000000;;; -*- mode: Emacs-Lisp; coding: utf-8 -*- ;; Author: Yoshinari Nomura , ;; TSUCHIYA Masatoshi ;; Created: 2000/05/04 ;; Reviesd: $Date$ ;;; Commentary: ;; This file is a part of MHC, and includes functions to manipulate ;; MHC-DAY structure. ;;; About MHC-DAY structure: ;; Each MHC-DAY structure is a cons cell has a construction as ;; follows: ;; ;; MHC-DAY ::= ( KEY . VALUE ) ;; KEY ::= DATE ;; VALUE ::= [ YEAR MONTH DAY-OF-MONTH DAY-OF-WEEK HOLIDAY SCHEDULES ] ;; YEAR ::= integer, larger than 1900. ;; MONTH ::= integer, between 1 and 12. ;; DAY-OF-MONTH ::= integer, between 1 and 31. ;; DAY-OF-WEEK ::= integer, between 0 and 6. ;; HOLIDAY ::= nil or t. t stands for holiday. ;; SCHEDULES ::= MHC-SCHEDULE* ;;; Code: ;; Function and macros to manipulate MHC-DAY structure: (defun mhc-day-new (date year month day-of-month &optional day-of-week holiday schedules) "Constructor of MHC-DAY structure." (cons date (vector year month day-of-month (or day-of-week (mhc-date-ww date)) holiday schedules))) (defmacro mhc-day/key (dayinfo) `(car ,dayinfo)) (defmacro mhc-day/value (dayinfo) `(cdr ,dayinfo)) (defmacro mhc-day-date (dayinfo) `(mhc-day/key ,dayinfo)) (defmacro mhc-day-year (dayinfo) `(aref (mhc-day/value ,dayinfo) 0)) (defmacro mhc-day-month (dayinfo) `(aref (mhc-day/value ,dayinfo) 1)) (defmacro mhc-day-day-of-month (dayinfo) `(aref (mhc-day/value ,dayinfo) 2)) (defmacro mhc-day-day-of-week (dayinfo) `(aref (mhc-day/value ,dayinfo) 3)) (defmacro mhc-day-holiday (dayinfo) `(aref (mhc-day/value ,dayinfo) 4)) (defmacro mhc-day-schedules (dayinfo) `(aref (mhc-day/value ,dayinfo) 5)) (defmacro mhc-day-set-holiday (dayinfo holiday) `(aset (mhc-day/value ,dayinfo) 4 ,holiday)) (defmacro mhc-day-set-schedules (dayinfo schedules) `(aset (mhc-day/value ,dayinfo) 5 ,schedules)) (defun mhc-day-day-of-week-as-string (dayinfo) "Return three letter code of the day of week." (aref ["Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat"] (mhc-day-day-of-week dayinfo))) (defun mhc-day-busy-p (dayinfo) (let ((schedules (mhc-day-schedules dayinfo))) (catch 'busy (while schedules (or (mhc-schedule-in-category-p (car schedules) "holiday") (throw 'busy t)) (setq schedules (cdr schedules)))))) ;; Utility functions: (defmacro mhc-day-let (day &rest form) "\ This special form converts DAY, as the number of days since 1970/01/01, to following local variables, and evaluates FORM. year The year, an integer typically greater than 1900. month The month of the year, as an integer between 1 and 12. day-of-month The day of the month, as an integer between 1 and 31. day-of-week The day of week, as an integer between 0 and 6, where 0 stands for Sunday. " (let ((tempvar (make-symbol "decode-time"))) `(let* ((,tempvar (mhc-date-to-list , day)) (day-of-month (nth 2 ,tempvar)) (month (nth 1 ,tempvar)) (year (nth 0 ,tempvar)) (day-of-week (nth 3 ,tempvar))) ,@form))) (put 'mhc-day-let 'lisp-indent-function 1) (put 'mhc-day-let 'edebug-form-spec '(form body)) (provide 'mhc-day) ;;; Copyright Notice: ;; Copyright (C) 1999, 2000 Yoshinari Nomura. All rights reserved. ;; Copyright (C) 2000 MHC developing team. All rights reserved. ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of the team nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' ;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ;; THE TEAM OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, ;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED ;; OF THE POSSIBILITY OF SUCH DAMAGE. ;;; mhc-day.el ends here. yoshinari-nomura-mhc-815a36a/emacs/mhc-db.el000066400000000000000000000313761222073515200206720ustar00rootroot00000000000000;;; -*- mode: Emacs-Lisp; coding: utf-8 -*- ;; Author: Yoshinari Nomura , ;; TSUCHIYA Masatoshi ;; Created: 2000/05/01 ;; Revised: $Date$ ;;; Commentary: ;; This file is a part of MHC, and includes functions to manipulate ;; database of schedules. ;;; Code: (require 'mhc-day) (require 'mhc-slot) (require 'mhc-schedule) (defun mhc-db/get-sexp-list-for-month (year month) "指定された月のスケジュールを探索するときに、評価するべきS式のリストを得る" (mapcar (lambda (f) (mhc-record-sexp f)) (apply (function nconc) (delq nil (mapcar (lambda (x) (and x (setq x (mhc-slot-records x)) (copy-sequence x))) (list (mhc-slot-get-month-schedule (cons year month)) (mhc-slot-get-intersect-schedule) (mhc-slot-get-constant-schedule))))))) (defun mhc-db/eval-for-duration (from to &optional todo) "\ ある期間 FROM〜TO に対してスケジュールを探索する FROM, TO は 1970/01/01 からの経過日数を用いて指定" (let (list new) (mhc-day-let from (let* ((day from) (week-of-month (/ (1- day-of-month) 7)) ;; FIXME: mhc-date.el の内部関数を呼び出している。 (last-day-of-month (mhc-date/last-day-of-month year month)) (last-week (> 7 (- last-day-of-month day-of-month))) (sexp-list (mhc-db/get-sexp-list-for-month year month))) (while (<= day to) (setq new (mhc-day-new day year month day-of-month day-of-week)) (mhc-day-set-schedules new (delq nil (mapcar (lambda (sexp) (and sexp (funcall sexp))) sexp-list))) (setq list (cons new list) day (1+ day) day-of-month (1+ day-of-month) day-of-week (% (1+ day-of-week) 7)) (if (> day-of-month last-day-of-month) ;; 1ヶ月を超えて連続した探索を行う場合 (setq month (1+ (% month 12)) year (if (= 1 month) (1+ year) year) day-of-month 1 week-of-month 0 last-week nil ;; FIXME: mhc-date.el の内部関数を呼び出している。 last-day-of-month (mhc-date/last-day-of-month year month) sexp-list (mhc-db/get-sexp-list-for-month year month)) ;; 週末毎の処理 (setq week-of-month (/ (1- day-of-month) 7)) (and (not last-week) (> 7 (- last-day-of-month day-of-month)) (setq last-week t))))) (nreverse list)))) (defun mhc-db/eval-for-month (year month &optional todo) "指定された月のスケジュールを探索" (let ((from (mhc-date-new year month 1))) (mhc-db/eval-for-duration from (mhc-date-mm-last from) todo))) (defun mhc-db/holiday-p (dayinfo) (catch 'holiday (let ((schedules (mhc-day-schedules dayinfo))) (while schedules (if (mhc-schedule-in-category-p (car schedules) "holiday") (throw 'holiday t)) (setq schedules (cdr schedules)))))) (defun mhc-db/sort-schedules-by-time (dayinfo) (if (mhc-day-schedules dayinfo) (let (time) (mapcar (function cdr) (sort (mapcar (lambda (schedule) (cons (cond ((setq time (mhc-schedule-time-begin schedule)) time) ((mhc-schedule-in-category-p schedule "holiday") (mhc-day-set-holiday dayinfo t) -1) (t 0)) schedule)) (mhc-day-schedules dayinfo)) (lambda (a b) (< (car a) (car b)))))))) (defun mhc-db-scan (from to &optional nosort) (let ((list (mhc-db/eval-for-duration from to))) (let ((days list)) (if nosort ;; 所用の開始時間に基づく並べ替えは行わずに、祝日のチェックのみを行う (while days (mhc-day-set-holiday (car days) (mhc-db/holiday-p (car days))) (setq days (cdr days))) ;; 所用の開始時間に基づく並べ替えも同時に行う (while days (mhc-day-set-schedules (car days) (mhc-db/sort-schedules-by-time (car days))) (setq days (cdr days))))) list)) (defun mhc-db-scan-month (year month &optional nosort) (let ((list (mhc-db/eval-for-month year month))) (let ((days list)) (if nosort ;; 所用の開始時間に基づく並べ替えは行わずに、祝日のチェックのみを行う (while days (mhc-day-set-holiday (car days) (mhc-db/holiday-p (car days))) (setq days (cdr days))) ;; 所用の開始時間に基づく並べ替えも同時に行う (while days (mhc-day-set-schedules (car days) (mhc-db/sort-schedules-by-time (car days))) (setq days (cdr days))))) list)) (defun mhc-db-scan-todo (day) (mapcar 'cdr (sort (mapcar (lambda (schedule) (cons (mhc-schedule-priority schedule) schedule)) (sort (mhc-day-schedules (mhc-logic-eval-for-date (mhc-day-let day (mhc-db/get-sexp-list-for-month year month)) day 'todo)) (lambda (x y) (< (or (mhc-schedule-todo-deadline x) 65535) (or (mhc-schedule-todo-deadline y) 65535))))) (lambda (a b) (if (and (null (car a)) (car b)) nil (if (and (null (car b)) (car a)) t (if (and (null (car b)) (null (car a))) nil (> (car a) (car b))))))))) (defun mhc-db-scan-memo (day) "行方不明の schedule の取得" (let ((schedules (mapcar (lambda (f) (car (mhc-record-schedules f))) (apply (function nconc) (delq nil (mapcar (lambda (x) (and x (setq x (mhc-slot-records x)) (copy-sequence x))) (list (mhc-slot-get-intersect-schedule))))))) schedule memos) (while (setq schedule (car schedules)) (unless (or (mhc-logic/day (mhc-schedule-condition schedule)) (mhc-logic/and (mhc-schedule-condition schedule)) (and mhc-insert-todo-list (mhc-schedule-in-category-p schedule "todo"))) (setq memos (cons schedule memos))) (setq schedules (cdr schedules))) (mapcar 'cdr (sort (mapcar (lambda (x) (cons (mhc-schedule-priority x) x)) memos) (lambda (a b) (if (and (null (car a)) (car b)) nil (if (and (null (car b)) (car a)) t (if (and (null (car b)) (null (car a))) nil (> (car a) (car b)))))))))) (defun mhc-db-add-record-from-buffer (record buffer &optional force-refile) (let* ((slot (mhc-logic-record-to-slot record)) (directory (and slot (mhc-slot-key-to-directory slot))) (old-record)) (unless slot (error "Cannot get schedule slot")) (if (mhc-record-name record) ;; 既存のスケジュールを編集した場合 (if (string= directory (file-name-directory (directory-file-name (mhc-record-name record)))) (setq old-record record) ;; スケジュール変更によって、ディレクトリの変更が必要な場合 (setq old-record (mhc-record-copy record)) (mhc-record-set-name record (mhc-misc-get-new-path directory))) ;; 新規のスケジュールを保存する場合 (mhc-record-set-name record (mhc-misc-get-new-path directory))) (if (or force-refile (y-or-n-p (format "Refile %s to %s " (mhc-misc-sub (if old-record (mhc-record-name old-record) "") mhc-mail-path "+") (mhc-misc-sub (mhc-record-name record) mhc-mail-path "+")))) (progn (mhc-record-write-buffer record buffer old-record) (if (and old-record (not (eq record old-record))) (let* ((dir (file-name-directory (directory-file-name (mhc-record-name old-record)))) (slot (mhc-slot-directory-to-key dir))) (mhc-misc-touch-directory dir) (mhc-slot-update-cache slot 'remove old-record))) (mhc-misc-touch-directory directory) (mhc-slot-update-cache slot 'add record) t)))) (defun mhc-db-delete-file (record) (let* ((dir (file-name-directory (directory-file-name (mhc-record-name record)))) (slot (mhc-slot-directory-to-key dir))) (mhc-record-delete record) (mhc-misc-touch-directory dir) (mhc-slot-update-cache slot 'remove record))) ;; FIXME: X-SC-Schedule ヘッダによって指定された子スケジュールに対する ;; 例外規則の追加が動作しない。 (defun mhc-db-add-exception-rule (original-record except-day) (let ((date-string (mhc-day-let except-day (format "%04d%02d%02d" year month day-of-month)))) (with-temp-buffer (mhc-draft-reedit-file (mhc-record-name original-record)) (let (record dayinfo schedule) (while (setq record (mhc-parse-buffer) dayinfo (mhc-logic-eval-for-date (list (mhc-record-sexp record)) except-day) schedule (car (mhc-day-schedules dayinfo))) (save-restriction (narrow-to-region (mhc-schedule-region-start schedule) (mhc-schedule-region-end schedule)) (mhc-header-put-value "x-sc-day" (mapconcat 'identity (cons (format "!%s" date-string) (delete date-string (mhc-logic-day-as-string-list (mhc-schedule-condition schedule)))) " ")))) (mhc-record-set-name record (mhc-record-name original-record)) (mhc-db-add-record-from-buffer record (current-buffer)))))) (provide 'mhc-db) ;;; Copyright Notice: ;; Copyright (C) 1999, 2000 Yoshinari Nomura. All rights reserved. ;; Copyright (C) 2000 MHC developing team. All rights reserved. ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of the team nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' ;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ;; THE TEAM OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, ;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED ;; OF THE POSSIBILITY OF SUCH DAMAGE. ;;; mhc-db.el ends here. yoshinari-nomura-mhc-815a36a/emacs/mhc-draft.el000066400000000000000000000202421222073515200213730ustar00rootroot00000000000000;;; mhc-draft.el --- Draft modules for MHC. ;; Author: Yoshinari Nomura , ;; Yuuichi Teranishi ;; Created: 2000/07/25 ;; Revised: $Date: 2008/07/04 06:01:20 $ ;;; Commentary: ;; This file is a part of MHC, includes functions for draft. ;;; About MUA Backend: ;; In order to define new MUA backend, it is required to define these ;; methods. ;; ;; (mhc-foo-draft-setup-new) ;; Setup new draft (Insert header separator). ;; ;; (mhc-foo-draft-reedit-buffer BUFFER ORIGINAL) ;; Restore content of BUFFER as draft in the current buffer. ;; If ORIGINAL is non-nil, use BUFFER as raw buffer. ;; ;; (mhc-foo-draft-reedit-file FILENAME) ;; Restore contents of file FILENAME as draft in the current buffer. ;; ;; (mhc-foo-draft-translate) ;; Translate current buffer to raw buffer. ;; ;; Define these methods appropriately, and put definitions as follows: ;; ;; (put 'mhc-foo 'draft-setup-new 'mhc-foo-draft-setup-new) ;; (put 'mhc-foo 'draft-reedit-buffer 'mhc-foo-draft-reedit-buffer) ;; (put 'mhc-foo 'draft-reedit-file 'mhc-foo-draft-reedit-file) ;; (put 'mhc-foo 'draft-translate 'mhc-foo-draft-translate) ;;; Code: (require 'mhc-summary) ;; Global Variable: (defconst mhc-draft-buffer-name "*mhc draft*") (defcustom mhc-draft-unuse-hdr-list '(">From " "From " "Delivered-To:" "Delivery-date:" "Envelope-to:" "Errors-To:" "Gnus-Warning:" "Lines:" "Posted:" "Precedence:" "Received:" "Replied:" "Return-Path:" "Sender:" "User-Agent:" "X-Bogosity:" "X-Dispatcher:" "X-Filter:" "X-Gnus-Mail-Source:" "X-Mailer:" "X-Received:" "X-Sender:" "X-Seqno:" "X-Spam-Flag:" "X-Spam-Probability:" "X-UIDL:" "Xref:") "*These headers are removed when article is imported." :group 'mhc :type '(repeat string)) (defcustom mhc-draft-mode-hook nil "*Hook run in mhc draft mode buffers." :group 'mhc :type 'hook) ;; Avoid warning of byte-compiler. (defvar mhc-draft-buffer-file-name nil) (defvar mhc-draft-mode-map) (defsubst mhc-draft-setup-new () "Setup new draft (Insert header separator, etc)." (funcall (mhc-get-function 'draft-setup-new))) (defsubst mhc-draft-reedit-buffer (buffer &optional original) "Restore contents of BUFFER as draft in the current buffer. If optional argument ORIGINAL is non-nil, BUFFER is raw buffer." (funcall (mhc-get-function 'draft-reedit-buffer) buffer original)) (defsubst mhc-draft-reedit-file (filename) "Restore contents of file FILENAME as draft in the current buffer." (funcall (mhc-get-function 'draft-reedit-file) filename)) (defsubst mhc-draft-translate () "Translate current buffer to raw buffer." (funcall (mhc-get-function 'draft-translate))) (define-derived-mode mhc-draft-mode text-mode "MHC-Draft" "Major mode for editing schdule files of MHC. Like Text Mode but with these additional commands: C-c C-c mhc-draft-finish C-c C-k mhc-draft-kill C-c C-q mhc-draft-kill C-c ? mhc-draft-insert-calendar . " (define-key mhc-draft-mode-map "\C-c\C-c" 'mhc-draft-finish) (define-key mhc-draft-mode-map "\C-c\C-q" 'mhc-draft-kill) (define-key mhc-draft-mode-map "\C-c\C-k" 'mhc-draft-kill) (define-key mhc-draft-mode-map "\C-c?" 'mhc-draft-insert-calendar) (make-local-variable 'adaptive-fill-regexp) (setq adaptive-fill-regexp (concat "[ \t]*[-a-z0-9A-Z]*\\(>[ \t]*\\)+[ \t]*\\|" adaptive-fill-regexp)) (unless (boundp 'adaptive-fill-first-line-regexp) (setq adaptive-fill-first-line-regexp nil)) (make-local-variable 'adaptive-fill-first-line-regexp) (setq adaptive-fill-first-line-regexp (concat "[ \t]*[-a-z0-9A-Z]*\\(>[ \t]*\\)+[ \t]*\\|" adaptive-fill-first-line-regexp)) (mhc-highlight-message t) (set (make-local-variable 'indent-tabs-mode) nil)) (defun mhc-draft-kill (&optional no-confirm) "Kill current draft. If optional argument NO-CONFIRM is non-nil, kill without confirmation." (interactive "P") (if (or no-confirm (y-or-n-p "Kill draft buffer? ")) (progn (message "") (mhc-calendar-input-exit) (kill-buffer (current-buffer)) (mhc-window-pop)))) (defvar mhc-draft-finish-hook nil "Hook run after `mhc-draft-finish'.") (defun mhc-draft-set-as-done () "Set current draft as DONE." (interactive) (if (mhc-draft-in-category-p "todo") (mhc-draft-append-category "Done"))) (defun mhc-draft-set-as-not-done () "Set current draft as NOT-DONE." (interactive) (if (mhc-draft-in-category-p "todo") (mhc-draft-delete-category "done"))) (defun mhc-draft-toggle-done () "Set current draft as DONE if not; remove done if there." (interactive) (if (mhc-draft-in-category-p "todo") (if (mhc-draft-in-category-p "done") (mhc-draft-delete-category "done") (mhc-draft-append-category "Done")))) (defun mhc-draft-append-category (category) "Append CATEGORY if it is not contained yet." (mhc-header-narrowing (let ((categories (mhc-header-get-value "x-sc-category"))) (unless (string-match category categories) (mhc-header-put-value "x-sc-category" (concat categories " " category)))))) (defun mhc-draft-in-category-p (category) (mhc-header-narrowing (string-match (concat "[ \t]*" category) (mhc-header-get-value "x-sc-category")))) (defun mhc-draft-delete-category (category) "Delete CATEGORY if it is contained." (mhc-header-narrowing (let ((categories (mhc-header-get-value "x-sc-category"))) (when (string-match (concat "[ \t]*" category) categories) (setq categories (concat (substring categories 0 (match-beginning 0)) (substring categories (match-end 0)))) (when (string-match "[ \t]+$" categories) (setq categories (substring categories 0 (match-beginning 0)))) (mhc-header-put-value "X-SC-Category" categories))))) (defun mhc-draft-finish () "Add current draft as a schedule." (interactive) (let ((record (mhc-parse-buffer (mhc-record-new mhc-draft-buffer-file-name) 'strict))) (mhc-calendar-input-exit) (if (mhc-db-add-record-from-buffer record (current-buffer) (not (interactive-p))) (progn (kill-buffer (current-buffer)) (mhc-window-pop) (or (and (mhc-summary-buffer-p) (mhc-rescan-month mhc-default-hide-private-schedules)) (and (mhc-calendar-p) (mhc-calendar-rescan))) (run-hooks 'mhc-draft-finish-hook))))) (provide 'mhc-draft) ;;; Copyright Notice: ;; Copyright (C) 1999, 2000 Yoshinari Nomura. All rights reserved. ;; Copyright (C) 2000 MHC developing team. All rights reserved. ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of the team nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' ;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ;; THE TEAM OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, ;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED ;; OF THE POSSIBILITY OF SUCH DAMAGE. ;;; mhc-draft.el ends here yoshinari-nomura-mhc-815a36a/emacs/mhc-e21.el000066400000000000000000000141621222073515200206660ustar00rootroot00000000000000;;; mhc-e21.el -- Emacs 21 stuff for MHC. ;; Author: Yuuichi Teranishi ;; ;; Created: 2000/11/21 ;; Revised: $Date: 2008/03/06 09:40:12 $ (defcustom mhc-e21-icon-alist '(("Conflict" . "Conflict.xpm") ("Recurrence" . "Recurrence.xpm") ("Private" . "Private.xpm") ("Holiday" . "Holiday.xpm") ("Todo" . "CheckBox.xpm") ("Done" . "CheckedBox.xpm") ("Link" . "Link.xpm")) "*Alist to define icons. Each element should have the form (NAME . ICON-FILE) It defines icon named NAME created from ICON-FILE. Example: '((\"Holiday\" . \"Holiday.xpm\") (\"Work\" . \"Business.xpm\") (\"Private\" . \"Private.xpm\") (\"Anniversary\" . \"Anniversary.xpm\") (\"Birthday\" . \"Birthday.xpm\") (\"Other\" . \"Other.xpm\") (\"Todo\" . \"CheckBox.xpm\") (\"Done\" . \"CheckedBox.xpm\") (\"Conflict\" . \"Conflict.xpm\"))" :group 'mhc :type '(repeat :inline t (cons (string :tag "Icon Name") (string :tag "XPM File Name")))) (defcustom mhc-icon-function-alist '(("Todo" . mhc-todo-set-as-done) ("Done" . mhc-todo-set-as-not-done) ("Link" . mhc-browse-x-url)) "*Alist to define callback function for icons. Each element should have the form (NAME . FUNCTION) If the icon named NAME is clicked, then FUNCTION is invoked at icon line." :group 'mhc :type '(repeat :inline t (cons (string :tag "Icon Name") (function :tag "Function")))) (defvar mhc-e21-icon-keymap nil) (if (null mhc-e21-icon-keymap) (setq mhc-e21-icon-keymap (make-sparse-keymap))) (define-key mhc-e21-icon-keymap [mouse-1] 'mhc-e21-icon-call-function) (define-key mhc-e21-icon-keymap [mouse-2] 'mhc-e21-icon-call-function) (defun mhc-e21-icon-call-function (event) (interactive "e") (save-excursion (mouse-set-point event) (when (get-text-property (point) 'mhc-e21-icon-function) (call-interactively (get-text-property (point) 'mhc-e21-icon-function)) t))) ;; internal variable. (defvar mhc-e21/icon-glyph-alist nil) (defvar mhc-e21/icon-function-alist nil) (defsubst mhc-e21/setup-icons () (let ((alist mhc-e21-icon-alist) name image (load-path (cons mhc-icon-path load-path))) (setq mhc-e21/icon-glyph-alist nil) (while alist (setq image (find-image (list (list :type 'xpm :file (cdr (car alist)) :ascent 'center)))) (when image (setq mhc-e21/icon-glyph-alist (cons (cons (downcase (car (car alist))) image) mhc-e21/icon-glyph-alist))) (setq alist (cdr alist))) (setq mhc-e21/icon-function-alist (mapcar (lambda (pair) (cons (downcase (car pair)) (cdr pair))) mhc-icon-function-alist)))) ;; Icon interface (defun mhc-icon-setup () "Initialize MHC icons." (interactive) (if (interactive-p) (setq mhc-e21/icon-glyph-alist nil)) (or mhc-e21/icon-glyph-alist (progn (message "Initializing MHC icons...") (mhc-e21/setup-icons) (run-hooks 'mhc-icon-setup-hook) (message "Initializing MHC icons...done")))) (defun mhc-use-icon-p () "Returns t if MHC displays icon." (and (display-graphic-p) (image-type-available-p 'xpm) mhc-use-icon)) (defun mhc-icon-exists-p (name) "Returns non-nil if icon with NAME exists." (cdr (assoc (downcase name) mhc-e21/icon-glyph-alist))) (defun mhc-put-icon (icons) "Put ICONS on current buffer. Icon is decided by `mhc-e21-icon-alist'." (let (icon pos func props) (while icons (when (setq icon (cdr (assoc (downcase (car icons)) mhc-e21/icon-glyph-alist))) (setq pos (point)) (insert (make-string (floor (car (image-size icon))) ? )) (setq props (list 'display icon 'invisible nil 'intangible icon)) (when (setq func (cdr (assoc (downcase (car icons)) mhc-e21/icon-function-alist))) (setq props (nconc props (list 'mouse-face 'highlight 'mhc-e21-icon-function func 'local-map mhc-e21-icon-keymap)))) (add-text-properties pos (point) props)) (setq icons (cdr icons))))) (provide 'mhc-e21) ;;; Copyright Notice: ;; Copyright (C) 1999, 2000 Yoshinari Nomura. All rights reserved. ;; Copyright (C) 2000 MHC developing team. All rights reserved. ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of the team nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' ;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ;; THE TEAM OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, ;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED ;; OF THE POSSIBILITY OF SUCH DAMAGE. ;;; mhc-e21.el ends here yoshinari-nomura-mhc-815a36a/emacs/mhc-face.el000066400000000000000000000231231222073515200211720ustar00rootroot00000000000000;;; mhc-face.el ;; Author: Yoshinari Nomura ;; ;; Created: 2000/02/08 ;; Revised: $Date: 2004/05/04 13:48:31 $ ;;; ;;; Commentay: ;;; ;;; ;;; Code: ;;; (defvar mhc-symbol-face-alist nil "*Alist which is used in setup time to define required faces. Each element should have the form (FACE-SYMBOL . (PARENT FG BG UNDERLINED FONT STIPPLE)) If this variable does't have necessary face definitions for mhc, mhc will lookup them from mhc-symbol-face-alist-internal instead. So, this variable doesn't have to cover all the face definitions.") (defvar mhc-category-face-alist nil "*Alist to rule the catgegory-to-face conversion. Each element should have the form (CATEGORY-STRING . (PARENT FG BG UNDERLINED FONT STIPPLE)) mhc will define mhc-summary-category-face-(downcase CATEGORY-STRING) in setup time.") (defvar mhc-calendar-hnf-face-alist nil "*Alist of HNS faces. Each element should have the form (FACE-SYMBOL . (PARENT FG BG UNDERLINED FONT STIPPLE)). refer to mhc-calendar-hnf-face-alist-internal.") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; for necessary faces. (defconst mhc-symbol-face-alist-internal '((mhc-calendar-face-default . (nil nil nil)) (mhc-calendar-face-saturday . (nil "blue" nil)) (mhc-calendar-face-sunday . (nil "red" nil)) (mhc-calendar-face-duration . (nil nil "gray")) (mhc-calendar-face-cw . (nil "slate gray" nil)) ;; (mhc-summary-face-default . (nil nil nil)) (mhc-summary-face-saturday . (nil "blue" nil)) (mhc-summary-face-sunday . (nil "red" nil)) (mhc-summary-face-today . (nil "black" "chocolate")) (mhc-summary-face-cw . (nil "slate gray" nil)) ;; (mhc-summary-face-separator . (nil "gray" nil)) (mhc-summary-face-month-separator . (nil "DarkKhaki" nil)) (mhc-summary-face-time . (nil "yellowgreen" nil)) (mhc-summary-face-location . (nil "black" "paleturquoise")) (mhc-summary-face-conflict . (nil "white" "purple")) (mhc-summary-face-recurrence . (nil "black" "green")) (mhc-summary-face-secret . (nil "gray" nil)) ;; (mhc-minibuf-face-candidate . (nil nil "yellow")) ;; (mhc-category-face-holiday . (nil "red" nil)))) (defconst mhc-calendar-hnf-face-alist-internal '((mhc-calendar-hnf-face-mark . (nil "MediumSeaGreen" nil)) (mhc-calendar-hnf-face-newtag . (italic "red" "paleturquoise")) (mhc-calendar-hnf-face-subtag . (italic "blue" nil)) (mhc-calendar-hnf-face-cat . (nil "DarkGreen" nil)) (mhc-calendar-hnf-face-new . (bold "DarkGreen" nil)) (mhc-calendar-hnf-face-sub . (nil "DarkGreen" nil)) (mhc-calendar-hnf-face-uri . (italic "blue" nil)))) (defmacro mhc-face-put (symbol face) `(put-text-property 0 (length ,symbol) 'face ,face ,symbol)) (eval-when-compile (cond ((featurep 'xemacs) ;; XEmacs 21.2 (make-face-bold FACE &optional LOCALE TAGS) ;; XEmacs 21.1 (make-face-bold FACE &optional LOCALE) (defmacro mhc-face/make-face-bold (face) `(make-face-bold ,face)) (defmacro mhc-face/make-face-italic (face) `(make-face-italic ,face)) (defmacro mhc-face/make-face-bold-italic (face) `(make-face-bold-italic ,face))) (t ;; (make-face-bold FACE &optional FRAME NOERROR) (defmacro mhc-face/make-face-bold (face) `(make-face-bold ,face nil t)) (defmacro mhc-face/make-face-italic (face) `(make-face-italic ,face nil t)) (defmacro mhc-face/make-face-bold-italic (face) `(make-face-bold-italic ,face nil t))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; make faces from string/symbol (defun mhc-face-category-to-face (category) (if category (or (intern-soft (format "mhc-category-face-%s" (downcase category))) 'default) 'default)) (defun mhc-face-make-face-from-string (string prop &optional overwrite prefix) (let ((symbol-name (concat prefix (if prefix "-") string))) (mhc-face-make-face-from-symbol (intern symbol-name) prop overwrite))) (defun mhc-face-make-face-from-symbol (symbol prop &optional overwrite) (let ((parent (nth 0 prop)) (fg (nth 1 prop)) (bg (nth 2 prop)) (uline (nth 3 prop)) (font (nth 4 prop)) (stipple (nth 5 prop)) (face nil)) (if (and (mhc-facep symbol) (not overwrite)) symbol (setq face (if parent (copy-face parent symbol) (make-face symbol))) (if fg (set-face-foreground face fg)) (if bg (set-face-background face bg)) (set-face-underline-p face uline) (if font (set-face-font face font)) (if stipple (set-face-stipple face stipple)) face))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; make faces arrange. (defvar mhc-face-effect-alist ;; fg bg bold talic ul '((today . (nil "gray" nil nil nil)) (busy . (nil nil t nil nil)) (saturday . ("Blue" nil nil nil nil)) (sunday . ("Red" nil nil nil nil)))) ;; get decolated face from face and effect ;; ex. mhc-summary-face + today -> mhc-summary-face-today (defun mhc-face-get-effect (face effect) (let ((new-face (intern (concat (symbol-name face) "-" (symbol-name effect)))) effect-list) (if (mhc-facep new-face) () (copy-face face new-face) (if (setq effect-list (cdr (assq effect mhc-face-effect-alist))) (let ((fg (nth 0 effect-list)) (bg (nth 1 effect-list)) (bl (nth 2 effect-list)) (it (nth 3 effect-list)) (ul (nth 4 effect-list))) (if fg (set-face-foreground new-face fg)) (if bg (set-face-background new-face bg)) (if ul (set-face-underline-p new-face t)) ;; (if bl (or (mhc-face/make-face-bold new-face) (and (fboundp 'set-face-bold-p) (set-face-bold-p new-face t)))) ;; (if it (or (mhc-face/make-face-italic new-face) (and (fboundp 'set-face-italic-p) (set-face-italic-p new-face t))))))) new-face)) ;; ;; (make-face-italic new-face nil t)))) (defsubst mhc-face-get-today-face (face) (mhc-face-get-effect face 'today)) (defsubst mhc-face-get-busy-face (face) (mhc-face-get-effect face 'busy)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; setup faces. (defun mhc-face-setup () (interactive) (let ((ow (interactive-p))) ;; (mhc-face-setup-internal mhc-symbol-face-alist ow) (mhc-face-setup-internal mhc-category-face-alist ow) ;; (mhc-face-setup-internal mhc-symbol-face-alist-internal nil) )) (defun mhc-face-setup-internal (alist &optional overwrite) (let (lst) (while (setq lst (car alist)) (cond ((stringp (car lst)) (mhc-face-make-face-from-string (format "mhc-category-face-%s" (downcase (car lst))) (cdr lst) overwrite)) ((symbolp (car lst)) (mhc-face-make-face-from-symbol (car lst) (cdr lst) overwrite))) (setq alist (cdr alist))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; facep for emacs 19.28 (cond ((fboundp 'find-face) (defalias 'mhc-facep 'find-face)) ((fboundp 'facep) (defalias 'mhc-facep 'facep)) (t ;; Introduced in Emacs 19.29. (defun mhc-facep (x) "Return non-nil if X is a face name or an internal face vector." (or (and (fboundp 'internal-facep) (let ((fn 'internal-facep)) ;; Avoid compile warning under old Emacsen. (funcall fn x))) (and (symbolp x) (assq x (and (boundp 'global-face-data) (symbol-value 'global-face-data)))))))) (provide 'mhc-face) ;;; Copyright Notice: ;; Copyright (C) 1999, 2000 Yoshinari Nomura. All rights reserved. ;; Copyright (C) 2000 MHC developing team. All rights reserved. ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of the team nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' ;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ;; THE TEAM OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, ;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED ;; OF THE POSSIBILITY OF SUCH DAMAGE. ;;; mhc-face.el ends here yoshinari-nomura-mhc-815a36a/emacs/mhc-file.el000066400000000000000000000200731222073515200212140ustar00rootroot00000000000000;;; -*- mode: Emacs-Lisp; coding: utf-8 -*- ;; Author: Yoshinari Nomura , ;; TSUCHIYA Masatoshi ;; Created: 2000/05/01 ;; Revised: $Date$ ;;; Comments: ;; This file is a part of MHC, and includes functions to manipulate ;; files of schedules. ;;; About Backend: ;; このライブラリは、実際にファイルを操作するバックエンドを呼び出すこ ;; とによって動作する。バックエンドは、以下のようなメソッドを提供する ;; ことが期待されている。 ;; ;; (mhc-foo/init) ;; ネットワークの状態に依存しない初期化処理を行う関数 ;; ;; (mhc-foo/exit) ;; ネットワークの状態に依存しない終了処理を行う関数 ;; ;; (mhc-foo/open &optional OFFLINE) ;; ネットワークの状態に依存する初期化処理を行う関数 ;; ;; (mhc-foo/close &optional OFFLINE) ;; ネットワークの状態に依存する終了処理を行う関数 ;; ;; (mhc-foo/sync) ;; スケジュールファイルの同期を取る関数 ;; ;; (mhc-foo/add FILENAME &optional OFFLINE) ;; ファイルを追加を通知する関数 ;; (ファイルの実体は追加された後に呼び出される) ;; ;; (mhc-foo/modify FILENAME &optional OFFLINE) ;; ファイルの変更を通知する関数 ;; (ファイルの実体が変更された後に呼び出される) ;; ;; (mhc-foo/remove FILENAME &optional OFFLINE) ;; ファイルを削除する関数 ;; (ファイルの実体は *削除されずに* 呼び出される) ;; ;; これらのメソッドを適切に定義し、更に以下のような宣言を付け加える。 ;; ;; (provide 'mhc-foo) ;; (put 'mhc-foo 'init 'mhc-foo/init) ;; (put 'mhc-foo 'exit 'mhc-foo/exit) ;; (put 'mhc-foo 'open 'mhc-foo/open) ;; (put 'mhc-foo 'close 'mhc-foo/close) ;; (put 'mhc-foo 'sync 'mhc-foo/sync) ;; (put 'mhc-foo 'add 'mhc-foo/add) ;; (put 'mhc-foo 'modify 'mhc-foo/modify) ;; (put 'mhc-foo 'remove 'mhc-foo/remove) ;; ;; メソッドの関数名は任意に選ぶことができる。 ;; ;; また、メソッドの定義は省略することができる。省略されたメソッドは、 ;; 関数 mhc-file/true によって置換され、その処理は常に成功したものと見 ;; なされる。 ;;; Definition (require 'mhc-compat) (require 'mhc-vars) ;;; Global Variables (defcustom mhc-file-method 'mhc-sync "*Variable to specify the method to control schdule files." :group 'mhc :type '(radio (const :tag "Backup and remove" mhc-sync) (const :tag "CVS" mhc-cvs) (symbol :tag "Other"))) (defcustom mhc-file-sync-enable-offline nil "*If non-nil, enable mhc-file-sync when status is offline." :group 'mhc :type '(radio (const :tag "Disable when offline" nil) (const :tag "Enable when offline" t))) ;;; Internal Variables (defvar mhc-file/offline (not mhc-default-network-status) "Keep current line status.") ;;; Codes (defun mhc-file/true (&rest arguments) "Dummy function for undefind backend functions." t) (defconst mhc-file/backend-method-list '(init exit open close sync add modify remove)) ;; To suprress byte compile warnings. (eval-when-compile (mapcar (lambda (s) (let ((f (intern (concat "mhc-file/" (symbol-name s))))) (or (fboundp f) (fset f 'mhc-file/true)))) mhc-file/backend-method-list)) (defun mhc-file-setup (&optional method) "Initialize backend to manipulate files." (require (or method mhc-file-method)) (mapcar (lambda (s) (fset (intern (concat "mhc-file/" (symbol-name s))) (or (get mhc-file-method s) 'mhc-file/true))) mhc-file/backend-method-list) (and (mhc-file/init) (mhc-file/open mhc-file/offline))) (defun mhc-file-exit () "Exit backend to manipulate files." (and (mhc-file/close mhc-file/offline) (mhc-file/exit))) (defmacro mhc-file-add (file) `(mhc-file/add ,file mhc-file/offline)) (defmacro mhc-file-modify (file) `(mhc-file/modify ,file mhc-file/offline)) (defmacro mhc-file-remove (file) `(mhc-file/remove ,file mhc-file/offline)) (defcustom mhc-file-line-status-strings '(" mhc[offline]" . " mhc[ONLINE]") "Strings to describe MHC network status." :group 'mhc :type '(choice (const :tag "Long format" (" mhc[offline]" . " mhc[ONLINE]")) (const :tag "Short format" (" Mhc" . " MHC")) (cons :tag "User definition" (string :tag "String for offline") (string :tag "String for online"))) :set (lambda (symbol value) (set-default symbol value) (if (assq 'mhc-mode minor-mode-alist) (setcdr (assq 'mhc-mode minor-mode-alist) (list (mhc-file-line-status)))) (force-mode-line-update))) (defun mhc-file-line-status () "Return status string for mode line." (if mhc-show-network-status (if mhc-file/offline (car mhc-file-line-status-strings) (cdr mhc-file-line-status-strings)))) (defun mhc-file-toggle-offline (&optional full set-to no-sync) "*Toggle line status of file manipulation backend." (interactive (list current-prefix-arg (not mhc-file/offline))) (let ((previous mhc-file/offline)) (setq mhc-file/offline set-to) (if (assq 'mhc-mode minor-mode-alist) (setcdr (assq 'mhc-mode minor-mode-alist) (list (mhc-file-line-status)))) (if mhc-file/offline (message "mhc-file is offline.") (if (and (not no-sync) previous (y-or-n-p "Sync schedule files right now ? ")) (mhc-file-sync full)) (message "mhc-file is online.")))) (defun mhc-file-sync (&optional full) "*Sync schedule files." (interactive "P") (if (and mhc-file/offline (not mhc-file-sync-enable-offline)) (message "\"M-x mhc-file-toggle-offline\" first.") (message "mhc file sync...") (when (mhc-file/sync full) (message "mhc file sync...done")))) ;; almost same as (make-directory dirname t) (defun mhc-file-make-directory (dirname) (if (file-directory-p dirname) t (if (mhc-file-make-directory (directory-file-name (file-name-directory (directory-file-name dirname)))) (progn (make-directory (directory-file-name dirname)) (mhc-file-add (file-name-as-directory dirname)) t)))) (provide 'mhc-file) ;;; Copyright Notice: ;; Copyright (C) 1999, 2000 Yoshinari Nomura. All rights reserved. ;; Copyright (C) 2000 MHC developing team. All rights reserved. ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of the team nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' ;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ;; THE TEAM OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, ;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED ;; OF THE POSSIBILITY OF SUCH DAMAGE. ;;; mhc-file.el ends here. yoshinari-nomura-mhc-815a36a/emacs/mhc-gnus.el000066400000000000000000000363231222073515200212560ustar00rootroot00000000000000;;; -*- mode: Emacs-Lisp; coding: utf-8 -*- ;; Author: Yoshinari Nomura , ;; MIYOSHI Masanori , ;; TSUCHIYA Masatoshi ;; Created: 2000/05/10 ;; Revised: $Date$ ;;; Commentary: ;; This file is a part of MHC, and includes MUA backend methods for ;; Gnus. ;; When you use T-gnus, you should add the following expression to ;; your ~/.emacs. ;; ;; (add-hook 'mhc-draft-mode-hook 'mime-edit-mode) ;; ;; Otherwise, you should add the following expression to your ;; ~/.emacs. ;; ;; (add-hook 'mhc-draft-mode-hook 'mml-mode) ;;; Code: (eval-when-compile (require 'cl) (require 'gnus-art)) (require 'gnus-sum) (require 'nnmhc) ;; To suppress byte-compile warnings. (eval-when-compile (defvar gnus-original-article-buffer)) (eval-and-compile (autoload 'eword-encode-string "eword-encode") (autoload 'gnus-backlog-remove-article "gnus-bcklg") (autoload 'gnus-copy-article-buffer "gnus-msg") (autoload 'mime-to-mml "mml") (autoload 'rfc2047-decode-region "rfc2047") (autoload 'rfc2047-decode-string "rfc2047") (autoload 'rfc2047-encode-message-header "rfc2047") (autoload 'rfc2047-encode-string "rfc2047")) ;;; Internal Variables: (defvar mhc-gnus/mhc-is-running nil) ;;; Setup function: ;;;###autoload (defun mhc-gnus-setup () (require 'mhc) (setq mhc-mailer-package 'gnus) (mhc-gnus/setup-methods) (mhc-file-toggle-offline nil (not gnus-plugged) nil) (mhc-setup) (add-hook 'gnus-group-mode-hook 'mhc-mode) (add-hook 'gnus-summary-mode-hook 'mhc-mode) (add-hook 'gnus-exit-gnus-hook 'mhc-exit) (add-hook 'gnus-agent-plugged-hook 'mhc-gnus/plugged) (add-hook 'gnus-agent-unplugged-hook 'mhc-gnus/unplugged)) (defun mhc-gnus/plugged () (mhc-file-toggle-offline nil nil)) (defun mhc-gnus/unplugged () (mhc-file-toggle-offline nil t)) ;;; Backend methods: ;;; Summary APIs (mhc-summary.el): (defun mhc-gnus-summary-filename () "Return the file name of the article on the current line." (let ((num (get-text-property (point) 'gnus-number))) (if num (nnmhc-get-article num)))) (defun mhc-gnus-summary-display-article () "Display the article on the current line." (let ((num (get-text-property (point) 'gnus-number))) (if num (gnus-summary-display-article num)))) (defun mhc-gnus-get-import-buffer (get-original) "Return a buffer visiting import article. If GET-ORIGINAL is non-nil, return a pair of buffer: one keeps a MIME message and the other keeps a visible message. NOTE: This function designed for original Gnus, not for T-gnus. When using T-gnus, `mhc-mime-get-import-buffer' must be used instead of this function." (gnus-summary-select-article) (if get-original (cons gnus-original-article-buffer (gnus-copy-article-buffer)) (gnus-copy-article-buffer))) (defsubst mhc-gnus/date-to-group-name (date) (mhc-date-format date "%s/%02d/%02d" mhc-base-folder yy mm)) (defun mhc-gnus-generate-summary-buffer (date) "Generate a summary buffer for DATE, and change current buffer to it." (let* ((group (mhc-gnus/date-to-group-name date)) (method `(nnmhc ,group)) (vgroup (gnus-group-prefixed-name group method))) ;; initialize ephemeral nnmhc group. (gnus-group-read-ephemeral-group vgroup method t (if (buffer-live-p gnus-summary-buffer) (cons gnus-summary-buffer 'summary) (cons (current-buffer) 'group)) t) (gnus-group-read-group 0 t vgroup) (gnus-summary-make-local-variables) (setq inhibit-read-only t nnmhc-article-list nil) (delete-region (point-min) (point-max)))) ;; This is a trick to suppress byte-compile of the inline function ;; `make-full-mail-header' defined by `defsubst'. Cf. (ELF:01937) (defalias 'mhc-gnus/make-full-mail-header 'make-full-mail-header) (defalias 'mhc-gnus/encode-string 'identity) (defun mhc-gnus-insert-summary-contents (inserter) "Insert `mhc-tmp-schedule' with INSERTER." (let ((x (mhc-record-name (mhc-schedule-record mhc-tmp-schedule))) (subject (mhc-gnus/encode-string (mhc-schedule-subject-as-string mhc-tmp-schedule))) (pos (point))) (when x (push (cons x subject) nnmhc-article-list) (setq x (length nnmhc-article-list))) (funcall inserter) (if x (let ((header (mhc-gnus/make-full-mail-header x subject ""))) (put-text-property pos (point) 'gnus-number x) (push (gnus-data-make x 0 0 header 0) gnus-newsgroup-data)) (remove-text-properties pos (point) '(gnus-number nil))) (insert "\n"))) (defun mhc-gnus-summary-mode-setup (date) "Setup this current buffer as a summary buffer for DATE." (setq gnus-newsgroup-data (nreverse gnus-newsgroup-data) nnmhc-article-list (nreverse nnmhc-article-list)) (save-excursion (goto-char (point-min)) (while (not (eobp)) (let ((num (get-text-property (point) 'gnus-number))) (if num (gnus-data-set-pos (assoc num gnus-newsgroup-data) (point)))) (forward-line 1))) (let ((group (gnus-group-prefixed-name (mhc-gnus/date-to-group-name date) '(nnmhc)))) ;; Reset all caches for this group. (let ((i 0)) (while (<= (incf i) (length nnmhc-article-list)) (gnus-backlog-remove-article group i))) ;; Reset an article kept in `gnus-original-article-buffer'. (when (gnus-buffer-live-p gnus-original-article-buffer) (with-current-buffer gnus-original-article-buffer (setq gnus-original-article nil))) (let ((gnus-newsgroup-data)) (gnus-summary-mode group))) (when (fboundp 'gnus-summary-setup-default-charset) (gnus-summary-setup-default-charset)) ; for Nana7 (set (make-local-variable 'mhc-gnus/mhc-is-running) t) (set (make-local-variable 'gnus-visual) nil) (set (make-local-variable 'gnus-auto-extend-newsgroup) nil) (setq gnus-article-current nil ; Reset structures of the current article. gnus-current-article nil gnus-current-headers nil gnus-newsgroup-begin 1 gnus-newsgroup-end (length nnmhc-article-list))) (defun mhc-gnus-highlight-message (for-draft) "Hilight message in the current buffer. If FOR-DRAFT is non-nil, Hilight message as draft message." (if for-draft (progn (require 'message) (set (make-local-variable 'font-lock-defaults) '(message-font-lock-keywords t))) (let ((gnus-article-buffer (current-buffer)) ;; Adhoc fix to avoid errors in gnus-article-add-buttons(). (gnus-button-marker-list)) (gnus-article-highlight)))) (defalias 'mhc-gnus-decode-string 'rfc2047-decode-string) (defun mhc-gnus/decode-buffer () (goto-char (point-min)) (skip-chars-forward "[ \t\r\f\n\x20-\x7e]") (unless (eobp) (decode-coding-region (point-min) (point-max) mhc-default-coding-system))) (defun mhc-gnus-decode-header () "Decode MIME-encoded headers. NOTE: This function designed for original Gnus, not for T-gnus. When using T-gnus, `mhc-mime-decode-header' must be used instead of this function." (save-restriction (mail-narrow-to-head) (mhc-gnus/decode-buffer) (rfc2047-decode-region (point-min) (point-max)))) ;;; Draft APIs (mhc-draft.el): (defun mhc-gnus-draft-setup-new () "Setup new draft (Insert header separator). NOTE: This function designed for original Gnus, not for T-gnus. When using T-gnus, `mhc-mime-draft-setup-new' must be used instead of this function." (goto-char (point-min)) (insert mail-header-separator "\n")) (defun mhc-gnus-draft-reedit-buffer (buffer original) "Prepare a draft from the content of the BUFFER. If ORIGINAL is non-nil, this function converts a MIME message in the BUFFER into a human-editable text written in MML, a language for describing MIME parts. NOTE: This function designed for original Gnus, not for T-gnus. When using T-gnus, `mhc-mime-draft-reedit-buffer' must be called instead of this function." ;; If current buffer is specified as buffer, no need to replace. (unless (eq (current-buffer) buffer) (erase-buffer) (insert-buffer buffer)) (if original (save-restriction (mail-narrow-to-head) (mhc-gnus/decode-buffer) (if (mhc-header-valid-p "Content-Type") (progn (widen) (mime-to-mml)) (rfc2047-decode-region (point-min) (point-max)) (goto-char (point-max)) (widen) (decode-coding-region (point) (point-max) mhc-default-coding-system)) (mail-narrow-to-head) (mhc-header-delete-header (concat "^\\(" (mhc-regexp-opt mhc-draft-unuse-hdr-list) "\\)") 'regexp)) (mhc-header-narrowing (mhc-header-delete-header "^\\(Content-.*\\|Mime-Version\\|User-Agent\\):" 'regexp))) (goto-char (point-min)) (when (re-search-forward "^\r?$" nil t) (insert mail-header-separator))) (defun mhc-gnus-draft-reedit-file (file) "Prepare a draft from the FILE. NOTE: This function designed for original Gnus, not for T-gnus. When using T-gnus, `mhc-mime-draft-reedit-file' must be called instead of this function." (erase-buffer) (let ((coding-system-for-read 'raw-text-dos) (format-alist)) (insert-file-contents file)) (mhc-gnus-draft-reedit-buffer (current-buffer) t)) (defun mhc-gnus-draft-translate () "Convert a message in this current buffer to a MIME message. A input text in this current buffer must be written in MML, a language for describing MIME parts. NOTE: This function designed for original Gnus, not for T-gnus. When using T-gnus, `mhc-mime-draft-translate' must be called instead of this function." (message-encode-message-body) (save-restriction (message-narrow-to-headers) (message-generate-headers '(Date From Lines)) (message-remove-header message-ignored-mail-headers t) (let ((mail-parse-charset message-default-charset)) (rfc2047-encode-message-header))) (save-excursion (goto-char (point-min)) (when (search-forward (concat "\n" mail-header-separator "\n") nil t) (replace-match "\n\n")))) (defun mhc-gnus-goto-message (&optional view) "Go to a view position on summary buffer." (when view (gnus-summary-next-page))) ;;; MIME APIs (mhc-mime.el): (defun mhc-gnus-mime-get-raw-buffer () "Get raw buffer of the current message. Note: This function is used only when using T-gnus." (gnus-summary-select-article) gnus-original-article-buffer) (defun mhc-gnus-mime-get-mime-structure () "Get mime message structure of the current message. Note: This function is used only when using T-gnus." (gnus-summary-select-article) gnus-current-headers) ;; modify Gnus original functions for cursor control. (eval-after-load "gnus" '(defadvice gnus-summary-position-point (around mhc-gnus-summary-position-point activate compile) (or mhc-gnus/mhc-is-running ad-do-it))) (let (current-load-list) (defadvice gnus-summary-update-mark (around mhc-gnus-summary-update-mark activate compile) (or mhc-gnus/mhc-is-running ad-do-it))) ;; modify Gnus original commands for manipulate articles. (let (current-load-list) (defadvice gnus-summary-edit-article (around mhc-gnus-draft-edit-message activate compile) "If MHC is running, call `mhc-modify'." (if mhc-gnus/mhc-is-running (mhc-modify) ad-do-it))) (let (current-load-list) (defadvice gnus-summary-delete-article (around mhc-gnus-summary-delete-article activate compile) "If MHC is running, call `mhc-delete'." (if mhc-gnus/mhc-is-running (mhc-delete) ad-do-it))) (provide 'mhc-gnus) (put 'mhc-gnus 'summary-filename 'mhc-gnus-summary-filename) (put 'mhc-gnus 'summary-display-article 'mhc-gnus-summary-display-article) (put 'mhc-gnus 'generate-summary-buffer 'mhc-gnus-generate-summary-buffer) (put 'mhc-gnus 'insert-summary-contents 'mhc-gnus-insert-summary-contents) (put 'mhc-gnus 'summary-mode-setup 'mhc-gnus-summary-mode-setup) (put 'mhc-gnus 'highlight-message 'mhc-gnus-highlight-message) (put 'mhc-gnus 'goto-message 'mhc-gnus-goto-message) (defun mhc-gnus/setup-methods () (if (and (boundp 'gnus-version) (stringp (symbol-value 'gnus-version)) (string-match "SEMI" (symbol-value 'gnus-version))) (progn (require 'mhc-mime) (defalias 'mhc-gnus/encode-string 'eword-encode-string) (put 'mhc-gnus 'draft-setup-new 'mhc-mime-draft-setup-new) (put 'mhc-gnus 'draft-reedit-buffer 'mhc-mime-draft-reedit-buffer) (put 'mhc-gnus 'draft-reedit-file 'mhc-mime-draft-reedit-file) (put 'mhc-gnus 'draft-translate 'mhc-mime-draft-translate) (put 'mhc-gnus 'get-import-buffer 'mhc-mime-get-import-buffer) (put 'mhc-gnus 'decode-header 'mhc-mime-decode-header) (put 'mhc-gnus 'eword-decode-string 'mhc-mime-eword-decode-string) (put 'mhc-gnus 'mime-get-raw-buffer 'mhc-gnus-mime-get-raw-buffer) (put 'mhc-gnus 'mime-get-mime-structure 'mhc-gnus-mime-get-mime-structure)) (defun mhc-gnus/encode-string (string) (let ((rfc2047-encoding-type 'mime)) (rfc2047-encode-string string))) (put 'mhc-gnus 'draft-setup-new 'mhc-gnus-draft-setup-new) (put 'mhc-gnus 'draft-reedit-buffer 'mhc-gnus-draft-reedit-buffer) (put 'mhc-gnus 'draft-reedit-file 'mhc-gnus-draft-reedit-file) (put 'mhc-gnus 'draft-translate 'mhc-gnus-draft-translate) (put 'mhc-gnus 'get-import-buffer 'mhc-gnus-get-import-buffer) (put 'mhc-gnus 'decode-header 'mhc-gnus-decode-header) (put 'mhc-gnus 'eword-decode-string 'mhc-gnus-decode-string) (put 'mhc-gnus 'mime-get-raw-buffer nil) (put 'mhc-gnus 'mime-get-mime-structure nil))) (mhc-gnus/setup-methods) ;;; Copyright Notice: ;; Copyright (C) 1999, 2000 Yoshinari Nomura. All rights reserved. ;; Copyright (C) 2000 MHC developing team. All rights reserved. ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of the team nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' ;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ;; THE TEAM OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, ;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED ;; OF THE POSSIBILITY OF SUCH DAMAGE. ;;; mhc-gnus.el ends here. yoshinari-nomura-mhc-815a36a/emacs/mhc-guess.el000066400000000000000000000574551222073515200214410ustar00rootroot00000000000000;;; mhc-guess.el -- Guess the important date from a Japanese mail article. ;; Author: Yoshinari Nomura ;; ;; Created: 1999/04/13 ;; Revised: $Date: 2007/12/05 04:59:35 $ ;; ;;; ;;; Commentary: ;;; ;; ;; バッファから mhc-guess-{time,date}: 日付、時間を集めて、 ;; 予定の日付けを表わしていると思われる可能性の高い順に並べて ;; 返す。 ;; ;; 以下のような GUESS-CANDIDATE のリストを返す ;; ([mhc-{date,time} mhc-{date,time}-end point-begin point-end score]..) ;; ;; mhc-{date,time}: 予定の開始 {日, 時間} ;; mhc-{date,time}-end 予定の終了 {日, 時間} or nil ;; ;; 日付推測の手順 ;; ;; 1. 日付/時刻を表すキーワード見付けて、発見個所リストを作る。 ;; ;; (mhc-guess/gather-candidate mhc-guess-date-regexp-list now) ;; (mhc-guess/gather-candidate mhc-guess-time-regexp-list now) ;; ;; の 2つの関数で、 ;; ;; ([found-date found-date-end found-point-begin found-point-end nil] ...) ;; ([found-time found-time-end found-point-begin found-point-end nil] ...) ;; ;; のような candidate-list を得る。 ;; ;; 2. みつかった日付時刻に点数をつける。 ;; ;; (mhc-guess/score candidate-list mhc-guess-keyword-score-alist) ;; ;; ([found-date found-date-end found-point-begin found-point-end score] ...) ;; ;; キーワードが引用行中にある ;; 同一行に特定の文字列がある ;; ある範囲の前方/後方に特定の文字列がある ;; ;; のような条件と加点/減点を表す mhc-guess-keyword-score-alist に基 ;; づいて採点をする。 ;; ;; 3. 得点順 (得点が同じ場合は，日付や時間を表わす文字列が長い順) ;; に sort して返す ;;; ;;; Code: ;;; (require 'mhc-date) (provide 'mhc-guess) ;;; Customize variables: (defcustom mhc-guess-ignore-english-date nil "*Ignore English dates." :group 'mhc :type '(choice (const :tag "Ignore" t) (const :tag "Don't Ignore" nil))) (defcustom mhc-guess-english-date-format '(usa) "*English date formats. You can specify following symbols as a list. usa: Suppose the USA style date formats. (e.g. Feb 25, 2004) british: Suppose British style date formats. (e.g. 25 Feb, 2004)" :group 'mhc :type '(repeat (choice (const :tag "USA" usa) (const :tag "British" british)))) ;; ;; regexp for get date strings. ;; (defvar mhc-guess-date-regexp-list `( (,(concat "\\([０-９0-9][０-９0-9][０-９0-9][０-９0-9]\\)[-−/／]" "\\([０-９0-9][０-９0-9]\\)[-−/／]" "\\([０-９0-9][０-９0-9]\\)") mhc-guess/make-date-from-yyyymmdd 1 2 3) (,(concat "\\([０-９0-9]+年\\)?" "\\([来今０-９0-9]+\\)[\n　 ]*月[\n 　]*の?[\n 　]*" "\\([０-９0-9]+\\)日?" "\\([（）()月火水木金土日曜\n 　 ]*" "\\([〜−-，,、]\\|から\\|より\\)[\n 　]*" "\\([０-９0-9]+年\\)?" "\\(\\([来今０-９0-9]+\\)[\n　 ]*月\\)?[\n 　]*の?[\n 　]*" "\\([０-９0-9]+\\)日?\\(間\\)?" "\\)?") mhc-guess/make-date-from-mmdd 2 3 8 9 10) (,(concat "\\([０-９0-9]+[　 ]*[／/][　 ]*\\)?" "\\([０-９0-9]+\\)[　 ]*[／/][　 ]*\\([０-９0-9]+\\)" "\\([（）()月火水木金土日曜\n 　 ]*" "\\([〜−，,、-]\\|から\\|より\\)[\n 　]*" "\\([０-９0-9]+[　 ]*[／/][　 ]*\\)?" "\\(\\([０-９0-9]+\\)[　 ]*[／/][　 ]*\\)" "\\([０-９0-9]+\\)日?\\(間\\)?" "\\)?") mhc-guess/make-date-from-mmdd 2 3 8 9 10) ;; USA style date format (,(concat "\\(Jan\\(uary\\)?\\|Feb\\(ruary\\)?\\|Mar\\(ch\\)?\\|" "Apr\\(il\\)?\\|May\\|June?\\|July?\\|Aug\\(ust\\)?\\|" "Sep\\(tember\\)?\\|Oct\\(ober\\)?\\|" "Nov\\(ember\\)?\\|Dec\\(ember\\)?\\)" "\.?,? +" "\\([0-9][0-9]?\\)\\(st\\|nd\\rd\\|th\\)?,?[ \n]+" ;; day "\\(\\('\\|[1-9][0-9]\\)?[0-9][0-9]\\)?") ;; year mhc-guess/make-date-from-usa-style-date 1 11 13) ;; British style date format (,(concat "\\([0-9][0-9]?\\)\\(st\\|nd\\rd\\|th\\)?,? " ;; day "\\(Jan\\(uary\\)?\\|Feb\\(ruary\\)?\\|Mar\\(ch\\)?\\|" "Apr\\(il\\)?\\|May\\|June?\\|July?\\|Aug\\(ust\\)?\\|" "Sep\\(tember\\)?\\|Oct\\(ober\\)?\\|" "Nov\\(ember\\)?\\|Dec\\(ember\\)?\\)" "\.?,?[ \n]+" "\\(\\('\\|[1-9][0-9]\\)?[0-9][0-9]\\)?") ;; year mhc-guess/make-date-from-british-style-date 1 3 13) throw (,(concat "\\(今度\\|[今来次]週\\|再来週\\)[\n 　]*の?[\n 　]*" "\\([月火水木金土日]\\)曜") mhc-guess/make-date-from-relative-week 1 2) (,(concat "\\([Tt]his\\|[Nn]ext\\)[\n ]+" "\\(Monday\\|Tuesday\\|Wednesday\\|Thursday\\|Friday\\|" "Saturday\\|Sunday\\)") mhc-guess/make-date-from-english-relative-week 2 1 nil) (,(concat "\\(Monday\\|Tuesday\\|Wednesday\\|Thursday\\|Friday\\|" "Saturday\\|Sunday\\)[\n ]+" "\\([Tt]his\\|[Nn]ext\\)[ \n]+\\([Ww]eek\\)") mhc-guess/make-date-from-english-relative-week 1 2 3) throw ("\\([０-９0-9]+\\)[\n 　]*日" mhc-guess/make-date-from-mmdd nil 1) ("\\([０-９0-9]+\\)[ 　]*[(（][月火水木金土日]" mhc-guess/make-date-from-mmdd nil 1) ("[^\(（]\\([月火水木金土日]\\)\n?曜" mhc-guess/make-date-from-relative-week nil 1) (,(concat "\\(Monday\\|Tuesday\\|Wednesday\\|Thursday\\|Friday\\|" "Saturday\\|Sunday\\)") mhc-guess/make-date-from-english-relative-week 1 nil nil) ("\\(本日\\|今日\\|あす\\|あした\\|あさって\\|明日\\|明後日\\)" mhc-guess/make-date-from-relative-day 1) (,(concat "\\([Tt]oday\\|[Tt]omorrow\\|" "[Tt]he[ \n]+[Dd]ay[ \n]+[Aa]fter[ \n]+[Tt]omorrow\\)") mhc-guess/make-date-from-english-relative-day 1) )) (defvar mhc-guess-time-regexp-list `( (,(concat "\\([０-９0-9]+\\) *[時] *\\([０-９0-9]+\\|半\\)?分?" "\\([\n 　]*\\([〜−-]\\|から\\|より\\)[\n 　午前後]*" "\\([０-９0-9]+\\) *[時]\\(間\\)? *\\([０-９0-9]+\\|半\\)?\\)?") mhc-guess/make-time-from-hhmm 1 2 5 7 6) (,(concat "\\([０-９0-9]+\\)[：:]\\([０-９0-9]+\\)" "\\([\n 　]*\\([〜−-]\\|から\\|より\\)[\n 　午前後]*" "\\([０-９0-9]+\\) *[：:時]\\(間\\)? *\\([０-９0-9]+\\|半\\)?\\)?") mhc-guess/make-time-from-hhmm 1 2 5 7 6) )) (defvar mhc-guess-location-list '() "*List of the regexps of the location, like this '(\"第?[0-9０-９〇-九]+応接室?\" \"第?[0-9０-９〇-九]+会議室[0-9０-９〇-九]?\"))") (defvar mhc-guess-location-regexp-list `( (,(concat "場[ 　]*所[ 　]*[：:]*[\n 　]*\\([^\n 　]+\\)") mhc-guess/make-location-from-string 1) (,(concat "於[ 　]*\\([^\n 　]+\\)") mhc-guess/make-location-from-string 1) (,(concat "[@＠][　 ]*\\([^\n　 .]+\\)[　 \n]") mhc-guess/make-location-from-string 1))) ;; keyword to score-alist: ;; each element consists of (regexp relative-boundary sameline? score) (defvar mhc-guess-keyword-score-alist '( ;; positive factor ("^[\t ]+" -200 t +5) ("次回" -200 nil +10) ("\\(期間\\|月日\\|日程\\|時間帯\\|日時\\|開始時間\\)" -150 nil +5) ("\\(期間\\|月日\\|日程\\|時間帯\\|日時\\|開始時間\\)[:：]" -150 t +5) ("\\(から\\|〜\\|変更\\|延期\\|順延\\|開始\\)" +80 nil +4) ;; negative factor ("\\(休み\\|除く\\|中止\\|までに\\)" +80 t -10) ("出欠" -80 nil -5) ("^\\(On\\|At\\|Date:\\) " -200 t -20) ("\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\)" -200 t -20) ("\\(Jul\\|Aug\\|Sep\\|Oct\\|Nov\\|Dec\\)" -200 t -20) ("^\\([ a-zA-Z]*>\\)+ *" -200 t -15) )) (defvar mhc-guess/location-regexp-list nil) ;; ;; manipulate guess-candidate structure. ;; (defmacro mhc-guess-get-date (obj) `(aref ,obj 0)) (defmacro mhc-guess-get-time (obj) `(aref ,obj 0)) (defmacro mhc-guess-get-date-or-time (obj) `(aref ,obj 0)) (defmacro mhc-guess-get-date-end (obj) `(aref ,obj 1)) (defmacro mhc-guess-get-time-end (obj) `(aref ,obj 1)) (defmacro mhc-guess-get-date-or-time-end (obj) `(aref ,obj 1)) (defmacro mhc-guess-get-begin (obj) `(aref ,obj 2)) (defmacro mhc-guess-get-end (obj) `(aref ,obj 3)) (defmacro mhc-guess-get-score (obj) `(aref ,obj 4)) (defmacro mhc-guess-set-date (obj val) `(aset ,obj 0 ,val)) (defmacro mhc-guess-set-time (obj val) `(aset ,obj 0 ,val)) (defmacro mhc-guess-set-date-end (obj val) `(aset ,obj 1 ,val)) (defmacro mhc-guess-set-time-end (obj val) `(aset ,obj 1 ,val)) (defmacro mhc-guess-set-begin (obj val) `(aset ,obj 2 ,val)) (defmacro mhc-guess-set-end (obj val) `(aset ,obj 3 ,val)) (defmacro mhc-guess-set-score (obj val) `(aset ,obj 4 ,val)) (defun mhc-guess/new (&optional date-or-time date-or-time-end begin end score) (vector date-or-time date-or-time-end begin end score)) ;; ;; pulic entry ;; (defun mhc-guess-date (&optional hint1) (let ((now (or (mhc-date-new-from-string3 (mhc-header-get-value "Date")) (mhc-date-now)))) (mhc-guess/guess mhc-guess-date-regexp-list hint1 now))) (defun mhc-guess-time (&optional hint1) (mhc-guess/guess mhc-guess-time-regexp-list hint1)) (defun mhc-guess-location-setup () (if mhc-guess-location-list (let ((list mhc-guess-location-list) regex) (while list (setq regex (concat regex "\\(" (car list) "\\)")) (setq list (cdr list)) (when list (setq regex (concat regex "\\|")))) (setq mhc-guess/location-regexp-list (cons `(,regex mhc-guess/make-location-from-string 0) mhc-guess-location-regexp-list))) (setq mhc-guess/location-regexp-list mhc-guess-location-regexp-list))) (defun mhc-guess-location (&optional hint1) (mhc-guess/guess mhc-guess/location-regexp-list hint1)) (defun mhc-guess/guess (control-regexp-lst &optional hint1 now) (let ((score-list (mhc-guess/score (mhc-guess/gather-candidate control-regexp-lst now) mhc-guess-keyword-score-alist hint1 now))) (sort score-list (function (lambda (a b) (if (= (mhc-guess-get-score a) (mhc-guess-get-score b)) (< (- (mhc-guess-get-end b) (mhc-guess-get-begin b)) (- (mhc-guess-get-end a) (mhc-guess-get-begin a))) (< (mhc-guess-get-score b) (mhc-guess-get-score a)))))))) ;; ;; gather date/time. ;; (defun mhc-guess/gather-candidate (control-regexp-lst &optional now) (let ((ret nil) cand-lst) (while control-regexp-lst (cond ((listp (car control-regexp-lst)) (if (setq cand-lst (mhc-guess/gather-candidate2 (car (car control-regexp-lst)) ;; regexp (car (cdr (car control-regexp-lst))) ;; convfunc (cdr (cdr (car control-regexp-lst))) ;; posision list now ;; current date )) (setq ret (nconc ret cand-lst)))) ((and (string= "throw" (symbol-name (car control-regexp-lst))) ret) (setq control-regexp-lst nil))) (setq control-regexp-lst (cdr control-regexp-lst))) ret)) (defun mhc-guess/gather-candidate2 (regexp convfunc pos-list &optional now) (let* (lst duration param-list p) (save-excursion ;; skip Header (goto-char (point-min)) (re-search-forward "^-*$" nil t) ;; search candities. (while (re-search-forward regexp nil t) (setq p pos-list param-list nil) (while p (setq param-list (cons (if (and (car p) (match-beginning (car p))) (buffer-substring (match-beginning (car p)) (match-end (car p))) nil) param-list)) (setq p (cdr p))) (setq duration (apply 'funcall convfunc now (nreverse param-list))) (if (car duration) (setq lst (cons (mhc-guess/new (car duration) (cdr duration) (match-beginning 0) (match-end 0) nil) lst))))) (nreverse lst))) ;; ;; make date from string. ;; (defun mhc-guess/make-date-from-yyyymmdd (now yy-str mm-str dd-str) (let (date) (if (setq date (mhc-date-new (mhc-guess/string-to-int yy-str) (mhc-guess/string-to-int mm-str) (mhc-guess/string-to-int dd-str) t)) ; noerror is t. (cons date nil)))) (defun mhc-guess/make-date-from-mmdd (now mm-str dd-str &optional mm-str2 dd-str2 relative) (let* ((start nil) (end nil)) (setq start (mhc-guess/make-date-from-mmdd2 now mm-str dd-str)) (if start (setq end (mhc-guess/make-date-from-mmdd2 start mm-str2 dd-str2))) (cond ((null start) nil) ((null end) (cons start nil)) (relative (cons start (mhc-date+ start end))) (t (cons start end))))) (defun mhc-guess/make-date-from-mmdd2 (now mm-str dd-str) (let ((data (match-data)) (mm (if mm-str (mhc-guess/string-to-int mm-str) 0)) (dd (if dd-str (mhc-guess/string-to-int dd-str) 0)) (year-offset 0) date) (cond ((string= mm-str "来") (setq mm (mhc-date-mm (mhc-date-mm++ now)))) ((string= mm-str "今") (setq mm (mhc-date-mm now))) ((= mm 0) (setq mm (mhc-date-mm now)))) (if (not (setq date (mhc-date-new (mhc-date-yy now) mm dd t))) ;; noerror is t () ;; if date is past, assume the next year. (if (mhc-date< date now) (setq year-offset (1+ year-offset))) ;; if date is far future, assume the last year. (if (< 300 (+ (mhc-date- date now) (* year-offset 365))) (setq year-offset (1- year-offset))) (setq date (mhc-date-yy+ date year-offset))) (store-match-data data) date)) (defun mhc-guess/make-date-from-usa-style-date (now month-str dd-str yy-str) (if (and (null mhc-guess-ignore-english-date) (memq 'usa mhc-guess-english-date-format)) (mhc-guess/make-date-from-english-date now month-str dd-str yy-str))) (defun mhc-guess/make-date-from-british-style-date (now dd-str month-str yy-str) (if (and (null mhc-guess-ignore-english-date) (memq 'british mhc-guess-english-date-format)) (mhc-guess/make-date-from-english-date now month-str dd-str yy-str))) (defun mhc-guess/make-date-from-english-date (now month-str dd-str yy-str) (let* ((month-alist '(("Jan" . "1") ("Feb" . "2") ("Mar" . "3") ("Apr" . "4") ("May" . "5") ("Jun" . "6") ("Jul" . "7") ("Aug" . "8") ("Sep" . "9") ("Oct" . "10") ("Nov" . "11") ("Dec" . "12"))) (mm-str (cdr (assoc (capitalize (substring month-str 0 3)) month-alist))) (yy-length (length yy-str))) (cond ((= yy-length 4) ; "yyyy" (mhc-guess/make-date-from-yyyymmdd now yy-str mm-str dd-str)) ((or (= yy-length 3) (= yy-length 2)) ; "'yy" or "yy" (mhc-guess/make-date-from-yyyymmdd now (concat (substring (format-time-string "%Y") 0 2) (substring yy-str -2)) mm-str dd-str)) (t (mhc-guess/make-date-from-mmdd now mm-str dd-str))))) (defun mhc-guess/make-date-from-relative-day (now rel-word) (cond ((null rel-word) nil) ((or (string= rel-word "今日") (string= rel-word "本日")) (cons now nil)) ((or (string= rel-word "あす") (string= rel-word "あした") (string= rel-word "明日")) (cons (mhc-date++ now) nil)) ((or (string= rel-word "あさって") (string= rel-word "明後日")) (cons (mhc-date+ now 2) nil)))) (defun mhc-guess/make-date-from-english-relative-day (now rel-word) (unless mhc-guess-ignore-english-date (let ((rel (downcase rel-word))) (cond ((null rel) nil) ((string= rel "today") (cons now nil)) ((string= rel "tomorrow") (cons (mhc-date++ now) nil)) (t ;; the day after tommorow. (cons (mhc-date+ now 2) nil)))))) (defun mhc-guess/make-date-from-relative-week (now rel-word week) (let ((data (match-data)) (ww (string-match week "日月火水木金土")) (date (or now (mhc-date-now))) off) (setq off (- ww (mhc-date-ww date))) (if (string= week "日") (setq off (+ 7 off))) (setq off (cond ((or (null rel-word) (string= rel-word "今度") (string= rel-word "次")) (if (<= off 0) (+ 7 off) off)) ((string= rel-word "今週") off) ((string= rel-word "来週") (+ off 7)) ((string= rel-word "再来週") (+ off 14)))) (store-match-data data) (cons (mhc-date+ date off) nil) )) (defun mhc-guess/make-date-from-english-relative-week (now dow rel-word week) (unless mhc-guess-ignore-english-date (let ((dow-alist '(("Monday" . "月") ("Tuesday" . "火") ("Wednesday" . "水") ("Thursday" . "木") ("Friday" . "金") ("Saturday" . "土") ("Sunday" . "日"))) (rel (when (stringp rel-word) (downcase rel-word)))) (mhc-guess/make-date-from-relative-week now (if (null rel) nil (cond ((and (string= rel "this") (null week)) "今度") ((and (string= rel "this") week) "今週") ((and (string= rel "next") (null week)) "今度") ((and (string= rel "next") week) "来週") (t nil))) (cdr (assoc-ignore-case dow dow-alist)))))) ;; ;; make time from string. ;; (defun mhc-guess/make-time-from-hhmm (now hh-str mm-str hh-str2 mm-str2 &optional relative) (let ((start (mhc-guess/make-time-from-hhmm2 hh-str mm-str)) (end (mhc-guess/make-time-from-hhmm2 hh-str2 mm-str2 relative))) (cond ((null start) nil) ((null end) (cons start nil)) (relative (cons start (mhc-time+ start end))) (t (cons start end))))) (defun mhc-guess/make-time-from-hhmm2 (hh-str mm-str &optional relative) (let (xHH xMM) (if (null hh-str) nil ;; retun value (setq xHH (mhc-guess/string-to-int hh-str)) (if (and (not relative) (< xHH 8)) ;; 8 depends on my life style. (setq xHH (+ xHH 12))) (setq xMM (cond ((not mm-str) 0) ((string= mm-str "半") 30) (t (mhc-guess/string-to-int mm-str)))) (mhc-time-new xHH xMM t)))) ;; ;; make location from string ;; (defun mhc-guess/make-location-from-string (now str) (cons str nil)) ;; ;; scoring ;; (defun mhc-guess/score (candidate-lst score-alist &optional hint1 now) (let ((clist candidate-lst) total-score candidate regexp boundary sameline score slist) (while clist (setq candidate (car clist) slist score-alist total-score 0) ;; set score using score-alist (while slist (setq regexp (nth 0 (car slist)) boundary (nth 1 (car slist)) sameline (nth 2 (car slist)) score (nth 3 (car slist))) (if (mhc-guess/search-in-boundary regexp (mhc-guess-get-begin candidate) boundary sameline) (setq total-score (+ total-score score))) (setq slist (cdr slist))) ;; hint1 is a position hint to encourage the near one. (if (and hint1 (< hint1 (mhc-guess-get-begin candidate)) (< (- (mhc-guess-get-begin candidate) hint1) 100)) (setq total-score (+ total-score 10))) ;; now is a date hint to discourage a past date. (if (and now (mhc-date<= (mhc-guess-get-date candidate) now)) (setq total-score (- total-score 5))) (mhc-guess-set-score candidate total-score) (setq clist (cdr clist))) candidate-lst)) (defun mhc-guess/search-in-boundary (regexp ptr rel-boundary sameline) (let ((pmin (+ ptr rel-boundary)) (pmax (+ ptr rel-boundary))) (save-excursion (goto-char ptr) (if sameline (setq pmax (min pmax (save-excursion (end-of-line) (point))) pmin (max pmin (save-excursion (beginning-of-line) (point))))) (if (< 0 rel-boundary) (and (< (point) pmax) (search-forward-regexp regexp pmax t)) (and (< pmin (point)) (search-backward-regexp regexp pmin t)))))) ;; ;; string-to-int with code conversion. ;; (defconst mhc-guess/zenkaku-hankaku-alist '(("０" . "0") ("１" . "1") ("２" . "2") ("３" . "3") ("４" . "4") ("５" . "5") ("６" . "6") ("７" . "7") ("８" . "8") ("９" . "9") ("／" . "/") ("：" . ":"))) (defun mhc-guess/string-to-int (str) (let ((chr "") (ret "") (data (match-data)) (z2h-alist '(("０" . "0") ("１" . "1") ("２" . "2") ("３" . "3") ("４" . "4") ("５" . "5") ("６" . "6") ("７" . "7") ("８" . "8") ("９" . "9") ("／" . "/") ("：" . ":")))) (while (string-match "^." str) (setq chr (substring str (match-beginning 0) (match-end 0))) (setq ret (concat ret (or (cdr (assoc chr z2h-alist)) chr))) (setq str (substring str (match-end 0)))) (store-match-data data) (string-to-number ret))) ;;; Copyright Notice: ;; Copyright (C) 1999, 2000 Yoshinari Nomura. All rights reserved. ;; Copyright (C) 2000 MHC developing team. All rights reserved. ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of the team nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' ;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ;; THE TEAM OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, ;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED ;; OF THE POSSIBILITY OF SUCH DAMAGE. ;;; mhc-guess.el ends here yoshinari-nomura-mhc-815a36a/emacs/mhc-header.el000066400000000000000000000140701222073515200215250ustar00rootroot00000000000000;;; -*- mode: Emacs-Lisp; coding: utf-8 -*- ;; Author: Yoshinari Nomura , ;; TSUCHIYA Masatoshi ;; Created: 2000/05/11 ;; Revised: $Date$ ;;; Commentary: ;; This file is a part of MHC, includes functions to manipulate ;; headers. ;;; Code: ;; Global Variable: (defconst mhc-header-table '(("x-sc-day" "X-SC-Day:" mhc-parse/day) ("x-sc-cond" "X-SC-Cond:" mhc-parse/cond) ("x-sc-duration" "X-SC-Duration:" mhc-parse/duration) ("x-sc-subject" "X-SC-Subject:" mhc-parse/subject) ("x-sc-location" "X-SC-Location:" mhc-parse/location) ("x-sc-time" "X-SC-Time:" mhc-parse/time) ("x-sc-alarm" "X-SC-Alarm:" mhc-parse/alarm) ("x-sc-category" "X-SC-Category:" mhc-parse/category) ("x-sc-recurrence-tag" "X-SC-Recurrence-Tag:" mhc-parse/recurrence-tag) ; ("x-sc-todo" "X-SC-ToDo:" mhc-parse/todo) ("x-sc-priority" "X-SC-Priority:" mhc-parse/priority) ("x-sc-record-id" "X-SC-Record-Id:" mhc-parse/record-id) ("x-sc-schedule" "X-SC-Schdule:" mhc-parse/schedule) ;; For backward compatibility ("x-sc-date" "X-SC-Date:" mhc-parse/old-style-date) ;; FIXME: 要削除 ("x-sc-next" "X-SC-Next:" mhc-parse/next))) (defmacro mhc-header-list () "Return headers which are referenced by MHC." `(mapcar (lambda (a) (nth 1 a)) mhc-header-table)) (defmacro mhc-header-parse-function (key) "Return a function to parse KEY." `(nth 2 (assoc (downcase ,key) mhc-header-table))) (defmacro mhc-header-narrowing (&rest form) "Evaluate FORM with restriction of editing in this buffer to the header." `(save-excursion (save-restriction (goto-char (point-min)) (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$\\|^$") nil t) (narrow-to-region (point-min) (match-beginning 0)) (goto-char (point-min)) ,@form))) (put 'mhc-header-narrowing 'lisp-indent-function 0) (put 'mhc-header-narrowing 'edebug-form-spec '(form body)) (defsubst mhc-header-goto-end () "Move point at end of this header." (while (and (forward-line 1) (memq (following-char) '(? ?\t))))) (defun mhc-header-delete-header (header &optional regexp) "\ Remove HEADER in the narrowed buffer. If REGEXP, HEADER is a regular expression." (save-excursion (let ((case-fold-search t) (regexp (if regexp header (concat "^" (regexp-quote header) ":")))) (goto-char (point-min)) (while (re-search-forward regexp nil t) (mhc-header-goto-end) (delete-region (match-beginning 0) (point)))))) (defun mhc-header-put-value (header value) "Overwrite VALUE of HEADER in the narrowed buffer." (if (assoc (downcase header) mhc-header-table) (setq header (substring (nth 1 (assoc (downcase header) mhc-header-table)) 0 -1))) (let ((case-fold-search t) (regexp (concat "^" (regexp-quote header) ":"))) (save-excursion (goto-char (point-min)) (if (re-search-forward regexp nil t) (save-restriction (mhc-header-goto-end) (delete-region (match-beginning 0) (point)) (insert (format "%s: %s\n" header value)) (narrow-to-region (point) (point-max)) (mhc-header-delete-header header)) (goto-char (point-max)) (insert (format "%s: %s\n" header value)))))) (defun mhc-header-get-value (header &optional repeat) "Return value of HEADER in the narrowed buffer." (let ((point (point)) (case-fold-search t) (regexp (concat "^" (regexp-quote header) ":[ \t]*")) value) (goto-char (point-min)) (while (and (not value) (re-search-forward regexp nil t repeat)) (mhc-header-goto-end) (setq value (buffer-substring-no-properties (match-end 0) (1- (point))))) (goto-char point) value)) (defun mhc-header-valid-p (header &optional repeat) "Valid HEADER in the narrowed buffer." (let ((get (mhc-header-get-value header repeat))) (and (stringp get) (not (string= "" get))))) (defun mhc-header-delete-separator () "Delete separator between header and body in this buffer." (save-excursion (goto-char (point-min)) (if (re-search-forward "^-*$" nil t) (delete-region (match-beginning 0) (match-end 0))))) (provide 'mhc-header) ;;; Copyright Notice: ;; Copyright (C) 1999, 2000 Yoshinari Nomura. All rights reserved. ;; Copyright (C) 2000 MHC developing team. All rights reserved. ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of the team nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' ;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ;; THE TEAM OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, ;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED ;; OF THE POSSIBILITY OF SUCH DAMAGE. ;;; mhc-header.el ends here. yoshinari-nomura-mhc-815a36a/emacs/mhc-logic.el000066400000000000000000000550251222073515200213770ustar00rootroot00000000000000;;; -*- mode: Emacs-Lisp; coding: utf-8 -*- ;; Author: TSUCHIYA Masatoshi ;; Created: 2000/04/30 ;; Revised: $Date$ ;;; Commentary: ;; This file is a part of MHC. ;; スケジュールの条件を表すヘッダを、その条件と等しいS式に変換するため ;; のライブラリ。 ;; S式は、以下のようなローカル変数の束縛の下で評価される。 ;; (let ((month 4) ;; (day 11048) ; 1970/1/1 からの日数 ;; (day-of-month 1) ;; (day-of-week 6) ; 0 = Sun, 1 = Mon, ... ;; (week-of-month 0) ; 0 = 1st, 1 = 2nd, 2 = 3rd, 3 = 4th, 4 = 5th ;; (last-week nil) ;; (todo nil)) ;; (eval sexp)) ;; 具体的な評価の形式は、mhc-logic-eval-for-date, mhc-db/eval-for-duration ;; 関数の定義などを参照。 ;; 条件が、Emacs-Lisp の述語のみからなるS式に変換されると、元々の条件 ;; の意味が分かりづらくなるため、一旦、元々のヘッダとほとんど同じ形式 ;; のマクロを用いた式に変換する。 ;; この中間式を参照することによって、元々の条件に対する意味論的な評価 ;; が可能となる(mhc-logic-file-to-slot)。 ;; また、通常の評価を行う場合は、中間式に含まれるマクロを完全に展開し ;; てから行うため(mhc-logic-compile-file)、スピードは高速に保たれる。 ;;; Definition: (require 'mhc-date) (require 'bytecomp) ;;---------------------------------------------------------------------- ;; MHC-LOGIC 構造体 ;;---------------------------------------------------------------------- ;; MHC-LOGIC ::= [ DAY AND TODO INTERMEDIATE SEXP ] ;; DAY ::= INT | NOT_INT ;; NOT_INT ::= ( INT . nil ) ;; INT ::= integer ( represents exceptional date ) ;; AND ::= conditions ( each condition represents X-SC-Cond: header ) ;; INTERMEDIATE ::= macro expression ;; SEXP ::= full expanded expression ;; mhc-logic/day = 日付(X-SC-Day)による条件 ;; mhc-logic/and = それ以外のヘッダに基づく条件 ;; mhc-logic/todo = TODOの順位 ;; mhc-logic/intermediate = 条件をS式に変換するための中間形式 ;; mhc-logic-sexp = 完全に展開されたS式 (defun mhc-logic-new () (make-vector 5 nil)) (defmacro mhc-logic/day (logicinfo) `(aref ,logicinfo 0)) (defmacro mhc-logic/and (logicinfo) `(aref ,logicinfo 1)) (defmacro mhc-logic-todo (logicinfo) `(aref ,logicinfo 2)) (defmacro mhc-logic/intermediate (logicinfo) `(aref ,logicinfo 3)) (defmacro mhc-logic-sexp (logicinfo) `(aref ,logicinfo 4)) (defmacro mhc-logic/set-day (logicinfo value) `(aset ,logicinfo 0 ,value)) (defmacro mhc-logic/set-and (logicinfo value) `(aset ,logicinfo 1 ,value)) (defmacro mhc-logic/set-todo (logicinfo value) `(aset ,logicinfo 2 ,value)) (defmacro mhc-logic/set-intermediate (logicinfo value) `(aset ,logicinfo 3 ,value)) (defmacro mhc-logic/set-sexp (logicinfo value) `(aset ,logicinfo 4 ,value)) (defun mhc-logic-day-as-string-list (logicinfo) (mapcar (lambda (day) (if (consp day) (mhc-date-format (car day) "!%04d%02d%02d" yy mm dd) (mhc-date-format day "%04d%02d%02d" yy mm dd))) (mhc-logic/day logicinfo))) ;;---------------------------------------------------------------------- ;; 条件式を評価する関数 ;;---------------------------------------------------------------------- (defun mhc-logic-eval-for-date (sexp-list day &optional todo) "指定された日のスケジュールを探索" (mhc-day-let day (let ((week-of-month (/ (+ day-of-month (mhc-date-ww (mhc-date-mm-first day)) -8) 7)) (last-week (> 7 (- (mhc-date/last-day-of-month year month) day-of-month))) (new (mhc-day-new year month day-of-month day-of-week))) (mhc-day-set-schedules new (delq nil (mapcar (lambda (sexp) (and sexp (funcall sexp))) sexp-list))) new))) ;;---------------------------------------------------------------------- ;; 条件式を生成するための関数群 ;;---------------------------------------------------------------------- ;; S式を表現する中間形式のマクロ ;; これらは、条件式の意味論的表示として用いられる。 (defmacro mhc-logic/condition-month (n) `(eq month ,n)) (defmacro mhc-logic/condition-day (n) `(eq day ,n)) (defmacro mhc-logic/condition-day-of-month (n) `(eq day-of-month ,n)) (defmacro mhc-logic/condition-day-of-week (n) `(eq day-of-week ,n)) (defmacro mhc-logic/condition-week-of-month (n) `(eq week-of-month ,n)) (defmacro mhc-logic/condition-last-week () 'last-week) (defmacro mhc-logic/condition-duration (begin end) `(and (>= day ,begin) (<= day ,end))) (defmacro mhc-logic/condition-duration-begin (begin) `(>= day ,begin)) (defmacro mhc-logic/condition-duration-end (end) `(<= day ,end)) (defconst mhc-logic/space-regexp "[,| \t\n]+" "構文要素の区切りに一致する正規表現") (defconst mhc-logic/not-regexp "\\(!\\)?[ \t]*" "構文要素の否定に一致する正規表現") (defconst mhc-logic/day-regexp "\\([0-9][0-9][0-9][0-9]\\)\\([0-9][0-9]\\)\\([0-9][0-9]\\)" "構文要素の日付に一致する正規表現") (defconst mhc-logic/day-of-month-regexp "0*\\([1-9]\\|[1-2][0-9]\\|3[01]\\)" "構文要素の該当月の何日目かを表す序数に一致する正規表現") (defconst mhc-logic/week-of-month-alist '(("1st" 0 (mhc-logic/condition-week-of-month 0)) ("2nd" 1 (mhc-logic/condition-week-of-month 1)) ("3rd" 2 (mhc-logic/condition-week-of-month 2)) ("4th" 3 (mhc-logic/condition-week-of-month 3)) ("5th" 4 (mhc-logic/condition-week-of-month 4)) ("last" 5 (mhc-logic/condition-last-week))) "構文要素の該当月の何週目かを表す序数の連想配列") (defconst mhc-logic/week-of-month-regexp (mhc-regexp-opt (mapcar (function car) mhc-logic/week-of-month-alist) 'paren) "構文要素の何週目かを表す序数に一致する正規表現") (defconst mhc-logic/day-of-week-alist '(("sun" . 0) ("mon" . 1) ("tue" . 2) ("wed" . 3) ("thu" . 4) ("fri" . 5) ("sat" . 6) ("sunday" . 0) ("monday" . 1) ("tuesday" . 2) ("wednesday" . 3) ("thursday" . 4) ("friday" . 5) ("saturday" . 6)) "構文要素の曜日の連想配列") (defconst mhc-logic/day-of-week-regexp (mhc-regexp-opt (mapcar (function car) mhc-logic/day-of-week-alist) 'paren) "構文要素の曜日に一致する正規表現") (defconst mhc-logic/month-alist '(("jan" . 1) ("feb" . 2) ("mar" . 3) ("apr" . 4) ("may" . 5) ("jun" . 6) ("jul" . 7) ("aug" . 8) ("sep" . 9) ("oct" . 10) ("nov" . 11) ("dec" . 12) ("january" . 1) ("february" . 2) ("march" . 3) ("april" . 4) ("june" . 6) ("july" . 7) ("august" . 8) ("september" . 9) ("october" .10) ("november" . 11) ("december" . 12)) "構文要素の月の連想配列") (defconst mhc-logic/month-regexp (mhc-regexp-opt (mapcar (function car) mhc-logic/month-alist) 'paren) "構文要素の月に一致する正規表現") (defconst mhc-logic/old-style-date-regexp "\\([0-9]+\\)[\t ]+\\([A-Z][a-z][a-z]\\)[\t ]+\\([0-9]+\\)" "構文要素の旧形式の日付指定に一致する正規表現") (defmacro mhc-logic/looking-at (&rest regexp) "正規表現に一致する構文要素を発見するマクロ" `(looking-at (concat ,@regexp mhc-logic/space-regexp))) (defun mhc-logic-parse-day (logicinfo) "X-SC-Day: ヘッダを解析する関数" (let ((d) (days (mhc-logic/day logicinfo))) (if (looking-at mhc-logic/space-regexp) (goto-char (match-end 0))) (while (not (eobp)) (or (mhc-logic/looking-at mhc-logic/not-regexp mhc-logic/day-regexp) (error "Parse ERROR !!! (at X-SC-Day:)")) (setq d (mhc-date-new (string-to-number (match-string 2)) (string-to-number (match-string 3)) (string-to-number (match-string 4))) days (cons (if (match-string 1) (cons d nil) d) days)) (goto-char (match-end 0))) (mhc-logic/set-day logicinfo (nreverse days)))) ;; xxxxx (defun mhc-logic-parse-old-style-date (logicinfo) "X-SC-Date: ヘッダの日付部分を解析する関数" (if (looking-at mhc-logic/space-regexp) (goto-char (match-end 0))) (let (month) (if (and (mhc-logic/looking-at mhc-logic/old-style-date-regexp) (setq month (cdr (assoc (downcase (match-string 2)) mhc-logic/month-alist)))) (let ((year (string-to-number (match-string 3)))) (mhc-logic/set-day logicinfo (cons (mhc-date-new (cond ((< year 69) (+ year 2000)) ((< year 1000) (+ year 1900)) (t year)) month (string-to-number (match-string 1))) (mhc-logic/day logicinfo))) (goto-char (match-end 0))) (error "Parse ERROR !!!(at X-SC-Date:)")))) (defun mhc-logic-parse-cond (logicinfo) "X-SC-Cond: ヘッダを解析する関数" (let (sexp day-of-month week-of-month day-of-week month) (if (looking-at mhc-logic/space-regexp) (goto-char (match-end 0))) (while (not (eobp)) (cond ;; 何日目 ((mhc-logic/looking-at mhc-logic/day-of-month-regexp) (setq day-of-month (cons (list 'mhc-logic/condition-day-of-month (string-to-number (match-string 1))) day-of-month))) ;; 何週目 ((mhc-logic/looking-at mhc-logic/week-of-month-regexp) (setq week-of-month (cons (nth 2 (assoc (downcase (match-string 1)) mhc-logic/week-of-month-alist)) week-of-month))) ;; 曜日 ((mhc-logic/looking-at mhc-logic/day-of-week-regexp) (setq day-of-week (cons (list 'mhc-logic/condition-day-of-week (cdr (assoc (downcase (match-string 1)) mhc-logic/day-of-week-alist))) day-of-week))) ;; 月 ((mhc-logic/looking-at mhc-logic/month-regexp) (setq month (cons (list 'mhc-logic/condition-month (cdr (assoc (downcase (match-string 1)) mhc-logic/month-alist))) month))) (t ;; 解釈できない要素の場合 (error "Parse ERROR !!!(at X-SC-Cond:)"))) (goto-char (match-end 0))) (mapcar (lambda (s) (set s (if (symbol-value s) (if (= 1 (length (symbol-value s))) (car (symbol-value s)) (cons 'or (nreverse (symbol-value s))))))) '(day-of-month week-of-month day-of-week month)) (setq sexp (cond ((and week-of-month day-of-week) `(and ,week-of-month ,day-of-week)) (week-of-month week-of-month) (day-of-week day-of-week))) (if day-of-month (setq sexp (if sexp (list 'or day-of-month sexp) day-of-month))) (if month (setq sexp (if sexp (list 'and month sexp) month))) (if sexp (mhc-logic/set-and logicinfo (cons sexp (mhc-logic/and logicinfo)))))) (defun mhc-logic-parse-duration (logicinfo) "X-SC-Duration: ヘッダを解析する関数" (let (sexp) (if (looking-at mhc-logic/space-regexp) (goto-char (match-end 0))) (while (not (eobp)) (setq sexp (cons (cond ((mhc-logic/looking-at mhc-logic/day-regexp "-" mhc-logic/day-regexp) (list 'mhc-logic/condition-duration (mhc-date-new (string-to-number (match-string 1)) (string-to-number (match-string 2)) (string-to-number (match-string 3))) (mhc-date-new (string-to-number (match-string 4)) (string-to-number (match-string 5)) (string-to-number (match-string 6))))) ((mhc-logic/looking-at mhc-logic/day-regexp "-") (list 'mhc-logic/condition-duration-begin (mhc-date-new (string-to-number (match-string 1)) (string-to-number (match-string 2)) (string-to-number (match-string 3))))) ((mhc-logic/looking-at "-" mhc-logic/day-regexp) (list 'mhc-logic/condition-duration-end (mhc-date-new (string-to-number (match-string 1)) (string-to-number (match-string 2)) (string-to-number (match-string 3))))) (t ; それ以外の場合 (error "Parse ERROR !!!(at X-SC-Duration:)"))) sexp)) (goto-char (match-end 0))) (if sexp (mhc-logic/set-and logicinfo (cons (if (= 1 (length sexp)) (car sexp) (cons 'or (nreverse sexp))) (mhc-logic/and logicinfo)))))) ;; Need to be deleted. (defun mhc-logic-parse-todo (logicinfo) (if (looking-at mhc-logic/space-regexp) (goto-char (match-end 0))) (let ((content (buffer-substring (point) (progn (skip-chars-forward "0-9") (point))))) (if (looking-at mhc-logic/space-regexp) (goto-char (match-end 0))) (if (eobp) (mhc-logic/set-todo logicinfo (string-to-number content)) (error "Parse ERROR !!!(at X-SC-Todo:)")))) (defun mhc-logic-compile-file (record) "日付を指定されたときに、関係するスケジュールを選びだすためのS式を生成する" (let ((sexp) (schedules (mhc-record-schedules record)) (byte-compile-warnings)) (while schedules (setq sexp (cons (mhc-logic/compile-schedule (car schedules)) sexp) schedules (cdr schedules))) (setq sexp (delq nil sexp)) (mhc-record-set-sexp record (if sexp (let (year month day day-of-month day-of-week week-of-month last-week todo) (byte-compile (list 'lambda () (if (= 1 (length sexp)) (car sexp) (cons 'or (nreverse sexp)))))))))) (defun mhc-logic/compile-schedule (schedule) "mhc-logic-compile-file の下請け関数" (let* ((logicinfo (mhc-schedule-condition schedule)) sexp) ;; 日付による例外条件とそれ以外の条件を結合した論理式を生成する (setq sexp (nreverse (delq nil (cons (let ((and (mhc-logic/and logicinfo))) (if and (if (= 1 (length and)) (list (car and) t) (list (cons 'and (reverse and)) t)))) (mapcar (lambda (day) (if (consp day) `((mhc-logic/condition-day ,(car day)) nil) `((mhc-logic/condition-day ,day) t))) (mhc-logic/day logicinfo)))))) (if sexp (progn ;; 条件の数によって、条件式を最適化しておく (setq sexp (if (= 1 (length sexp)) (if (nth 1 (car sexp)) (car (car sexp)) `(not ,(car (car sexp)))) (cons 'cond sexp))) ;; TODOに基づく条件を加える (setq sexp (if (mhc-logic-todo logicinfo) `(if todo t ,sexp) `(if todo nil ,sexp)))) (if (mhc-logic-todo logicinfo) (setq sexp 'todo))) ;; この中間形式を保存しておく (mhc-logic/set-intermediate logicinfo sexp) ;; 中間形式を展開する (mhc-logic/set-sexp logicinfo (if sexp (mhc-logic/macroexpand `(if ,sexp ,schedule)))))) (defun mhc-logic/macroexpand (sexp) "部分式に遡ってマクロを展開する関数" (macroexpand (if (listp sexp) (mapcar (function mhc-logic/macroexpand) sexp) sexp))) ;;---------------------------------------------------------------------- ;; mhc-logic-record-to-slot ;;---------------------------------------------------------------------- (defun mhc-logic-record-to-slot (record) "Return appropriate slot key, ( YEAR . MONTH ), for RECORD." (let ((schedules (mhc-record-schedules record)) pre-month cur-month) (while (and schedules (not (mhc-logic-todo (mhc-schedule-condition (car schedules)))) (setq cur-month (mhc-logic/check-sexp-range (mhc-schedule-condition (car schedules)))) (if pre-month (equal pre-month cur-month) (setq pre-month cur-month))) (setq schedules (cdr schedules))) (if schedules (cons nil nil) cur-month))) (defun mhc-logic/day-to-slot (day) "Generate slot key by DAY, which represents the number of days from 1970/01/01," (mhc-day-let day (cons year month))) (defun mhc-logic/check-sexp-range (logicinfo) "Estimate appropriate slot for LOGICINFO, with macro expression." (let (duration-begin duration-end day-list month-list require-duration) (mhc-logic/check-sexp-range-internal (mhc-logic/intermediate logicinfo)) (if (or (> (length month-list) 1) (if require-duration (or (not duration-begin) (not duration-end))) (progn (if day-list (setq day-list (sort day-list '<))) (not (equal (setq duration-begin (if day-list (mhc-logic/day-to-slot (if duration-begin (min (car day-list) duration-begin) (car day-list))))) (if day-list (mhc-logic/day-to-slot (if duration-end (max (nth (1- (length day-list)) day-list) duration-end) (nth (1- (length day-list)) day-list)))))))) '(nil . nil) duration-begin))) (eval-when-compile (defvar day-list) (defvar duration-begin) (defvar duration-end) (defvar month-list) (defvar require-duration)) (defun mhc-logic/check-sexp-range-internal (sexp) "Recursive subroutine of mhc-logic/check-sexp-range." (if (listp sexp) (cond ((eq (car sexp) 'mhc-logic/condition-duration) (if (or (not duration-begin) (< (nth 1 sexp) duration-begin)) (setq duration-begin (nth 1 sexp))) (if (or (not duration-end) (> (nth 1 sexp) duration-end)) (setq duration-end (nth 2 sexp)))) ((eq (car sexp) 'mhc-logic/condition-duration-begin) (if (or (not duration-begin) (< (nth 1 sexp) duration-begin)) (setq duration-begin (nth 1 sexp)))) ((eq (car sexp) 'mhc-logic/condition-duration-end) (if (or (not duration-end) (> (nth 1 sexp) duration-end)) (setq duration-end (nth 1 sexp)))) ((eq (car sexp) 'mhc-logic/condition-day) (setq day-list (cons (nth 1 sexp) day-list))) ((eq (car sexp) 'mhc-logic/condition-month) (or (memq (nth 1 sexp) month-list) (setq month-list (cons (nth 1 sexp) month-list))) (setq require-duration t)) ((eq (car sexp) 'mhc-logic/condition-day-of-week) (setq require-duration t)) ((eq (car sexp) 'mhc-logic/condition-day-of-month) (setq require-duration t)) (t (while sexp (mhc-logic/check-sexp-range-internal (car sexp)) (setq sexp (cdr sexp))))))) ; (defun mhc-logic-occur-multiple-p (logicinfo) ; "If LOGICINFO occurs multiple times, return t." ; (let (duration-begin duration-end day-list month-list require-duration) ; (mhc-logic/check-sexp-range-internal (mhc-logic/intermediate logicinfo)) ; (if (or duration-begin ; duration-end ; month-list ; (> (length day-list) 1)) ; t))) ;; rough (but safety) check -- nom (defun mhc-logic-occur-multiple-p (logicinfo) "If LOGICINFO occurs multiple times, return t." (if (or (mhc-logic/and logicinfo) (> (length (mhc-logic/day logicinfo)) 1)) t)) (provide 'mhc-logic) ;;; Copyright Notice: ;; Copyright (C) 1999, 2000 Yoshinari Nomura. All rights reserved. ;; Copyright (C) 2000 MHC developing team. All rights reserved. ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of the team nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' ;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ;; THE TEAM OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, ;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED ;; OF THE POSSIBILITY OF SUCH DAMAGE. ;;; mhc-logic.el ends here yoshinari-nomura-mhc-815a36a/emacs/mhc-mew.el000066400000000000000000000466671222073515200211060ustar00rootroot00000000000000;;; -*- mode: Emacs-Lisp; coding: utf-8 -*- ;; Author: Yoshinari Nomura , ;; Hideyuki SHIRAI ;; Created: 2000/05/10 ;; Revised: $Date$ ;;; Commentary: ;; This file is a part of MHC, includes MUA backend methods for Mew. ;;; Code: (require 'mew) (defcustom mhc-mew-redisplay-import nil "*If non-nil, re-display with no hooks and no x-face when a message imports" :group 'mhc :type 'boolean) ;; Internal Variables: (defvar mhc-mew-new-virtual-type (boundp 'mew-regex-summary2) "*Mew virtual format type. Non-nil means Mew 3.0.55 or later.") (defconst mhc-mew/summary-filename-regex (if mhc-mew-new-virtual-type ".*[^\006\n]+\006 \\+\\([^ ]*\\) \\([0-9]+\\)$" ".*\r *\\+\\([^ \t]+\\)[ \t]+\\([^ \t\n]+\\)")) ;; Mew 6.x does not need invisible property at (beginning-of-line) (defconst mhc-mew/header-string "") (defconst mhc-mew/header-string-review "") (defconst mhc-mew/summary-message-alist '((mew-summary-mode . mew-message-mode) (mew-virtual-mode . mew-message-mode))) (defconst mhc-mew/cs-m17n (if (>= emacs-major-version 20) 'ctext '*ctext*)) (defconst mhc-mew/lc-ascii (if (>= emacs-major-version 20) 'ascii 0)) ;; Setup function: ;;;###autoload (defun mhc-mew-setup () (require 'mhc) (setq mhc-mailer-package 'mew) (mhc-setup) (add-hook 'mew-summary-mode-hook 'mhc-mode) (add-hook 'mew-virtual-mode-hook 'mhc-mode) (add-hook 'mew-quit-hook 'mhc-exit)) (if (fboundp 'mew-match) (defalias 'mhc-mew/match-string 'mew-match) (defalias 'mhc-mew/match-string 'match-string)) ;; Backend methods: (defun mhc-mew-summary-filename () (let (folder number) (save-excursion (beginning-of-line) (if (not (looking-at mhc-mew/summary-filename-regex)) () (setq folder (buffer-substring (match-beginning 1) (match-end 1)) number (buffer-substring (match-beginning 2) (match-end 2))) (mhc-summary-folder-to-path folder number))))) (defun mhc-mew-summary-display-article () "Display the article on the current." (mew-summary-display 'force)) (defun mhc-mew-get-import-buffer (get-original) (let (mew-use-highlight-x-face mew-opt-highlight-x-face mew-message-hook mew-summary-display-message-filter-hook) (if get-original (condition-case nil (mew-summary-display-asis t) (error (mew-summary-display-asis))) (if mhc-mew-redisplay-import (cond ((fboundp 'mew-summary-analyze-again) (mew-summary-analyze-again)) ((fboundp 'mew-summary-display-command) (mew-summary-display-command)) (t (mew-summary-display)))))) (save-window-excursion (if (eq (cdr (assq major-mode mhc-mew/summary-message-alist)) (progn (other-window 1) major-mode)) (current-buffer)))) (defun mhc-mew/date-to-buffer (date) (mhc-date-format date "%s/%04d/%02d" mhc-base-folder yy mm)) (defun mhc-mew-generate-summary-buffer (date) (switch-to-buffer (set-buffer (mhc-get-buffer-create (mhc-mew/date-to-buffer date)))) (setq inhibit-read-only t buffer-read-only nil selective-display t selective-display-ellipses nil indent-tabs-mode nil) (widen) (delete-region (point-min) (point-max))) (defun mhc-mew/schedule-foldermsg (schedule) (let ((path (mhc-record-name (mhc-schedule-record schedule))) fld-msg) (if (and path (string-match (concat "^" (regexp-quote (file-name-as-directory mhc-mail-path))) path)) (if (fboundp 'mew-summary-parent-id) (progn (setq fld-msg (concat "+" (substring path (match-end 0)))) (setq fld (directory-file-name (file-name-directory fld-msg))) (setq msg (file-name-nondirectory fld-msg)) (with-temp-buffer (mew-insert-message fld msg mew-cs-text-for-read mew-header-reasonable-size) (setq msgid (or (mew-idstr-get-first-id (mew-header-get-value "X-SC-Record-Id:")) " ")) (setq ref (or (mew-idstr-get-first-id (mew-header-get-value mew-message-id:)) " "))) (concat "\r " (directory-file-name (file-name-directory fld-msg)) " " (file-name-nondirectory fld-msg) " " msgid " " ref " ")) (setq fld-msg (concat "+" (substring path (match-end 0)))) (concat "\r " (if mhc-mew-new-virtual-type "<> <> \006 ") (directory-file-name (file-name-directory fld-msg)) " " (file-name-nondirectory fld-msg))) ""))) (defun mhc-mew-insert-summary-contents (inserter) (insert (if mhc-tmp-schedule mhc-mew/header-string-review mhc-mew/header-string)) (funcall inserter) (insert (mhc-mew/schedule-foldermsg mhc-tmp-schedule) "\n")) (defun mhc-mew-summary-mode-setup (date) (make-local-variable 'mew-use-cursor-mark) (make-local-variable 'mew-use-highlight-cursor-line) (setq mew-use-cursor-mark nil) (setq mew-use-highlight-cursor-line nil) (let ((mew-virtual-mode-hook nil)) (mew-virtual-mode)) (mew-buffers-setup (buffer-name)) (and (mew-buffer-message) (get-buffer-window (mew-buffer-message)) (window-live-p (get-buffer-window (mew-buffer-message))) (delete-window (get-buffer-window (mew-buffer-message)))) ;; Mew-1.95b104 or later, disable mark highlight (when (boundp 'mew-summary-buffer-raw) (setq mew-summary-buffer-raw nil)) ;; Mew 4.x or later (when (fboundp 'mew-summary-set-count-line) (mew-summary-set-count-line)) ;; Mew 4.0.69 or later, fake mew-pickable-p() (when (fboundp 'mew-vinfo-set-flds) (mew-vinfo-set-flds `(,(mhc-mew/date-to-buffer date) ,(format "%s/intersect" mhc-base-folder)))) (mew-summary-toggle-disp-msg 'off)) ;; This function was orignally written by ;; Shun-ichi Goto (cf. http://www.imasy.org/~gotoh/) ;; Arranged by Hideyuki SHIRAI . (defun mhc-mew-decode-header () "mew-message-hook function to decode RAW JIS subject in header" (condition-case e (if (mew-current-get 'cache) (let* ((cache (mew-current-get 'cache)) (part (mew-current-get 'part)) (syntax (mew-cache-decode-syntax cache)) (ent (mew-syntax-get-entry syntax part)) (ct (mew-syntax-get-ct ent)) (buffer-read-only nil)) (if (not (equal "Message/Rfc822" (car ct))) () ; nothing to do ;; do only Message/Rfc822 contents (save-excursion (save-restriction (widen) (goto-char 1) (if (not (re-search-forward "\r?\n\r?\n" nil t)) () ; no header (narrow-to-region (point-min) (point)) (goto-char (point-min)) (if (not (re-search-forward "^X-SC-Subject:" nil t)) () (goto-char (point-min)) ;; decode raw JIS string (while (< (point) (point-max)) (if (looking-at "[^:]+:? *") (goto-char (match-end 0))) (if (and (not (looking-at "[\t\x20-\x7e]+$")) (equal (mew-find-cs-region (point) (save-excursion (end-of-line) (point))) (list mhc-mew/lc-ascii))) ;; decode! (mew-cs-decode-region (point) (save-excursion (end-of-line) (point)) mhc-mew/cs-m17n)) (beginning-of-line) (forward-line 1)) ;; re-highlight (mew-highlight-header) (save-excursion (mew-highlight-x-face (point-min) (point-max)))))))))) (error (ding t) (message "mhc-message-decode-header: %s" (or (cdr e) "some error!"))))) (defun mhc-mew-draft-setup-new () (make-local-variable 'mail-header-separator) (setq mail-header-separator mew-header-separator) (goto-char (point-min)) (mew-header-set (concat mew-header-separator "\n"))) (defun mhc-mew-draft-reedit-buffer (buffer original) ;; If current buffer is specified as buffer, no need to replace. (unless (eq (current-buffer) buffer) (erase-buffer) (insert-buffer buffer)) (make-local-variable 'mail-header-separator) (setq mail-header-separator mew-header-separator) (mhc-header-narrowing (mhc-header-delete-header "x-mew")) (goto-char (point-min)) (re-search-forward "^$" nil 'limit) (or (= (current-column) 0) (insert "\n")) (mew-header-set mew-header-separator) (goto-char (point-min))) (defun mhc-mew-draft-reedit-file (file) (erase-buffer) (insert-file-contents file) (make-local-variable 'mail-header-separator) (setq mail-header-separator mew-header-separator) (goto-char (point-min)) (and (re-search-forward "^$" nil t) (save-excursion (save-restriction (narrow-to-region (point-min) (point)) (goto-char (point-min)) (let ((mew-field-spec nil) (mew-decode-broken nil)) (mew-decode-rfc822-header t))))) (mhc-header-narrowing (mhc-header-delete-header "x-mew")) (goto-char (point-min)) (re-search-forward "^$" nil 'limit) (or (= (current-column) 0) (insert "\n")) (mew-header-set mew-header-separator) (goto-char (point-min))) (defun mhc-mew-highlight-message (for-draft) (when (mew-header-end) (mew-highlight-header)) ;; Mew-1.95b104 or later, not have functions. (when (and (fboundp 'mew-highlight-url) (fboundp 'mew-highlight-body)) (mew-highlight-url) (mew-highlight-body))) (defun mhc-mew-draft-translate () (let ((bufstr (buffer-substring (point-min) (point-max))) (case-fold-search t) ct cte boundary beg end) (condition-case nil (progn (mhc-header-narrowing ;; Mew can't encode Mime-Version ? (setq ct (mhc-header-get-value "content-type")) (setq cte (mhc-header-get-value "content-transfer-encoding")) (mhc-header-delete-header "mime-version") (mhc-header-delete-header "content-type") (mhc-header-delete-header "content-transfer-encoding")) (when (and ct (string-match "^multipart/" ct) (or (string-match "boundary=\"\\([^\"]+\\)\"" ct) (string-match "boundary=\\(.+\\)" ct))) (setq boundary (regexp-quote (mhc-mew/match-string 1 ct))) (let ((case-fold-search nil)) (goto-char (point-min)) (unless (and boundary (re-search-forward (concat "^--" boundary "$") nil t) (re-search-forward (concat "^--" boundary "--$") nil t)) ;; looks like Broken multi-part message. (setq boundary nil)))) (if (null (mew-header-end)) (mhc-header-narrowing (mew-header-encode-region (point-min) (point-max))) (mew-header-encode-region (point-min) (mew-header-end)) (mew-header-clear) (insert "\n")) (if (null boundary) ;; text/plain (progn (mhc-header-narrowing (mhc-header-put-value "Mime-Version" "1.0")) (mhc-mew/make-message)) ;; Multipart (mhc-header-narrowing (mhc-header-put-value "Mime-Version" "1.0") (mhc-header-put-value "Content-Type" (or ct mew-ct-txt)) (mhc-header-put-value "Content-Transfer-Encoding" (or cte mew-7bit))) (when (and (re-search-forward (concat "^--" boundary "$") nil t) (forward-line) (setq beg (point)) (re-search-forward (concat "\n--" boundary "\\(--\\)?$") nil t) (setq end (match-beginning 0))) ;; first sub-part (goto-char beg) (when (or (looking-at "^content-type: +text/plain") (looking-at "^$")) (save-excursion (save-restriction (narrow-to-region beg end) (mhc-mew/make-message))))))) (error (let ((buffer-read-only nil) (inhibit-read-only t)) (delete-region (point-min) (point-max)) (insert bufstr) (goto-char (point-min)) (ding t) (error "%s" (or (and (fboundp 'mew-tinfo-get-encode-err) (mew-tinfo-get-encode-err)) "Draft buffer has some illegal headers. Please fix it."))))))) (defun mhc-mew/make-message () (mew-charset-sanity-check (point-min) (point-max)) (goto-char (point-min)) (re-search-forward "^$" nil t) (forward-line) (let* ((charset (or (and mhc-default-coding-system (mew-cs-to-charset mhc-default-coding-system)) (mew-charset-guess-region (point) (point-max)) mew-us-ascii)) (cte (or (mew-charset-to-cte charset) mew-b64)) (switch mew-prog-mime-encode-text-switch) beg opt file) (mhc-header-narrowing (mhc-header-put-value "Content-Type" (concat "Text/Plain; charset=" charset)) (mhc-header-put-value "Content-Transfer-Encoding" cte)) (if (mew-case-equal cte mew-7bit) () (goto-char (point-min)) (re-search-forward "^$" nil t) (forward-line) (setq beg (point)) (mew-cs-encode-region beg (point-max) (mew-charset-to-cs charset)) (cond ((mew-case-equal cte mew-8bit) ()) ((and (mew-case-equal cte mew-b64) (fboundp 'base64-encode-region)) (goto-char beg) (while (search-forward "\n" nil t) (replace-match "\r\n")) (base64-encode-region beg (point-max)) (goto-char (point-max)) (insert "\n")) ((mew-which-exec mew-prog-mime-encode) (setq opt (mew-prog-mime-encode-get-opt cte switch)) (if (null opt) (mew-encode-error (concat "Unknown CTE: " cte)) (setq file (mew-make-temp-name)) (mew-frwlet mew-cs-dummy mew-cs-text-for-write ;; NEVER use call-process-region for privacy reasons (write-region beg (point-max) file nil 'no-msg)) (delete-region beg (point-max))) (mew-piolet mew-cs-text-for-read mew-cs-dummy (apply (function call-process) mew-prog-mime-encode file t nil opt)) (if (file-exists-p file) (delete-file file))) (t (mew-encode-error (concat mew-prog-mime-encode " doesn't exist"))))))) (defconst mhc-mew-header-decode-regex "\\(=\\?[^? \t]+\\?.\\?[^? \t]+\\?=\\)") (defun mhc-mew-eword-decode-string (string) (let ((ret "") tmpstr) (while (string-match "\n" string) (setq string (replace-match "" nil nil string))) (while (string-match (concat mhc-mew-header-decode-regex "\\([ \t]+\\)" mhc-mew-header-decode-regex) string) (setq string (replace-match "\\1\\3" nil nil string))) (while (string-match "[ \t\][ \t\]+" string) (setq string (replace-match " " nil nil string))) (while (not (string= string "")) (if (not (string-match mew-header-decode-regex string)) (setq ret (concat ret string) string "") (setq tmpstr (substring string (match-end 0))) (setq ret (concat ret (substring string 0 (match-beginning 0)) (mew-header-decode (mhc-mew/match-string 1 string) (mhc-mew/match-string 2 string) (mhc-mew/match-string 3 string)))) (setq string tmpstr))) ret)) (defun mhc-mew-decode-rfc822-header () (mew-decode-rfc822-header) (mew-header-goto-end) (mew-header-arrange (point-min) (point))) (defun mhc-mew-goto-message (&optional view) "Go to a view position on summary buffer." (when (fboundp 'mew-summary-goto-message) (mew-summary-goto-message)) (when view (condition-case nil (mew-summary-display 'force) (error (mew-summary-display))))) (provide 'mhc-mew) (put 'mhc-mew 'summary-filename 'mhc-mew-summary-filename) (put 'mhc-mew 'summary-display-article 'mhc-mew-summary-display-article) (put 'mhc-mew 'get-import-buffer 'mhc-mew-get-import-buffer) (put 'mhc-mew 'highlight-message 'mhc-mew-highlight-message) (put 'mhc-mew 'draft-mode 'mhc-mew-draft-mode) (put 'mhc-mew 'generate-summary-buffer 'mhc-mew-generate-summary-buffer) (put 'mhc-mew 'insert-summary-contents 'mhc-mew-insert-summary-contents) (put 'mhc-mew 'summary-search-date 'mhc-mew-summary-search-date) (put 'mhc-mew 'summary-mode-setup 'mhc-mew-summary-mode-setup) (put 'mhc-mew 'draft-setup-new 'mhc-mew-draft-setup-new) (put 'mhc-mew 'draft-reedit-buffer 'mhc-mew-draft-reedit-buffer) (put 'mhc-mew 'draft-reedit-file 'mhc-mew-draft-reedit-file) (put 'mhc-mew 'draft-translate 'mhc-mew-draft-translate) (put 'mhc-mew 'eword-decode-string 'mhc-mew-eword-decode-string) (put 'mhc-mew 'decode-header 'mhc-mew-decode-rfc822-header) (put 'mhc-mew 'goto-message 'mhc-mew-goto-message) ;;; Copyright Notice: ;; Copyright (C) 1999, 2000 Yoshinari Nomura. All rights reserved. ;; Copyright (C) 2000 MHC developing team. All rights reserved. ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of the team nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' ;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ;; THE TEAM OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, ;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED ;; OF THE POSSIBILITY OF SUCH DAMAGE. ;;; mhc-mew.el ends here. yoshinari-nomura-mhc-815a36a/emacs/mhc-mime.el000066400000000000000000000145561222073515200212350ustar00rootroot00000000000000;;; mhc-mime.el -- MIME module backend for MHC. ;; Author: Yuuichi Teranishi ;; ;; Created: 2000/07/26 ;; Revised: $Date: 2001/04/05 07:38:43 $ ;;; Commentary: ;; This file is a part of MHC, includes MUA backend methods for ;; MIME module (SEMI). ;;; Code: (require 'mime-edit) (defsubst mhc-mime-get-raw-buffer () "Get raw buffer of the current message for `mhc-mime-get-import-buffer'." (funcall (mhc-get-function 'mime-get-raw-buffer))) (defsubst mhc-mime-get-mime-structure () "Get mime message structure of the current message." (let ((function (mhc-get-function 'mime-get-mime-structure))) (when function (funcall function)))) (defvar mhc-mime-import-buffer " *MHC MIME import*") (defun mhc-mime-get-import-buffer (get-original) (let* ((structure (mhc-mime-get-mime-structure)) (raw-buffer (when (or get-original (not structure)) (mhc-mime-get-raw-buffer))) mime-view-ignored-field-list) (with-current-buffer (get-buffer-create mhc-mime-import-buffer) (if structure (mime-display-message structure (current-buffer)) (mime-view-buffer raw-buffer (current-buffer))) (let (buffer-read-only) (mhc-highlight-message)) (if get-original (cons raw-buffer (current-buffer)) (current-buffer))))) (defalias 'mhc-mime-eword-decode-string 'eword-decode-string) (defun mhc-mime-decode-header () (mhc-header-narrowing (while (not (eobp)) (if (looking-at "X-SC-Schedule:") (save-restriction (narrow-to-region (point) (progn (mhc-header-goto-end) (point))) (goto-char (point-min)) (while (search-forward "\\" nil t) (insert "\\")) (goto-char (point-min)) (while (search-forward "\n" nil t) (goto-char (match-beginning 0)) (delete-region (match-beginning 0) (match-end 0)) (insert "\\n")) (goto-char (point-max))) (mhc-header-goto-end))) (mime-decode-header-in-region (point-min) (point-max) 'decode) (goto-char (point-min)) (while (not (eobp)) (when (looking-at "X-SC-Schedule:") (save-restriction (narrow-to-region (point) (progn (end-of-line) (point))) (goto-char (point-min)) (while (re-search-forward "\\(\\\\\\\\\\)\\|\\\\n" nil t) (goto-char (match-beginning 0)) (delete-region (match-beginning 0) (match-end 0)) (insert (if (match-beginning 1) "\\" "\n"))))) (forward-line 1)))) (defun mhc-mime-draft-translate () (let (mime-edit-insert-user-agent-field) (mime-edit-translate-buffer) (save-excursion (goto-char (point-min)) (if (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$") nil t) (replace-match ""))))) (defun mhc-mime-draft-setup-new () (goto-char (point-min)) (insert mail-header-separator "\n")) (defsubst mhc-mime/draft-reedit () (save-excursion (let (ct cte start) (save-excursion (goto-char (point-min)) (if (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$") nil t) (replace-match ""))) (mhc-header-narrowing (mhc-header-delete-header (concat "^\\(" (mhc-regexp-opt mhc-draft-unuse-hdr-list) "\\)") 'regexp) (mhc-mime-decode-header) (setq ct (std11-fetch-field "content-type") cte (std11-fetch-field "content-transfer-encoding")) (mhc-header-delete-header mime-edit-again-ignored-field-regexp 'regexp)) (goto-char (point-min)) (when (re-search-forward "^$" nil t) (setq start (point)) (insert "Content-type: " (or ct "text/plain") "\n") (and cte (insert "Content-Transfer-Encoding: " cte "\n"))) (save-restriction (narrow-to-region (or start (point-min)) (point-max)) (mime-edit-decode-message-in-buffer) (widen) (goto-char (or start (point-min))) (insert mail-header-separator "\n"))))) (defun mhc-mime-draft-reedit-buffer (buffer original) ;; If current buffer is specified as buffer, no need to replace. (unless (eq (current-buffer) buffer) (erase-buffer) (insert-buffer buffer)) (if original ;; buffer is raw buffer. (mhc-mime/draft-reedit) (mhc-header-narrowing (mhc-header-delete-header mime-edit-again-ignored-field-regexp 'regexp)) (goto-char (point-min)) (when (re-search-forward "^$" nil t) (insert mail-header-separator)))) (defun mhc-mime-draft-reedit-file (file) (erase-buffer) (insert-file-contents-as-raw-text file) (mhc-mime/draft-reedit)) (provide 'mhc-mime) ;;; Copyright Notice: ;; Copyright (C) 1999, 2000 Yoshinari Nomura. All rights reserved. ;; Copyright (C) 2000 MHC developing team. All rights reserved. ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of the team nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' ;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ;; THE TEAM OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, ;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED ;; OF THE POSSIBILITY OF SUCH DAMAGE. ;;; mhc-mime.el ends here. yoshinari-nomura-mhc-815a36a/emacs/mhc-minibuf.el000066400000000000000000000377621222073515200217430ustar00rootroot00000000000000;;; mhc-minibuf.el ;; Author: Yoshinari Nomura ;; ;; Created: 1999/12/10 ;; Revised: $Date: 2004/09/08 09:12:10 $ ;;; ;;; Commentay: ;;; ;;; ;;; Code: ;;; (defvar mhc-minibuf-candidate-to-s-func nil) (defvar mhc-minibuf-candidate-alist nil) (defvar mhc-minibuf-candidate-offset 0) (defvar mhc-minibuf-candidate-overlay nil) (defvar mhc-minibuf-candidate-buffer nil) (defvar mhc-minibuf-candidate-delimiter nil) ;; (make-variable-buffer-local 'mhc-minibuf-candidate-to-s-func) ;; (make-variable-buffer-local 'mhc-minibuf-candidate-alist) ;; (make-variable-buffer-local 'mhc-minibuf-candidate-offset) ;; (make-variable-buffer-local 'mhc-minibuf-candidate-overlay) ;; (make-variable-buffer-local 'mhc-minibuf-candidate-buffer) (defun mhc-minibuf-read (&optional prompt default buffer cand offset to-s delimiter) (if mhc-minibuf-candidate-overlay (delete-overlay mhc-minibuf-candidate-overlay)) (setq mhc-minibuf-candidate-buffer buffer mhc-minibuf-candidate-alist cand mhc-minibuf-candidate-offset (or offset 0) mhc-minibuf-candidate-to-s-func to-s mhc-minibuf-candidate-delimiter delimiter) (if cand (progn (setq mhc-minibuf-candidate-overlay (make-overlay (mhc-minibuf-candidate-nth-begin) (mhc-minibuf-candidate-nth-end) buffer)) (overlay-put mhc-minibuf-candidate-overlay 'face 'mhc-minibuf-face-candidate) (mhc-minibuf-move-candidate 0 t t))) (read-from-minibuffer prompt (cond (default default) ((and to-s (mhc-minibuf-candidate-nth-obj) (funcall to-s (mhc-minibuf-candidate-nth-obj)))) (t "")) mhc-minibuf-map)) ;; access methods to candidate-alist ;; ;; candidate-alist is like: ;; ((score (begin . end) obj) ...) ;; (defun mhc-minibuf/get-nth-candidate (&optional alist n) (nth (or n mhc-minibuf-candidate-offset) (or alist mhc-minibuf-candidate-alist))) (defun mhc-minibuf-candidate-nth-score (&optional alist n) (let ((candidate (mhc-minibuf/get-nth-candidate alist n))) (if candidate (mhc-guess-get-score candidate)))) (defun mhc-minibuf-candidate-nth-begin (&optional alist n) (let ((candidate (mhc-minibuf/get-nth-candidate alist n))) (if candidate (mhc-guess-get-begin candidate)))) (defun mhc-minibuf-candidate-nth-end (&optional alist n) (let ((candidate (mhc-minibuf/get-nth-candidate alist n))) (if candidate (mhc-guess-get-end candidate)))) (defun mhc-minibuf-candidate-nth-obj (&optional alist n) (let ((candidate (mhc-minibuf/get-nth-candidate alist n))) (if candidate (cons (mhc-guess-get-date-or-time candidate) (mhc-guess-get-date-or-time-end candidate))))) ;; ;; move candidate by score. ;; (defun mhc-minibuf-candidate-inc-offset2 (&optional n) (let ((len (length mhc-minibuf-candidate-alist))) (if (< 0 len) (setq mhc-minibuf-candidate-offset (% (+ len (% (+ mhc-minibuf-candidate-offset (or n 1)) len)) len))))) ;; ;; move candidate by position. ;; xxx: offset is 1 or -1 only. ;; (defun mhc-minibuf-candidate-inc-offset (&optional n) (let* ((len (length mhc-minibuf-candidate-alist)) (cur (mhc-minibuf-candidate-nth-begin)) (max cur) (min cur) (max-i mhc-minibuf-candidate-offset) (min-i mhc-minibuf-candidate-offset) (i 0) nxt prv ptr prv-i nxt-i) (while (< i len) (setq ptr (mhc-minibuf-candidate-nth-begin mhc-minibuf-candidate-alist i)) (if (< max ptr) (setq max ptr max-i i)) (if (< ptr min) (setq min ptr min-i i)) (if (and (< cur ptr) (or (null nxt) (< ptr nxt))) (setq nxt ptr nxt-i i)) (if (and (< ptr cur) (or (null prv) (< prv ptr))) (setq prv ptr prv-i i)) (setq i (1+ i))) (if (< 0 n) (setq mhc-minibuf-candidate-offset (if nxt-i nxt-i min-i)) (setq mhc-minibuf-candidate-offset (if prv-i prv-i max-i))))) (defun mhc-minibuf-candidate-set-offset (n) (setq mhc-minibuf-candidate-offset n)) ;; ;; keybind ;; (defvar mhc-minibuf-map nil) ;; (setq mhc-minibuf-map nil) (if mhc-minibuf-map () (setq mhc-minibuf-map (copy-keymap minibuffer-local-map)) (define-key mhc-minibuf-map "\C-c?" 'mhc-minibuf-insert-calendar) (define-key mhc-minibuf-map "\C-n" 'mhc-minibuf-next-candidate) (define-key mhc-minibuf-map "\C-p" 'mhc-minibuf-prev-candidate) (define-key mhc-minibuf-map "\C-v" 'scroll-other-window) (define-key mhc-minibuf-map "\M-v" 'scroll-other-window-down)) ;; ;; minibuffer functions ;; ;; (defun mhc-minibuf-delete-word () ;; (delete-region ;; (save-excursion ;; (while (and (not (bobp)) ;; (string-match "[0-9:/-]" ;; (buffer-substring ;; (1- (point)) (point)))) ;; (forward-char -1)) ;; (point)) ;; (point))) (defun mhc-minibuf-delete-word (&optional delimiter) (delete-region (save-excursion (while (and (not (bobp)) (string-match (or delimiter "[0-9:/-]") (buffer-substring (1- (point)) (point)))) (forward-char -1)) (point)) (point))) (defun mhc-minibuf-move-candidate (offset &optional absolute non-minibuf) (if (not mhc-minibuf-candidate-alist) () (if absolute (mhc-minibuf-candidate-set-offset offset) (mhc-minibuf-candidate-inc-offset offset)) ;; (y-or-n-p (format "%d" mhc-minibuf-candidate-offset)) (let* ((b (mhc-minibuf-candidate-nth-begin)) (e (mhc-minibuf-candidate-nth-end)) (obj (mhc-minibuf-candidate-nth-obj)) (str (if (and mhc-minibuf-candidate-to-s-func obj) (funcall mhc-minibuf-candidate-to-s-func obj) ""))) (if (not (and mhc-minibuf-candidate-overlay b)) () (move-overlay mhc-minibuf-candidate-overlay b e) (if (not non-minibuf) (pop-to-buffer mhc-minibuf-candidate-buffer)) (goto-char b) (if (not (pos-visible-in-window-p b)) (recenter)) (if (not non-minibuf) (pop-to-buffer (window-buffer (minibuffer-window)))) ;; in minibuffer (if non-minibuf () ;; (if (string-match "-" str) ;; (delete-region (point-min) (point-max)) ;; (mhc-minibuf-delete-word)) (mhc-minibuf-delete-word mhc-minibuf-candidate-delimiter) (insert str)))))) (defun mhc-minibuf-next-candidate () (interactive) (mhc-minibuf-move-candidate 1)) (defun mhc-minibuf-prev-candidate () (interactive) (mhc-minibuf-move-candidate -1)) ;; ;; input functions for mhc. ;; (defun mhc-minibuf/date-to-string (date-cons) (let ((date (car date-cons)) (date2 (cdr date-cons))) (concat (mhc-date-format date "%04d/%02d/%02d" yy mm dd) (if date2 (mhc-date-format date2 "-%04d/%02d/%02d" yy mm dd) "")))) (defun mhc-minibuf/time-to-string (time-cons) (let ((time (car time-cons)) (time2 (cdr time-cons))) (if time2 (concat (mhc-time-to-string time) "-" (mhc-time-to-string time2)) (mhc-time-to-string time)))) (defun mhc-minibuf/location-to-string (location-cons) (let ((loc (car location-cons)) (loc2 (cdr location-cons))) (if loc2 (concat (format "%s" loc) "-" (format "%s" loc2)) (format "%s" loc)))) (defun mhc-input-day (&optional prompt default candidate) (interactive) (let (str-list date ret (error t) str) (while error (setq str (mhc-minibuf-read (concat (or prompt "") "(yyyy/mm/dd): ") (if candidate nil (cond ((and (stringp default) (mhc-date-new-from-string default t)) default) ((mhc-date-p default) (mhc-date-format default "%04d/%02d/%02d" yy mm dd)) ((listp default) (mapconcat (lambda (date) (mhc-date-format date "%04d/%02d/%02d" yy mm dd)) default " ")) (t nil))) (current-buffer) candidate 0 (function mhc-minibuf/date-to-string)) str-list (mhc-misc-split str) ret nil error nil) (while (car str-list) (cond ((= 2 (length (mhc-misc-split (car str-list) "-"))) (let* ((duration (mhc-misc-split (car str-list) "-")) (b (mhc-date-new-from-string2 (nth 0 duration) nil t)) (e (mhc-date-new-from-string2 (nth 1 duration) b t))) (if (and b e (mhc-date< b e)) (progn (setq date b) (while (mhc-date<= date e) (if (not (member date ret)) (setq ret (cons date ret)) (setq error t)) (setq date (mhc-date++ date)))) (setq error t)))) ((string= (car str-list) "") ()) ((setq date (mhc-date-new-from-string2 (car str-list) date t)) (if (not (member date ret)) (setq ret (cons date ret)) (setq error t))) ((string= (car str-list) "none") ()) (t (setq error t))) (setq str-list (cdr str-list))) (if error (beep))) (mhc-calendar-input-exit) (mhc-date-sort ret))) (defun mhc-input-time (&optional prompt default candidate) (interactive) (let (str time-b time-e) (catch 'ok (while t (setq str (mhc-minibuf-read (concat (or prompt "") "(HH:MM-HH:MM or none) ") (if candidate nil (if default (if (stringp default) default (mhc-minibuf/time-to-string default) ""))) (current-buffer) candidate 0 (function mhc-minibuf/time-to-string))) (cond ((and (string-match "^\\([0-9]+:[0-9]+\\)\\(-\\([0-9]+:[0-9]+\\)\\)?$" str) (setq time-b (mhc-time-new-from-string (substring str (match-beginning 1) (match-end 1)) t mhc-input-time-regex))) (if (not (match-beginning 3)) (throw 'ok (list time-b nil))) (if (and (setq time-e (mhc-time-new-from-string (substring str (match-beginning 3) (match-end 3)) t mhc-input-time-regex)) (mhc-time<= time-b time-e)) (throw 'ok (list time-b time-e)))) ((string= "" str) (throw 'ok (list nil nil)))) (beep))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; input x-sc- schedule data from minibuffer. (defvar mhc-month-hist nil) (defun mhc-input-month (prompt &optional default) (let ((ret nil) (month-str (mhc-date-format (or default (mhc-date-now)) "%04d/%02d" yy mm))) (while (null ret) (setq month-str (read-from-minibuffer (concat prompt "(yyyy/mm) : ") month-str nil nil 'mhc-month-hist)) (if (string-match "\\([0-9]+\\)/\\([0-9]+\\)" month-str) (setq ret (mhc-date-new (string-to-number (match-string 1 month-str)) (string-to-number (match-string 2 month-str)) 1 t)))) ret)) (defconst mhc-input-time-regex "^\\([0-9]+\\):\\([0-9]+\\)$") (defvar mhc-subject-hist nil) (defun mhc-input-subject (&optional prompt default) (interactive) (read-from-minibuffer (or prompt "Subject: ") (or default "") nil nil 'mhc-subject-hist)) (defvar mhc-location-hist nil) ;; (defun mhc-input-location (&optional prompt default) ;; (interactive) ;; (read-from-minibuffer (or prompt "Location: ") ;; (or default "") ;; nil nil 'mhc-location-hist)) (defun mhc-input-location (&optional prompt default) (mhc-minibuf-read "Location: " default (current-buffer) (mhc-guess-location) 0 (function mhc-minibuf/location-to-string) "[^ ]")) (defvar mhc-category-hist nil) (if (fboundp 'completing-read-multiple) (defun mhc-input-category (&optional prompt default) (interactive) (let ((completion-ignore-case t) (table (nconc (delete '("Todo") (delete '("Done") (mapcar (lambda (x) (list (car x))) mhc-category-face-alist))) (list '("Todo") '("Done"))))) (completing-read-multiple (or prompt "Category: ") ;PROMPT table nil ;PREDICATE nil ;REQUIRE-MATCH default ;INITIAL-INPUT 'mhc-category-hist ;HIST ))) (defun mhc-input-category (&optional prompt default) (interactive) (let (in) (and default (listp default) (setq default (mapconcat 'identity default " "))) (if (string= "" (setq in (read-from-minibuffer (or prompt "Category: ") (or default "") nil nil 'mhc-category-hist))) nil (mhc-misc-split in))))) (defvar mhc-recurrence-tag-hist nil) (defun mhc-input-recurrence-tag (&optional prompt default) (interactive) (read-from-minibuffer (or prompt "Recurrence Tag: ") (or default "") nil nil 'mhc-recurrence-tag-hist)) (defvar mhc-alarm-hist nil) (defun mhc-input-alarm (&optional prompt default) (interactive) (read-from-minibuffer (or prompt "Alarm: ") (or default mhc-default-alarm) nil nil 'mhc-alarm-hist)) (provide 'mhc-minibuf) ;;; Copyright Notice: ;; Copyright (C) 1999, 2000 Yoshinari Nomura. All rights reserved. ;; Copyright (C) 2000 MHC developing team. All rights reserved. ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of the team nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' ;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ;; THE TEAM OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, ;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED ;; OF THE POSSIBILITY OF SUCH DAMAGE. ;;; mhc-minibuf.el ends here yoshinari-nomura-mhc-815a36a/emacs/mhc-misc.el000066400000000000000000000172261222073515200212360ustar00rootroot00000000000000;;; mhc-misc.el -- miscellaneous functions for mhc. ;; Author: Yoshinari Nomura ;; ;; Created: 1997/10/12 ;; Revised: $Date: 2002/12/01 03:55:06 $ ;;; ;;; Commentay: ;;; ;;; ;;; Code: ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; string (defun mhc-misc-sub (str regex replace) (if (and (stringp str) (string-match regex str)) (concat (substring str 0 (match-beginning 0)) replace (substring str (match-end 0))) str)) (defun mhc-misc-gsub (str regex replace) (if (and (stringp str) (string-match regex str)) (concat (substring str 0 (match-beginning 0)) replace (mhc-misc-gsub (substring str (match-end 0)) regex replace)) str)) (defun mhc-misc-split (str &optional sep) (let ((ret ())) (while (string-match (or sep "[\t ]+") str) (setq ret (cons (substring str 0 (match-beginning 0)) ret)) (setq str (substring str (match-end 0)))) (nreverse (cons str ret)))) (defun mhc-misc-strip (str) (mhc-misc-sub (mhc-misc-sub str "^[\t ]+" "") "[\t ]+$" "")) (defun mhc-misc-substring-to-int (str pos) (cond ((stringp str) (string-to-number (substring str (match-beginning pos) (match-end pos)))) (t (string-to-number (buffer-substring (match-beginning pos) (match-end pos)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; file & path (defun mhc-misc-get-new-path (dir) "Return name for new schedule file on DIR." (let (dirent (max 0) (num nil)) (mhc-file-make-directory dir) (setq dirent (directory-files dir nil nil t)) (while dirent (or (string-match "[^0-9]" (car dirent)) (if (< max (setq num (string-to-number (car dirent)))) (setq max num))) (setq dirent (cdr dirent))) (expand-file-name (number-to-string (1+ max)) dir))) ;; ;; touch directory and files. ;; (defvar mhc-mtime-file ".mhc-mtime") (defun mhc-misc-get-mtime (obj) (let ((mtime-file (expand-file-name mhc-mtime-file obj))) (cond ((not (stringp obj)) nil) ((file-exists-p mtime-file) (nth 5 (file-attributes mtime-file))) ((file-exists-p obj) (nth 5 (file-attributes obj))) (t nil)))) (defun mhc-misc-touch-directory (dir) (let ((mtime-file (expand-file-name mhc-mtime-file dir))) (if (file-writable-p mtime-file) ;; (write-region (point-min) (point-min) mtime-file nil 'silence)) (write-region 1 2 mtime-file nil 'silence)) )) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; rectangle ;; ;; Does (current-column) count visible character only? ;; emacs 19.34, 20.4, 20.5 -- yes ;; emacs 19.28 -- no ;; xemacs -- no ;; (defvar mhc-misc-column-count-visible-only (and (not (featurep 'xemacs)) (string< "19.3" emacs-version))) (defun mhc-misc-move-to-column (column) "Move point to column COLUMN rigidly in the current line, considering invisible charracters." (if mhc-misc-column-count-visible-only () (beginning-of-line) (let* ((bol (point)) (vis (if (get-char-property bol 'invisible) (next-single-property-change bol 'invisible) bol))) (setq column (+ column (- vis bol))))) (if (< column (move-to-column column t)) (progn (delete-char -1) (insert ?\ )))) (defun mhc-misc-current-column () "Return current column in a visible field." (if mhc-misc-column-count-visible-only (current-column) (let* ((bol (save-excursion (beginning-of-line) (point))) (vis (if (get-char-property bol 'invisible) (next-single-property-change bol 'invisible) bol))) (- (current-column) (- vis bol))))) (defun mhc-misc-insert-rectangle (rectangle) (let ((lines rectangle) (insertcolumn (mhc-misc-current-column)) (first t)) ;; (push-mark) (while lines (or first (progn (forward-line 1) (or (bolp) (insert ?\n)) (mhc-misc-move-to-column insertcolumn))) (setq first nil) (if (looking-at "[^\r\n]+") (delete-region (point) (match-end 0))) (insert (car lines)) (setq lines (cdr lines))))) (defun mhc-misc-get-width () (let ((dw (* mhc-calendar-width 2)) (ww (window-width)) (fw (frame-width))) (cond ((> ww dw) ww) ((and (< (* ww 2) fw) (> (* ww 2) dw)) (* ww 2)) ((> fw dw) fw) (t dw)))) ;; read-passwd (defun mhc-misc-read-passwd (prompt) (let ((inhibit-input-event-recording t)) (if (fboundp 'read-passwd) (condition-case nil (read-passwd prompt) ;; If read-passwd causes an error, let's return "" so that ;; the password process will safely fail. (error "")) (let ((pass "") (c 0) (echo-keystrokes 0) (ociea cursor-in-echo-area)) (condition-case nil (progn (setq cursor-in-echo-area 1) (while (and (/= c ?\r) (/= c ?\n) (/= c ?\e) (/= c 7)) ;; ^G (message "%s%s" prompt (make-string (length pass) ?.)) (setq c (read-char-exclusive)) (cond ((char-equal c ?\C-u) (setq pass "")) ((or (char-equal c ?\b) (char-equal c ?\177)) ;; BS DELL ;; delete one character in the end (if (not (equal pass "")) (setq pass (substring pass 0 -1)))) ((< c 32) ()) ;; control, just ignore (t (setq pass (concat pass (char-to-string c)))))) (setq cursor-in-echo-area -1)) (quit (setq cursor-in-echo-area ociea) (signal 'quit nil)) (error ;; Probably not happen. Just align to the code above. (setq pass ""))) (setq cursor-in-echo-area ociea) (message "") (sit-for 0) pass)))) (provide 'mhc-misc) ;;; Copyright Notice: ;; Copyright (C) 1999, 2000 Yoshinari Nomura. All rights reserved. ;; Copyright (C) 2000 MHC developing team. All rights reserved. ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of the team nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' ;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ;; THE TEAM OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, ;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED ;; OF THE POSSIBILITY OF SUCH DAMAGE. ;;; mhc-misc.el ends here yoshinari-nomura-mhc-815a36a/emacs/mhc-parse.el000066400000000000000000000244421222073515200214130ustar00rootroot00000000000000;;; -*- mode: Emacs-Lisp; coding: utf-8 -*- ;; Author: Yoshinari Nomura , ;; TSUCHIYA Masatoshi ;; Created: 2000/04/30 ;; Revised: $Date$ ;;; Commentary: ;; This file is a part of MHC, and includes functions to parse ;; schedule headers. ;;; Code: (require 'mhc-logic) (require 'mhc-record) (require 'mhc-header) (defvar mhc-parse/strict nil) (defun mhc-parse/continuous-lines () "ヘッダの継続行を処理して、内容のみを取り出す関数" (let (list) (skip-chars-forward " \t\n") (while (not (eobp)) (setq list (cons (buffer-substring-no-properties (point) (progn (end-of-line) (skip-chars-backward " \t") (point))) list)) (end-of-line) (skip-chars-forward " \t\n")) (mapconcat 'identity (nreverse list) " "))) (defun mhc-parse/day (record schedule) (mhc-logic-parse-day (mhc-schedule-condition schedule)) schedule) (defun mhc-parse/cond (record schedule) (mhc-logic-parse-cond (mhc-schedule-condition schedule)) schedule) (defun mhc-parse/duration (record schedule) (mhc-logic-parse-duration (mhc-schedule-condition schedule)) schedule) ;; FIXME: Need to be deleted. (defun mhc-parse/todo (record schedule) (mhc-logic-parse-todo (mhc-schedule-condition schedule)) schedule) (defun mhc-parse/priority (record schedule) (if (looking-at mhc-logic/space-regexp) (goto-char (match-end 0))) (let ((content (buffer-substring (point) (progn (skip-chars-forward "0-9") (point))))) (if (looking-at mhc-logic/space-regexp) (goto-char (match-end 0))) (if (eobp) (mhc-schedule/set-priority schedule (if (eq (length content) 0) nil (string-to-number content))) (error "Parse ERROR !!!(at X-SC-Priority:)"))) schedule) (defun mhc-parse/subject (record schedule) (mhc-schedule/set-subject schedule (mhc-eword-decode-string (mhc-parse/continuous-lines))) schedule) (defun mhc-parse/location (record schedule) (mhc-schedule/set-location schedule (mhc-eword-decode-string (mhc-parse/continuous-lines))) schedule) (defconst mhc-parse/time-regexp "\\([012][0-9]\\):\\([0-5][0-9]\\)") (defun mhc-parse/time (record schedule) (let ((time (mhc-parse/continuous-lines)) begin end) (cond ((string-match (concat "^" mhc-parse/time-regexp "-" mhc-parse/time-regexp "$") time) (setq begin (+ (* 60 (string-to-number (match-string 1 time))) (string-to-number (match-string 2 time))) end (+ (* 60 (string-to-number (match-string 3 time))) (string-to-number (match-string 4 time))))) ((string-match (concat "^" mhc-parse/time-regexp "-?$") time) (setq begin (+ (* 60 (string-to-number (match-string 1 time))) (string-to-number (match-string 2 time))))) ((string-match (concat "^-" mhc-parse/time-regexp "$") time) (setq end (+ (* 60 (string-to-number (match-string 1 time))) (string-to-number (match-string 2 time))))) ((and mhc-parse/strict (not (string= "" time))) (error "Parse ERROR!!!(at X-SC-Time:)"))) (mhc-schedule/set-time schedule begin end)) schedule) ;; For backward compatibility. (defun mhc-parse/old-style-date (record schedule) (mhc-logic-parse-old-style-date (mhc-schedule-condition schedule)) (mhc-parse/time record schedule)) (defconst mhc-parse/alarm-regexp "^[0-9]+ \\(minute\\|hour\\|day\\)$") (defun mhc-parse/alarm (record schedule) (let ((alarm (mhc-parse/continuous-lines))) (unless (or (not mhc-parse/strict) (string-match mhc-parse/alarm-regexp alarm) (string= "" alarm)) (error "Parse ERROR!!! (at X-SC-Alarm:)")) (mhc-schedule/set-alarm schedule alarm)) schedule) (defun mhc-parse/category (record schedule) (let ((category (mhc-parse/continuous-lines))) (mhc-schedule/set-categories schedule (nconc (delq nil (mapcar (lambda (str) (and (stringp str) (downcase str))) (mhc-misc-split (mhc-eword-decode-string category) "[ \t]+"))) (mhc-schedule-categories schedule)))) (mhc-logic/set-todo (mhc-schedule-condition schedule) (mhc-schedule-in-category-p schedule "todo")) schedule) (defun mhc-parse/recurrence-tag (record schedule) (mhc-schedule/set-recurrence-tag schedule (mhc-eword-decode-string (mhc-parse/continuous-lines))) schedule) ;; FIXME: 要削除 (defun mhc-parse/next (record schedule) (let ((new (mhc-schedule-new record))) (if schedule (mhc-schedule/set-region-end schedule (point-min))) (mhc-schedule/set-region-start new (point-min)) new)) ;; FIXME: X-SC-Schedule の入れ子構造は、(mhc-db-add-exception-rule) の ;; 実装の都合上受け入れられないので、top level 以外の X-SC-Schedule は ;; 安全に無視される必要がある。 (defun mhc-parse/schedule (record schedule) (let ((buffer (current-buffer)) (start (point)) (end (point-max)) (schedule (mhc-schedule-new record))) (mhc-schedule/set-region-start schedule start) (mhc-schedule/set-region-start schedule end) (with-temp-buffer (insert-buffer-substring buffer start end) (goto-char (point-min)) (while (not (eobp)) (let ((start (point))) (if (skip-chars-forward " \t\n") (delete-region start (point)))) (while (if (eobp) nil (eq ?\\ (progn (end-of-line) (preceding-char)))) (delete-char -1) (forward-line)) (forward-line)) (goto-char (point-min)) (mhc-parse/internal-parser record schedule))) schedule) ;; FIXME: top level 以外の場所で記述された X-SC-Record-Id: は安全に無 ;; 視される必要があるが、現在の実装では何も考えずに上書きしてしまう。 (defun mhc-parse/record-id (record schedule) (mhc-record-set-id record (mhc-parse/continuous-lines)) schedule) ;; FIXME: top level とそれ以外の場所で許される header が異なるので、 ;; multi pass parser に組み替えるべきかも知れない。 (defun mhc-parse/internal-parser (record &optional schedule strict) "Internal parseser of schedule headers in this narrowed buffer." (let ((mhc-parse/strict strict) (case-fold-search t) func) (while (not (eobp)) (if (looking-at "\\([^ \t:]+\\):") (progn (setq func (mhc-header-parse-function (format "%s" (match-string 1)))) (mhc-header-goto-end) (if (fboundp func) (save-restriction (narrow-to-region (match-beginning 0) (point)) (goto-char (match-end 0)) (setq schedule (funcall func record (or schedule (if (memq func '(mhc-parse/schedule mhc-parse/next)) nil (mhc-parse/next record nil))))) (goto-char (point-max))))) ;; Always skip non-header lines. (forward-line 1)))) schedule) (defun mhc-parse-buffer (&optional record strict) "Parse schedule headers in this buffer." (unless record (setq record (mhc-record-new (buffer-file-name)))) (mhc-header-narrowing (let ((schedule (mhc-parse/internal-parser record nil strict))) (if schedule (mhc-schedule/set-region-end schedule (point))))) ;; 得られた構造を整理する (let (schedules sexp) ;; 現れた順序に直しておく (mhc-record-set-schedules record (nreverse (mhc-record-schedules record))) ;; 先頭のスケジュールをデフォルトとして参照して、欠けている要素を埋めておく (setq schedules (cdr (mhc-record-schedules record))) (while schedules (mhc-schedule-append-default (car schedules) (car (mhc-record-schedules record))) (setq schedules (cdr schedules))) ;; 各スケジュールの条件式を生成する (mhc-logic-compile-file record)) record) (defun mhc-parse-file (filename) "Parse schedules headers in the file, FILENAME." (save-excursion (set-buffer (mhc-get-buffer-create " *mhc-parse-file*")) (delete-region (point-min) (point-max)) (mhc-insert-file-contents-as-coding-system mhc-default-coding-system filename) (mhc-parse-buffer (mhc-record-new filename)))) (provide 'mhc-parse) ;;; Copyright Notice: ;; Copyright (C) 1999, 2000 Yoshinari Nomura. All rights reserved. ;; Copyright (C) 2000 MHC developing team. All rights reserved. ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of the team nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' ;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ;; THE TEAM OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, ;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED ;; OF THE POSSIBILITY OF SUCH DAMAGE. ;;; mhc-parse.el ends here. yoshinari-nomura-mhc-815a36a/emacs/mhc-ps.el000066400000000000000000001063141222073515200207220ustar00rootroot00000000000000;;; -*- mode: Emacs-Lisp; coding: utf-8 -*- ;; Author: TSUCHIYA Masatoshi ;; Hideyuki SHIRAI ;; Created: 2000/06/18 ;; Revised: $Date: 2004/05/06 16:35:12 $ ;;; Commentary: ;; This file is a part of MHC and includes functions to make ;; PostScrpit calendar. ;;; History: ;; Original PostScript program was written ;; by Patrick Wood in 1987. ;; ;; Shell stuff added by King Ables at Sep 3, 1987. ;; ;; Made pretty by tjt in 1988. ;; ;; Holiday and printer flag passing hacks added by ;; smann@june.cs.washington.edu in Dec 1988. ;; ;; Used the better looking version with 5 rows of days rather than 6 ;; hacked together with holiday and banner/footnotes added ;; by Joe Wood in Dec 1989. ;; ;; Fixed "-R" (didn't work at all; now it at least works on 8.5x11) ;; and also fixed handling of unrecognized arguments ;; by Jeff Mogul in Jan 1990. ;; ;; Japanized and improved handling holidays ;; by SUZUKI Shingo in Feb 2000. ;; ;; Stuffs rewritten with Emacs Lisp ;; by TSUCHIYA Masatoshi ;; in Jun 2000. ;;; Bugs: ;; This program doesn't work for months before 1753 (weird stuff ;; happened in September, 1752). ;;; Code: (require 'mhc) ;;; Customize variables: (defcustom mhc-ps-preview-command "gv" "*Command to preview PostScript calendar." :group 'mhc :type 'string) (defcustom mhc-ps-preview-command-arguments '() "*Argument of previewer" :group 'mhc :type '(repeat string)) (defcustom mhc-ps-print-command "lp" "*Command to print PostScript calendar." :group 'mhc :type 'string) (defcustom mhc-ps-print-command-arguments '() "*Argument of print command." :group 'mhc :type '(repeat string)) (defcustom mhc-ps-paper-type t "*Calendar paper type." :group 'mhc :type '(radio (const :tag "Landscape" t) (const :tag "Portrait" nil))) (defcustom mhc-ps-paper-fill-print nil "*Fill printing just in Landscape paper size." :group 'mhc :type 'boolean) (defcustom mhc-ps-truncate-lines nil "*Truncate line." :group 'mhc :type 'boolean) (defcustom mhc-ps-left-margin 2 "*Left margin of the each schedule." :group 'mhc :type 'integer) (defcustom mhc-ps-string-width 20 "*Width of the each schedule." :group 'mhc :type 'integer) (defcustom mhc-ps-string-column 7 "*Column of the each schedule." :group 'mhc :type 'integer) (defcustom mhc-ps-title-font "Times-Bold" "*PostScript Font used for title." :group 'mhc :type 'string) (defcustom mhc-ps-day-font "Helvetica-Bold" "*PostScript Font used for days." :group 'mhc :type 'string) (defcustom mhc-ps-event-font "Times-Roman" "*PostScript Font used for events." :group 'mhc :type 'string) (defcustom mhc-ps-japanese-font "Ryumin-Light-EUC-H" "*PostScript Font used for Japanese characters." :group 'mhc :type 'string) (defcustom mhc-ps-coding-system (if (boundp 'MULE) '*euc-japan*unix 'euc-japan-unix) "*Coding system of PostScript data." :group 'mhc :type 'symbol) ;;; Internal Variables: (defconst mhc-ps/string "\ %! % PostScript program to draw calendar % Copyright \(C\) 1987 by Pipeline Associates, Inc. % Permission is granted to modify and distribute this free of charge. % The number after /month should be set to a number from 1 to 12. % The number after /year should be set to the year you want. % You can change the title and date fonts, if you want. % We figure out the rest. % This program won't produce valid calendars before 1800 due to the switch % from Julian to Gregorian calendars in September of 1752 wherever English % was spoken. %% For Japanese. Added by ichimal, 2000/2/6. %% Original code is generated by k2ps. /copyfont { % font-dic extra-entry-count copyfont font-dic 1 index maxlength add dict begin { 1 index /FID ne 2 index /UniqueID ne and {def}{pop pop} ifelse } forall currentdict end } bind def %% For Japanese. Added by ichimal, 2000/2/6. %% Original code is generated by k2ps. /narrowfont { % ASCIIFontName EUCFontName compositefont font' findfont dup /FontType get 0 eq { 12 dict begin % % 7+8 bit EUC font % 12 dict begin /EUCFont exch def /FontInfo \(7+8 bit EUC font\) readonly def /PaintType 0 def /FontType 0 def /FontMatrix matrix def % /FontName /Encoding \[ 16#00 1 16#20 { pop 0 } for 16#21 1 16#28 { 16#20 sub } for 16#29 1 16#2F { pop 0 } for 16#30 1 16#74 { 16#27 sub } for 16#75 1 16#FF { pop 0 } for \] def /FMapType 2 def EUCFont /WMode known { EUCFont /WMode get /WMode exch def } { /WMode 0 def } ifelse /FDepVector \[ EUCFont /FDepVector get 0 get \[ 16#21 1 16#28 {} for 16#30 1 16#74 {} for \] { 13 dict begin /EUCFont EUCFont def /UpperByte exch 16#80 add def % /FontName /FontInfo \(EUC lower byte font\) readonly def /PaintType 0 def /FontType 3 def /FontMatrix matrix def /FontBBox {0 0 0 0} def /Encoding \[ 16#00 1 16#A0 { pop /.notdef } for 16#A1 1 16#FE { 16#80 sub 16 2 string cvrs \(cXX\) dup 1 4 -1 roll putinterval cvn } for /.notdef \] def % /UniqueID % /WMode /BuildChar { gsave exch dup /EUCFont get setfont /UpperByte get 2 string dup 0 4 -1 roll put dup 1 4 -1 roll put dup stringwidth setcharwidth 0 0 moveto show grestore } bind def currentdict end /lowerbytefont exch definefont } forall \] def currentdict end /eucfont exch definefont exch findfont 1 copyfont dup begin /FontMatrix FontMatrix \[.83 0 0 1 0 0.05\] matrix concatmatrix def end /asciifont exch definefont exch /FDepVector \[ 4 2 roll \] def /FontType 0 def /WMode 0 def /FMapType 4 def /FontMatrix matrix def /Encoding \[0 1\] def /FontBBox {0 0 0 0} def currentdict end }{ pop findfont 0 copyfont } ifelse } def /month @MONTH@ def /year @YEAR@ def /titlefont /@TFONT@ def /dayfont /@DFONT@ def %% For Japanese. Changed by ichimal, 2000/2/6. %% Original code is generated by k2ps. %% /eventfont /@EFONT@ def /Courier-Ryumin /@EFONT@ /@JFONT@ narrowfont definefont pop /eventfont /Courier-Ryumin def /holidays \[ @HOLIDAYS@ \] def /lholidays \[ @LHOLIDAYS@ \] def /nholidays \[ @NHOLIDAYS@ \] def /schedules \[ @SCHEDULES@ \] def /lschedules \[ @LSCHEDULES@ \] def /nschedules \[ @NSCHEDULES@ \] def /Bannerstring \(@BANNER@\) def /Lfootstring \(@LFOOT@\) def /Rfootstring \(@RFOOT@\) def /Cfootstring \(@CFOOT@\) def % calendar names - change these if you don't speak english % \"August\", \"April\" and \"February\" could stand to be kerned even if you do /month_names \[ \(January\) \(February\) \(March\) \(April\) \(May\) \(June\) \(July\) \(August\) \(September\) \(October\) \(November\) \(December\) \] def /day_names \[ \(Sunday\) \(Monday\) \(Tuesday\) \(Wednesday\) \(Thursday\) \(Friday\) \(Saturday\) \] def % layout parameters - you can change these, but things may not look nice /daywidth 100 def /dayheight 95 def /titlefontsize 48 def /weekdayfontsize 10 def /datefontsize 24 def /footfontsize 20 def /topgridmarg 35 def /leftmarg 35 def /daytopmarg 14 def /dayleftmarg 5 def % layout constants - don't change these, things probably won't work /mainrows @WEEKS@ def /subrows 6 def % calendar constants - change these if you want a French revolutionary calendar /days_week 7 def /days_month \[ 31 28 31 30 31 30 31 31 30 31 30 31 \] def /isleap { % is this a leap year? year 4 mod 0 eq % multiple of 4 year 100 mod 0 ne % not century year 1000 mod 0 eq or and % unless it's a millenia } def /ndays { % number of days in this month days_month month 1 sub get month 2 eq % February isleap and { 1 add } if } def /weekday { % weekday \(range 0-6\) for integer date days_week mod } def /startday { % starting day-of-week for this month /off year 2032 sub def % offset from start of \"epoch\" off off 4 idiv add % number of leap years off 100 idiv sub % number of centuries off 1000 idiv add % number of millenia 4 add weekday days_week add % offset from Jan 1 2032 /off exch def 1 1 month 1 sub { /idx exch def days_month idx 1 sub get idx 2 eq isleap and { 1 add } if /off exch off add def } for off weekday % 0--Sunday, 1--monday, etc. } def /prtevent { % event-string day prtevent % print out an event /start startday def /day 2 1 roll def day start add 1 sub 7 mod daywidth mul day start add 1 sub 7 div truncate dayheight neg mul -5 numevents day start add get -10 mul add numevents day start add numevents day start add get 1 add put add 2 add moveto show } def /drawevents { % read in a file full of events; print % the events for this month /numevents \[0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0\] def eventfont findfont 9 scalefont setfont 0 2 holidays length 2 sub { % for the \"Holidays\" dup 1 add holidays 2 1 roll get 2 1 roll holidays 2 1 roll get prtevent } for 0 2 schedules length 2 sub { % for the \"Schedules\" dup 1 add schedules 2 1 roll get 2 1 roll schedules 2 1 roll get prtevent } for } def % ------------------------------------------------------------------------ /prtnum { 3 string cvs show } def /center { % center string in given width /width exch def /str exch def width str stringwidth pop sub 2 div 0 rmoveto str show } def /centernum { exch 3 string cvs exch center } def /drawgrid { % draw calendar boxes titlefont findfont weekdayfontsize scalefont setfont currentpoint /y0 exch def /x0 exch def 0 1 days_week 1 sub { submonth 0 eq { x0 y0 moveto dup dup daywidth mul 40 rmoveto day_names exch get daywidth center } if x0 y0 moveto daywidth mul topgridmarg rmoveto 1.0 setlinewidth submonth 0 eq { /rowsused mainrows 1 sub def } { /rowsused subrows 1 sub def } ifelse 0 1 rowsused { gsave daywidth 0 rlineto 0 dayheight neg rlineto daywidth neg 0 rlineto closepath stroke grestore 0 dayheight neg rmoveto } for } for } def /drawnums { % place day numbers on calendar dayfont findfont datefontsize submonth 0 ne { 2.5 mul } if scalefont setfont /start startday def /days ndays def start daywidth mul dayleftmarg add daytopmarg rmoveto submonth 0 ne { dayleftmarg neg dayheight -2 div rmoveto } if 1 1 days { /day exch def gsave day start add weekday 0 eq { submonth 0 eq { .7 setgray } { holidaymark } ifelse } if day start add weekday 1 eq { submonth 0 eq { .7 setgray } { holidaymark } ifelse } if %% Added by ichimal, 2000.2 submonth 0 eq { 0 2 holidays length 2 sub { holidays 2 1 roll get day eq { .7 setgray exit } if } for } { nsubmonth 0 eq { 0 1 lholidays length 1 sub { lholidays exch get day eq { holidaymark exit } if } for 0 1 lschedules length 1 sub { lschedules exch get day eq { shedulemark exit } if } for } { 0 1 nholidays length 1 sub { nholidays exch get day eq { holidaymark exit } if } for 0 1 nschedules length 1 sub { nschedules exch get day eq { shedulemark exit } if } for } ifelse } ifelse submonth 0 eq { day prtnum } { day daywidth centernum } ifelse grestore day start add weekday 0 eq { currentpoint exch pop dayheight sub 0 exch moveto submonth 0 eq { dayleftmarg 0 rmoveto } if } { daywidth 0 rmoveto } ifelse } for } def /holidaymark { % tiny holiday mark gsave 0 dayheight 2 div daytopmarg add 5 add rmoveto daywidth 0 rlineto 0 dayheight neg rlineto daywidth neg 0 rlineto .9 setgray closepath fill grestore } def /shedulemark { % tiny shedule mark gsave 80 60 rmoveto 10 0 rlineto 0 -10 rlineto -10 0 rlineto 0 10 rlineto closepath .0 setgray fill grestore } def /drawfill { % place fill squares on calendar /start startday def /days ndays def currentpoint /y0 exch def /x0 exch def submonth 0 eq { usefirst { /fillstart 2 def } { /fillstart 0 def } ifelse } { /fillstart 0 def } ifelse fillstart daywidth mul topgridmarg rmoveto 1.0 setlinewidth fillstart 1 start 1 sub { gsave .9 setgray daywidth 0 rlineto 0 dayheight neg rlineto daywidth neg 0 rlineto closepath fill grestore daywidth 0 rmoveto } for x0 y0 moveto submonth 0 ne { /lastday subrows days_week mul def days_week 1 sub daywidth mul -440 rmoveto } { /lastday mainrows days_week mul 2 sub fillstart add def days_week 3 sub fillstart add daywidth mul @FOFFSET@ dayheight add rmoveto } ifelse lastday -1 ndays start 1 add add { /day exch def gsave .9 setgray daywidth 0 rlineto 0 dayheight neg rlineto daywidth neg 0 rlineto closepath fill grestore day weekday 1 eq { submonth 0 ne { x0 y0 moveto days_week 1 sub daywidth mul -440 dayheight add rmoveto } { x0 y0 moveto days_week 1 sub daywidth mul @FOFFSET@ dayheight add rmoveto } ifelse } { daywidth neg 0 rmoveto } ifelse } for } def /usefirst { % are last two boxes used by days? start ndays add mainrows days_week mul 3 sub gt start 2 ge and mainrows 6 eq or } def /calendar { titlefont findfont titlefontsize scalefont setfont 0 60 moveto /month_name month_names month 1 sub get def month_name show /yearstring year 10 string cvs def daywidth days_week mul yearstring stringwidth pop sub 60 moveto yearstring show eventflag { % Show a centered Banner if any at the Top daywidth days_week mul 2 div Bannerstring stringwidth pop 2 div sub 60 moveto Bannerstring show % Show footnotes left-center-right eventfont findfont footfontsize scalefont setfont /bottomrow { dayheight mainrows mul 5 sub neg } def 0 bottomrow moveto Lfootstring show daywidth days_week mul Rfootstring stringwidth pop sub bottomrow moveto Rfootstring show daywidth days_week mul Cfootstring stringwidth pop sub 2 div bottomrow moveto Cfootstring show } if 0 -5 moveto drawnums 0 -5 moveto drawfill eventflag { 0 0 moveto drawevents } if 0 -5 moveto drawgrid } def /eventflag true def @SCALE@ scale @ROTATE@ rotate @TRANSLATE@ translate /submonth 0 def calendar /eventflag false def month 1 sub 0 eq { /lmonth 12 def /lyear year 1 sub def } { /lmonth month 1 sub def /lyear year def } ifelse month 1 add 13 eq { /nmonth 1 def /nyear year 1 add def } { /nmonth month 1 add def /nyear year def } ifelse usefirst { 0 30 translate } { days_week 2 sub daywidth mul -350 translate } ifelse /submonth 1 def /nsubmonth 0 def /year lyear def /month lmonth def gsave .138 .138 scale 12 -120 translate calendar grestore /submonth 1 def /nsubmonth 1 def /year nyear def /month nmonth def daywidth 0 translate gsave .138 .138 scale 12 -120 translate calendar grestore showpage ") (defconst mhc-ps/replace-table '(("@MONTH@" . (format "%d" month)) ("@YEAR@" . (format "%d" year)) ("@TFONT@" . mhc-ps-title-font) ("@DFONT@" . mhc-ps-day-font) ("@EFONT@" . mhc-ps-event-font) ("@JFONT@" . mhc-ps-japanese-font) ("@HOLIDAYS@" . holidays-buffer) ("@SCHEDULES@" . schedules-buffer) ("@LHOLIDAYS@" . last-holidays-buffer) ("@LSCHEDULES@" . last-schedules-buffer) ("@NHOLIDAYS@" . next-holidays-buffer) ("@NSCHEDULES@" . next-schedules-buffer) ("@WEEKS@" . (number-to-string weeks)) ("@FOFFSET@" . (if (eq weeks 6) "-535" "-440")) ("@BANNER@" . (user-login-name)) ("@LFOOT@" . "") ("@RFOOT@" . "") ("@CFOOT@" . "") ("@SCALE@" . (cond ((and mhc-ps-paper-type (or (not mhc-ps-paper-fill-print) (eq weeks 6))) "0.85 0.85") (mhc-ps-paper-type "1.0 1.0") (t "0.75 0.75"))) ("@ROTATE@" . (if mhc-ps-paper-type "90" "0")) ("@TRANSLATE@" . (cond ((and mhc-ps-paper-type (or (not mhc-ps-paper-fill-print) (eq weeks 6))) "140 -120") (mhc-ps-paper-type "50 -120") (t "50 900"))))) (defun mhc-ps/weeks (date) (if (> (+ (mhc-date-dd (mhc-date-mm-last date)) (mhc-date-ww (mhc-date-mm-first date))) 35) 6 5)) (defun mhc-ps/substring (str width) (let ((clist (mhc-string-to-char-list str)) cw (i 0) (w 0) (ow 0) (spc ?\ )) (catch 'loop (while clist (setq w (+ w (char-width (car clist)))) (if (> w width) (throw 'loop nil)) (setq i (+ i (length (char-to-string (car clist))))) (setq clist (cdr clist)))) (substring str 0 i))) (defun mhc-ps/compose-subject (time subject margin) (let ((mstr (make-string margin ?\ )) pos str) ;; Delete characters to emphasize subject. (and (string-match "^\\*+[ \t\r\f\n]*" subject) (setq pos (match-end 0)) (string-match "[ \t\r\f\n]*\\*+$" subject) (setq subject (substring subject pos (match-beginning 0)))) (if time (setq str (concat time " " subject)) (setq str subject)) (cond ((<= (string-width str) mhc-ps-string-width) (list str)) (mhc-ps-truncate-lines (if (null time) (list (if (= (string-width (setq subject (mhc-ps/substring subject mhc-ps-string-width))) mhc-ps-string-width) (concat subject "$") subject)) (setq subject (concat mstr subject)) (if (= (string-width (setq subject (mhc-ps/substring subject mhc-ps-string-width))) mhc-ps-string-width) (setq subject (concat subject "$"))) (list time subject))) (t (with-temp-buffer (let ((fill-column mhc-ps-string-width) (left-margin 0) ret) (insert str) (fill-region (point-min) (point-max)) (goto-char (point-min)) (if (= (forward-line 1) 0) (let ((fill-column (- mhc-ps-string-width margin))) (fill-region (point) (point-max)))) (delete-region (goto-char (point-max)) (progn (skip-chars-backward " \t\n") (point))) (goto-char (point-min)) (setq ret (list (buffer-substring (point) (progn (end-of-line) (point))))) (forward-line 1) (while (not (eobp)) (setq ret (cons (concat mstr (buffer-substring (point) (progn (end-of-line) (point)))) ret)) (forward-line 1)) (nreverse ret))))))) (defun mhc-ps/encode-string (string) (let ((start 0) buf ch) (while (string-match "[()\\\\]" string start) (setq ch (aref string (match-beginning 0)) buf (cons (if (eq ch ?\() "\\(" (if (eq ch ?\)) "\\)" "\\\\")) (cons (substring string start (match-beginning 0)) buf)) start (match-end 0))) (eval (cons 'concat (nreverse (cons (substring string start) buf)))))) (defun mhc-ps/schedule-to-string (dayinfo schedule) (let ((begin (mhc-schedule-time-begin schedule)) (end (mhc-schedule-time-end schedule)) (day (mhc-day-day-of-month dayinfo))) (if (or begin end) (mapconcat (lambda (str) (format "%d ( %s)" day (mhc-ps/encode-string str))) (mhc-ps/compose-subject (concat (if begin (mhc-time-to-string begin) "") (if end (concat "-" (mhc-time-to-string end)) "")) (mhc-schedule-subject-as-string schedule) mhc-ps-left-margin) " ") (mapconcat (lambda (str) (format "%d ( %s)" day (mhc-ps/encode-string str))) (mhc-ps/compose-subject nil (mhc-schedule-subject-as-string schedule) mhc-ps-left-margin) " ")))) (defun mhc-ps/uniq-list (lst) (let ((tmp lst)) (while tmp (setq tmp (setcdr tmp (delete (car tmp) (cdr tmp)))))) lst) (defun mhc-ps/make-contents (file year month &optional category-predicate) (let ((weeks (mhc-ps/weeks (mhc-date-new year month 1))) (last-yymm (mhc-date-mm-- (mhc-date-new year month 1))) (next-yymm (mhc-date-mm++ (mhc-date-new year month 1))) schedules-buffer holidays-buffer last-schedules-buffer last-holidays-buffer next-schedules-buffer next-holidays-buffer) ;; this month (let ((dayinfo-list (mhc-db-scan-month year month))) (while dayinfo-list (let ((schedules (mhc-day-schedules (car dayinfo-list)))) (while schedules (when (funcall category-predicate (car schedules)) (if (mhc-schedule-in-category-p (car schedules) "holiday") (setq holidays-buffer (cons (mhc-ps/schedule-to-string (car dayinfo-list) (car schedules)) holidays-buffer)) (setq schedules-buffer (cons (mhc-ps/schedule-to-string (car dayinfo-list) (car schedules)) schedules-buffer)))) (setq schedules (cdr schedules)))) (setq dayinfo-list (cdr dayinfo-list)))) ;; last month (let ((dayinfo-list (mhc-date-let last-yymm (mhc-db-scan-month yy mm)))) (while dayinfo-list (let ((schedules (mhc-day-schedules (car dayinfo-list)))) (while schedules (when (funcall category-predicate (car schedules)) (if (mhc-schedule-in-category-p (car schedules) "holiday") (setq last-holidays-buffer (cons (number-to-string (mhc-day-day-of-month (car dayinfo-list))) last-holidays-buffer)) (setq last-schedules-buffer (cons (number-to-string(mhc-day-day-of-month (car dayinfo-list))) last-schedules-buffer)))) (setq schedules (cdr schedules)))) (setq dayinfo-list (cdr dayinfo-list)))) ;; next month (let ((dayinfo-list (mhc-date-let next-yymm (mhc-db-scan-month yy mm)))) (while dayinfo-list (let ((schedules (mhc-day-schedules (car dayinfo-list)))) (while schedules (when (funcall category-predicate (car schedules)) (if (mhc-schedule-in-category-p (car schedules) "holiday") (setq next-holidays-buffer (cons (number-to-string (mhc-day-day-of-month (car dayinfo-list))) next-holidays-buffer)) (setq next-schedules-buffer (cons (number-to-string (mhc-day-day-of-month (car dayinfo-list))) next-schedules-buffer)))) (setq schedules (cdr schedules)))) (setq dayinfo-list (cdr dayinfo-list)))) (setq last-schedules-buffer (mhc-ps/uniq-list last-schedules-buffer) last-holidays-buffer (mhc-ps/uniq-list last-holidays-buffer) next-schedules-buffer (mhc-ps/uniq-list next-schedules-buffer) next-holidays-buffer (mhc-ps/uniq-list next-holidays-buffer)) (setq schedules-buffer (mapconcat 'identity (nreverse schedules-buffer) " ") holidays-buffer (mapconcat 'identity (nreverse holidays-buffer) " ") last-schedules-buffer (mapconcat 'identity (nreverse last-schedules-buffer) " ") last-holidays-buffer (mapconcat 'identity (nreverse last-holidays-buffer) " ") next-schedules-buffer (mapconcat 'identity (nreverse next-schedules-buffer) " ") next-holidays-buffer (mapconcat 'identity (nreverse next-holidays-buffer) " ")) (with-temp-buffer (insert mhc-ps/string) (let ((case-fold-search nil) (alist mhc-ps/replace-table) key value) (while alist (setq key (car (car alist)) value (eval (cdr (car alist))) alist (cdr alist)) (goto-char (point-min)) (while (search-forward key nil t) (delete-region (- (point) (length key)) (point)) (insert value)))) (and file (mhc-write-region-as-coding-system mhc-ps-coding-system (point-min) (point-max) (expand-file-name file) nil 'nomsg)) (buffer-substring (point-min) (point-max))))) (defvar mhc-ps/process-file-alist '()) (defun mhc-ps/process (command arguments file buffer year month category-predicate) (mhc-setup) (message "PostScript creating...") (let ((contents (mhc-ps/make-contents file year month category-predicate))) (if (null contents) (message "No PostScript create.") (cond ((stringp command) (let ((process (apply (function start-process) (format "mhc-ps-%s" command) (mhc-get-buffer-create (format " *mhc-ps-%s*" command)) command (append arguments (list (expand-file-name file)))))) (set-process-coding-system process mhc-ps-coding-system mhc-ps-coding-system) (set-process-sentinel process 'mhc-ps/process-sentinel) (setq mhc-ps/process-file-alist (cons (cons process (expand-file-name file)) mhc-ps/process-file-alist)) (message "PostScript creating...done"))) ((eq command 'save) (message "PostScript saving (%s)...done" file)) ((eq command 'buffer) (pop-to-buffer (get-buffer-create buffer)) (kill-new contents) (let ((msg "Insert PostScript data ? (y or n) ") (char nil)) (message msg) (while (null char) (setq char (read-char-exclusive)) (if (or (eq ?y char) (eq ?\ char) (eq ?n char) (eq ?\177 char)) () (setq char nil) (message (concat "Please answer y or n. " msg)))) (if (or (eq ?y char) (eq ?\ char)) (save-excursion (insert contents) (message "PostScript insert to \"%s\"." buffer)) (message "PostScript data to the latest kill in the kill ring.")))))))) (defun mhc-ps/process-sentinel (process event) (let ((al (assoc process mhc-ps/process-file-alist))) (and (cdr al) (file-writable-p (cdr al)) (delete-file (cdr al))) (setq mhc-ps/process-file-alist (delete al mhc-ps/process-file-alist)))) ;;;###autoload (defun mhc-ps (&optional arg) "*Create PostScript calendar with selected method." (interactive "P") (let ((method 'preview) (date (or (mhc-current-date-month) (mhc-calendar-get-date))) year month char) (if (or arg (null date)) (setq date (mhc-input-month "Month: " date))) (setq year (mhc-date-yy date)) (setq month (mhc-date-mm date)) (message "pre(V)iew (default), (P)rint, (S)ave, (I)nsert buffer") (condition-case nil (setq char (read-char)) (error (setq char ?v))) (cond ((memq char '(?p ?P)) (mhc-ps-print year month mhc-default-category-predicate-sexp)) ((memq char '(?s ?S)) (mhc-ps-save year month (expand-file-name (mhc-date-format date "mhc%04d%02d.ps" yy mm) (mhc-summary-folder-to-path mhc-base-folder)) mhc-default-category-predicate-sexp)) ((memq char '(?i ?I)) (mhc-ps-insert-buffer year month (read-buffer "Insert buffer: " "*mhc-postscript*") mhc-default-category-predicate-sexp)) (t (mhc-ps-preview year month mhc-default-category-predicate-sexp))))) ;;;###autoload (defun mhc-ps-preview (year month &optional category-predicate) "*Preview PostScript calendar." (interactive (let* ((cdate (or (mhc-current-date-month) (mhc-calendar-get-date))) (date (mhc-input-month "Month: " cdate))) (list (mhc-date-yy date) (mhc-date-mm date) mhc-default-category-predicate-sexp))) (mhc-ps/process mhc-ps-preview-command mhc-ps-preview-command-arguments (expand-file-name (format "mhc%04d%02d.ps" year month) (mhc-summary-folder-to-path mhc-base-folder)) nil year month category-predicate)) ;;;###autoload (defun mhc-ps-print (year month &optional category-predicate) "*Print PostScript calendar." (interactive (let* ((cdate (or (mhc-current-date-month) (mhc-calendar-get-date))) (date (mhc-input-month "Month: " cdate))) (list (mhc-date-yy date) (mhc-date-mm date) mhc-default-category-predicate-sexp))) (mhc-ps/process mhc-ps-print-command mhc-ps-print-command-arguments (expand-file-name (format "mhc%04d%02d.ps" year month) (mhc-summary-folder-to-path mhc-base-folder)) nil year month category-predicate)) ;;;###autoload (defun mhc-ps-save (year month file &optional category-predicate) "*Save PostScript calendar." (interactive (let* ((cdate (or (mhc-current-date-month) (mhc-calendar-get-date))) (date (mhc-input-month "Month: " cdate)) (default (expand-file-name (mhc-date-format date "mhc%04d%02d.ps" yy mm) (mhc-summary-folder-to-path mhc-base-folder))) (file (read-file-name "Save file: " default default))) (list (mhc-date-yy date) (mhc-date-mm date) file mhc-default-category-predicate-sexp))) (mhc-ps/process 'save nil file nil year month category-predicate)) ;;;###autoload (defun mhc-ps-insert-buffer (year month buffer &optional category-predicate) "*Insert PostScript calendar." (interactive (let* ((cdate (or (mhc-current-date-month) (mhc-calendar-get-date))) (date (mhc-input-month "Month: " cdate)) (buffer (read-buffer "Insert buffer: " "*mhc-postscript*"))) (list (mhc-date-yy date) (mhc-date-mm date) buffer mhc-default-category-predicate-sexp))) (mhc-ps/process 'buffer nil nil buffer year month category-predicate)) (provide 'mhc-ps) ;;; Copyright Notice of the PostScript programs. ;; Copyright (C) 1987 by Pipeline Associates, Inc. ;; Copyright (C) 2000 by SUZUKI Shingo . ;; Permission is granted to modify and distribute this free of charge. ;;; Copyright Notice of the Emacs Lisp programs. ;; Copyright (C) 2000 MHC developing team. All rights reserved. ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of the team nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' ;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ;; THE TEAM OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, ;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED ;; OF THE POSSIBILITY OF SUCH DAMAGE. ;;; mhc-ps.el ends here. yoshinari-nomura-mhc-815a36a/emacs/mhc-record.el000066400000000000000000000157601222073515200215620ustar00rootroot00000000000000;;; -*- mode: Emacs-Lisp; coding: utf-8 -*- ;; Author: Yoshinari Nomura , ;; TSUCHIYA Masatoshi ;; Created: 2000/05/15 ;; Revised: $Date$ ;;; Commentary: ;; This file is a part of MHC, and includes functions manipulate ;; MHC-RECORD structure. ;;; About MHC-RECORD structure: ;; Each MHC-RECORD structure is a cons cell has a construction as ;; follows: ;; ;; MHC-RECORD ::= ( KEY . VALUE ) ;; KEY ::= string ( represents file name of record ) ;; VALUE ::= [ ID SCHEDULES SEXP ] ;; ID ::= string ( represents unique id of recort ) ;; SCHEDULES ::= MHC-SCHEDULE* ;; SEXP ::= S expression to get schedule. ;;; Code: (require 'mhc-summary) (require 'mhc-file) (require 'mhc-draft) ;; Global Variable: (defcustom mhc-record-log-file (expand-file-name ".mhc-db-log" (mhc-summary-folder-to-path mhc-base-folder)) "*スケジュールファイルの操作履歴ログ" :group 'mhc :type 'file) ;; Internal Variable: (defvar mhc-record/id-counter 0) ;; Functions: (defun mhc-record-create-id () "Return unique ID string." (let ((uid (user-login-name)) (time (format-time-string "%Y%m%d%H%M%S" (current-time))) (sequence (format "%04d" mhc-record/id-counter)) (host (system-name))) (setq mhc-record/id-counter (1+ mhc-record/id-counter)) (concat "<" time sequence "." uid "@" host ">"))) (defun mhc-record-new (name &optional id schedules sexp) "Constructer of MHC-RECORD structure." (cons name (vector (or id (mhc-record-create-id)) schedules sexp))) (defmacro mhc-record/key (record) `(car ,record)) (defmacro mhc-record/value (record) `(cdr ,record)) (defmacro mhc-record-name (record) `(mhc-record/key ,record)) (defmacro mhc-record-id (record) `(aref (mhc-record/value ,record) 0)) (defmacro mhc-record-schedules (record) `(aref (mhc-record/value ,record) 1)) (defmacro mhc-record-sexp (record) `(aref (mhc-record/value ,record) 2)) (defmacro mhc-record-set-name (record name) `(setcar ,record ,name)) (defmacro mhc-record-set-id (record id) `(aset (mhc-record/value ,record) 0 ,id)) (defmacro mhc-record-set-schedules (record schedules) `(aset (mhc-record/value ,record) 1 ,schedules)) (defmacro mhc-record-set-sexp (record sexp) `(aset (mhc-record/value ,record) 2 ,sexp)) (defun mhc-record-copy (record) (cons (copy-sequence (mhc-record/key record)) (copy-sequence (mhc-record/value record)))) (defun mhc-record-subject (record) (catch 'found (let ((schedules (mhc-record-schedules record))) (while schedules (if (mhc-schedule-subject (car schedules)) (throw 'found (mhc-schedule-subject (car schedules)))) (setq schedules (cdr schedules)))))) (defun mhc-record-subject-as-string (record) (or (mhc-record-subject record) "(none)")) (defun mhc-record-occur-multiple-p (record) "Return t if RECORD occurs multiple times." (let ((schedules (mhc-record-schedules record))) (or (> (length schedules) 1) (mhc-logic-occur-multiple-p (mhc-schedule-condition (car schedules)))))) (defun mhc-record-write-buffer (record buffer &optional old-record) "Write BUFFER to RECORD." (let ((modify (file-exists-p (mhc-record-name record)))) (save-excursion (set-buffer buffer) (mhc-draft-translate) (mhc-write-region-as-coding-system mhc-default-coding-system (point-min) (point-max) (mhc-record-name record) nil 'nomsg) (set-buffer-modified-p nil) (if modify (prog1 (mhc-file-modify (mhc-record-name record)) (mhc-record/append-log record 'modify)) (if old-record (prog2 (mhc-file-remove (mhc-record-name old-record)) (mhc-file-add (mhc-record-name record)) (mhc-record/append-log record 'modify)) (prog1 (mhc-file-add (mhc-record-name record)) (mhc-record/append-log record 'add))))))) (defun mhc-record-delete (record) (prog1 (mhc-file-remove (mhc-record-name record)) (mhc-record/append-log record 'delete))) (defun mhc-record/append-log (record status) (if mhc-record-log-file (let ((tmp-buffer (mhc-get-buffer-create " *mhc-record-append-log*"))) (save-excursion (set-buffer tmp-buffer) (delete-region (point-min) (point-max)) (insert (format "%c %s %s %s %s\n" (cond ((eq status 'add) ?A) ((eq status 'delete) ?D) ((eq status 'modify) ?M) (t ??)) (format-time-string "%Y-%m-%d %T") (mhc-record-id record) (mhc-record-name record) (mhc-record-subject-as-string record))) (mhc-write-region-as-coding-system mhc-default-coding-system (point-min) (point-max) mhc-record-log-file 'append 'nomsg))))) (provide 'mhc-record) ;;; Copyright Notice: ;; Copyright (C) 1999, 2000 Yoshinari Nomura. All rights reserved. ;; Copyright (C) 2000 MHC developing team. All rights reserved. ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of the team nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' ;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ;; THE TEAM OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, ;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED ;; OF THE POSSIBILITY OF SUCH DAMAGE. ;;; mhc-record.el ends here. yoshinari-nomura-mhc-815a36a/emacs/mhc-schedule.el000066400000000000000000000200651222073515200220720ustar00rootroot00000000000000;;; -*- mode: Emacs-Lisp; coding: utf-8 -*- ;; Author: Yoshinari Nomura , ;; TSUCHIYA Masatoshi ;; Created: 1997/10/12 ;; Revised: $Date: 2004/05/06 16:35:12 $ ;;; Commentary: ;; This file is a part of MHC, and includes functions to manipulate ;; MHC-SCHEDULE structure. ;; About MHC-SCHEDULE structure: ;; Each MHC-SCHEDULE structure is a vector has a construction as ;; follows: ;; ;; MHC-SCHEDULE ::= [ RECORD CONDITION SUBJECT LOCATION TIME ALARM CATEGORIES PRIORITY REGION ] ;; RECORD ::= MHC-RECORD ;; CONDITION ::= MHC-LOGIC ;; SUBJECT ::= string ( represents subject of schedule ) ;; LOCATION ::= string ( represents location of schedule ) ;; TIME ::= integer ( represents minutes of day from midnight ) ;; ALARM ::= string ;; CATEGORIES ::= CATEGORY* ;; CATEGORY ::= string ( represents category of schedule ) ;; PRIORITY ::= integer ;; REGION ::= ( START . END ) ;; START ::= integer ( represents start point of headers of schedule ) ;; END ::= integer ( represents end point of headers of schedule ) ;;; Codes: (defun mhc-schedule-new (record &optional condition subject location time alarm categories priority region recurrence-tag) "Constructor of MHC-SCHEDULE structure." (let ((new (vector record (or condition (mhc-logic-new)) subject location time alarm categories priority (or region (cons nil nil)) recurrence-tag))) (mhc-record-set-schedules record (cons new (mhc-record-schedules record))) new)) (defsubst mhc-schedule-record (schedule) (if schedule (aref schedule 0))) (defsubst mhc-schedule-condition (schedule) (if schedule (aref schedule 1))) (defsubst mhc-schedule-subject (schedule) (if schedule (aref schedule 2))) (defsubst mhc-schedule-location (schedule) (if schedule (aref schedule 3))) (defsubst mhc-schedule-time (schedule) (if schedule (aref schedule 4))) (defsubst mhc-schedule-alarm (schedule) (if schedule (aref schedule 5))) (defsubst mhc-schedule-categories (schedule) (if schedule (aref schedule 6))) (defsubst mhc-schedule-priority (schedule) (if schedule (aref schedule 7))) (defsubst mhc-schedule-region (schedule) (if schedule (aref schedule 8))) (defsubst mhc-schedule-recurrence-tag (schedule) (if schedule (aref schedule 9))) (defmacro mhc-schedule-time-begin (schedule) `(car (mhc-schedule-time ,schedule))) (defmacro mhc-schedule-time-end (schedule) `(cdr (mhc-schedule-time ,schedule))) (defmacro mhc-schedule-region-start (schedule) `(car (mhc-schedule-region ,schedule))) (defmacro mhc-schedule-region-end (schedule) `(cdr (mhc-schedule-region ,schedule))) ;; Need to be deleted. (defsubst mhc-schedule-todo-lank (schedule) (if schedule (mhc-logic-todo (mhc-schedule-condition schedule)))) (defsubst mhc-schedule-todo-deadline (schedule) (and schedule (or (car (mhc-logic/day (mhc-schedule-condition schedule))) (nth 2 (assq 'mhc-logic/condition-duration (mhc-logic/and (mhc-schedule-condition schedule)))) (cadr (assq 'mhc-logic/condition-duration-end (mhc-logic/and (mhc-schedule-condition schedule))))))) (defmacro mhc-schedule/set-subject (schedule subject) `(aset ,schedule 2 ,subject)) (defmacro mhc-schedule/set-location (schedule location) `(aset ,schedule 3 ,location)) (defmacro mhc-schedule/set-time (schedule begin end) `(aset ,schedule 4 (cons ,begin ,end))) (defmacro mhc-schedule/set-alarm (schedule alarm) `(aset ,schedule 5 ,alarm)) (defmacro mhc-schedule/set-categories (schedule categories) `(aset ,schedule 6 ,categories)) (defmacro mhc-schedule/set-priority (schedule priority) `(aset ,schedule 7 ,priority)) (defmacro mhc-schedule/set-region-start (schedule start) `(setcar (aref ,schedule 8) ,start)) (defmacro mhc-schedule/set-region-end (schedule end) `(setcdr (aref ,schedule 8) ,end)) (defmacro mhc-schedule/set-recurrence-tag (schedule tag) `(aset ,schedule 9 ,tag)) (defun mhc-schedule-append-default (schedule default) (or (mhc-schedule-subject schedule) (mhc-schedule/set-subject schedule (mhc-schedule-subject default))) (or (mhc-schedule-location schedule) (mhc-schedule/set-location schedule (mhc-schedule-location default))) (or (mhc-schedule-time schedule) (not (mhc-schedule-time default)) (mhc-schedule/set-time schedule (mhc-schedule-time-begin default) (mhc-schedule-time-end default))) (or (mhc-schedule-alarm schedule) (mhc-schedule/set-alarm schedule (mhc-schedule-alarm default))) (or (mhc-schedule-categories schedule) (mhc-schedule/set-categories schedule (mhc-schedule-categories default))) (or (mhc-schedule-recurrence-tag schedule) (mhc-schedule/set-recurrence-tag schedule (mhc-schedule-recurrence-tag default)))) (defsubst mhc-schedule/time-to-string (minutes) (format "%02d:%02d" (/ minutes 60) (% minutes 60))) (defun mhc-schedule-time-as-string (schedule) (let ((time (mhc-schedule-time schedule))) (cond ((and (car time) (cdr time)) (concat (mhc-schedule/time-to-string (car time)) "-" (mhc-schedule/time-to-string (cdr time)))) ((car time) (mhc-schedule/time-to-string (car time))) ((cdr time) (concat "-" (mhc-schedule/time-to-string (cdr time)))) (t "")))) (defun mhc-schedule-subject-as-string (schedule) (or (mhc-schedule-subject schedule) "(none)")) (defun mhc-schedule-categories-as-string (schedule) (let ((categories (mhc-schedule-categories schedule))) (if categories (mapconcat (function identity) categories " ") ""))) (defun mhc-schedule-in-category-p (schedule category) (and schedule (if (listp category) (catch 'found (while category (if (member (downcase (car category)) (mhc-schedule-categories schedule)) (throw 'found t)) (setq category (cdr category)))) (member (downcase category) (mhc-schedule-categories schedule))))) (defun mhc-schedule-recurrence-tag-as-string (schedule) (or (mhc-schedule-recurrence-tag schedule) "")) (provide 'mhc-schedule) ;;; Copyright Notice: ;; Copyright (C) 1999, 2000 Yoshinari Nomura. All rights reserved. ;; Copyright (C) 2000 MHC developing team. All rights reserved. ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of the team nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' ;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ;; THE TEAM OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, ;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED ;; OF THE POSSIBILITY OF SUCH DAMAGE. ;;; mhc-schedule.el ends here. yoshinari-nomura-mhc-815a36a/emacs/mhc-slot.el000066400000000000000000000224371222073515200212640ustar00rootroot00000000000000;;; -*- mode: Emacs-Lisp; coding: utf-8 -*- ;; Author: Yoshinari Nomura , ;; TSUCHIYA Masatoshi ;; Created: 2000/04/30 ;; Revised: $Date$ ;;; Commentary: ;; This is a part of MHC. This file includes functions to manipulate ;; cache of schedule files. ;;; About MHC-SLOT structure. ;; Each MHC-SLOT structure is a cons cell has a construction as ;; follows: ;; ;; MHC-SLOT ::= ( KEY . VALUE ) ;; KEY ::= ( YEAR . MONTH ) ;; YEAR ::= integer ;; MONTH ::= integer ;; VALUE ::= [ MTIME RECORDS ] ;; MTIME ::= integer ;; RECORDS ::= MHC-RECORD* ;;; Code: (require 'mhc-parse) (require 'mhc-vars) ;; Internal Variables: (defvar mhc-slot/cache nil) ;; Function and macros to manipulate MHC-SLOT structure: (defun mhc-slot/new (slotkey &optional mtime records) (cons slotkey (vector mtime records))) (defmacro mhc-slot/key (slotinfo) `(car ,slotinfo)) (defmacro mhc-slot/value (slotinfo) `(cdr ,slotinfo)) (defmacro mhc-slot-mtime (slotinfo) `(aref (mhc-slot/value ,slotinfo) 0)) (defmacro mhc-slot-records (slotinfo) `(aref (mhc-slot/value ,slotinfo) 1)) (defmacro mhc-slot/set-mtime (slotinfo mtime) `(aset (mhc-slot/value ,slotinfo) 0 ,mtime)) (defmacro mhc-slot/set-records (slotinfo records) `(aset (mhc-slot/value ,slotinfo) 1 ,records)) ;; Functions to manipulate cache: (defun mhc-slot-clear-cache () "*Clear all cache." (interactive) (setq mhc-slot/cache nil)) (defun mhc-slot/cache-live-p (slotinfo) (let* ((mtime (mhc-misc-get-mtime (mhc-slot-key-to-directory (mhc-slot/key slotinfo)))) (cache (mhc-slot-mtime slotinfo)) (mtime-ms (car mtime)) (mtime-ls (car (cdr mtime))) (cache-ms (car cache)) (cache-ls (car (cdr cache)))) (cond ((null mtime) t) ; directory doesn't exist yet. ((null cache) nil) ((< cache-ms mtime-ms) nil) ((= cache-ms mtime-ms) (if (>= cache-ls mtime-ls) t ; t if same. nil)) (t t)))) (defsubst mhc-slot/check-cache (key) (cond ;; Access cache without checking mtime. ((eq mhc-use-cache 0) (assoc key mhc-slot/cache)) ;; Access cache with checking mtime. (mhc-use-cache (let ((slotinfo (assoc key mhc-slot/cache))) (if slotinfo (if (mhc-slot/cache-live-p slotinfo) slotinfo (setq mhc-slot/cache (delq slotinfo mhc-slot/cache)) nil)))))) (defsubst mhc-slot/set-current-mtime (slotinfo) (or (eq mhc-use-cache 0) (mhc-slot/set-mtime slotinfo (mhc-misc-get-mtime (mhc-slot-key-to-directory (mhc-slot/key slotinfo)))))) (defsubst mhc-slot/store-cache (slotinfo) (if mhc-use-cache (progn (mhc-slot/set-current-mtime slotinfo) (setq mhc-slot/cache (cons slotinfo (let ((x (assoc (mhc-slot/key slotinfo) mhc-slot/cache))) (if x (delq x mhc-slot/cache) mhc-slot/cache)))))) slotinfo) (defun mhc-slot-destruct-cache (directory) "Destruct cache of schedule files on DIRECTORY." (let ((cache (assoc (mhc-slot-directory-to-key directory) mhc-slot/cache))) (setq mhc-slot/cache (delq cache mhc-slot/cache)))) (defun mhc-slot-update-cache (key operation record) (cond ((eq operation 'add) (mhc-slot/add-file key record)) ((eq operation 'remove) (mhc-slot/remove-file key record)) (t (error "Internal ERROR: not defined operation(%s)." operation)))) (defun mhc-slot/add-file (key record) (let (slot x) (if (setq slot (mhc-slot/check-cache key)) (progn (mhc-slot/set-records slot (cons record (if (setq x (assoc (mhc-record-name record) (mhc-slot-records slot))) (delq x (mhc-slot-records slot)) (mhc-slot-records slot)))) (mhc-slot/set-current-mtime slot))))) (defun mhc-slot/remove-file (key record) (let (slot x) (if (setq slot (mhc-slot/check-cache key)) (progn (mhc-slot/set-records slot (if (setq x (assoc (mhc-record-name record) (mhc-slot-records slot))) (delq x (mhc-slot-records slot)) (message "Internal Warning: there is no information about specified file in cache.") (mhc-slot-records slot))) (mhc-slot/set-current-mtime slot))))) ;; Functions to manipulate slot key: (defsubst mhc-slot-key-to-directory (key) "\ 指定された KEY ::= (YEAR . MONTH) に対応する適当なディレクトリを返す ただし (nil . nil) が指定された場合は intersect/ を返す" (file-name-as-directory (expand-file-name (if (equal key '(nil . nil)) "intersect" (format "%04d/%02d" (car key) (cdr key))) (mhc-summary-folder-to-path mhc-base-folder)))) (defsubst mhc-slot-directory-to-key (directory) "mhc-slot-month-to-directory の逆関数" (setq directory (expand-file-name directory)) (let ((base (regexp-quote (mhc-summary-folder-to-path mhc-base-folder)))) (cond ((string-match (concat "^" base "/intersect/?$") directory) (cons nil nil)) ((string-match (concat "^" base "/\\([0-9][0-9][0-9][0-9]\\)/\\(0[1-9]\\|1[012]\\)/?$") directory) (cons (string-to-number (match-string 1 directory)) (string-to-number (match-string 2 directory)))) (t (error "Illegal argument: directory=%s" directory))))) ;; Interface functions: (defun mhc-slot-get-month-schedule (key) (or (mhc-slot/check-cache key) (let* ((slotinfo (mhc-slot/new key)) (directory (mhc-slot-key-to-directory key)) (entries (if (file-directory-p directory) (directory-files directory nil nil t))) records filename) (while entries (and (not (string-match "[^0-9]" (car entries))) (file-regular-p (setq filename (expand-file-name (car entries) directory))) (setq records (cons (mhc-parse-file filename) records))) (setq entries (cdr entries))) (mhc-slot/set-records slotinfo records) (mhc-slot/store-cache slotinfo)))) (defun mhc-slot-get-constant-schedule () (let ((mhc-use-cache 0)) (or (mhc-slot/check-cache (cons nil 'constant-schedule)) (if (file-readable-p mhc-schedule-file) (let ((slotinfo (mhc-slot/new (cons nil 'constant-schedule))) records) (save-excursion (set-buffer (mhc-get-buffer-create " *mhc-parse-file*")) (delete-region (point-min) (point-max)) (mhc-insert-file-contents-as-coding-system mhc-default-coding-system (expand-file-name mhc-schedule-file)) (goto-char (point-min)) (while (not (eobp)) (if (eq (following-char) ?#) (delete-region (point) (progn (forward-line 1) (point))) (forward-line 1))) (goto-char (point-min)) (while (progn (skip-chars-forward " \t\n") (not (eobp))) (delete-region (point-min) (point)) (mhc-header-narrowing (setq records (cons (mhc-parse-buffer) records)) (delete-region (point-min) (point-max))))) (mhc-slot/set-records slotinfo (nreverse records)) (mhc-slot/store-cache slotinfo)))))) (defun mhc-slot-get-intersect-schedule () (mhc-slot-get-month-schedule '(nil . nil))) (provide 'mhc-slot) ;;; Copyright Notice: ;; Copyright (C) 1999, 2000 Yoshinari Nomura. All rights reserved. ;; Copyright (C) 2000 MHC developing team. All rights reserved. ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of the team nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' ;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ;; THE TEAM OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, ;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED ;; OF THE POSSIBILITY OF SUCH DAMAGE. ;;; mhc-slot.el ends here. yoshinari-nomura-mhc-815a36a/emacs/mhc-summary.el000066400000000000000000001124201222073515200217700ustar00rootroot00000000000000;;; -*- mode: Emacs-Lisp; coding: utf-8 -*- ;; Author: Yoshinari Nomura , ;; TSUCHIYA Masatoshi ;; Created: 2000/05/01 ;; Revised: $Date$ ;;; Commentary: ;; This file is a part of MHC. ;; This file consists of two parts: the first part contains MUA ;; backend functions, and the second part contains functions to make ;; summary contents. ;;; About MUA Backend: ;; In order to define new MUA backend, it is required to define these ;; methods. ;; ;; (mhc-foo-summary-filename) ;; Return the file name of the article on the current line in ;; this summary buffer. ;; ;; (mhc-foo-summary-display-article) ;; Display the article on the current line in this buffer. ;; ;; (mhc-foo-get-import-buffer GET-ORIGINAL) ;; Return buffer visiting import article. If GET-ORIGINAL, ;; return it without MIME decode. ;; ;; (mhc-foo-generate-summary-buffer DATE) ;; Generate summary buffer of mailer, and change current ;; buffer to it. This function will be called at the top of ;; mhc-scan-month. ;; ;; (mhc-foo-insert-summary-contents INSERTER) ;; Insert schedule with INSERTER. ;; ;; (mhc-foo-summary-mode-setup DATE) ;; Setup buffer as summary of mailer. This function will be ;; called at the end of mhc-scan-month. ;; ;; (mhc-foo-highlight-message FOR-DRAFT) ;; Hilight message in the current buffer. ;; If FOR-DRAFT is non-nil, Hilight message as draft message." ;; ;; (mhc-foo-eword-decode-string STRING) ;; Decode encoded STRING. ;; ;; (mhc-foo-decode-header) ;; Decode encoded header. ;; ;; Define these methods appropriately, and put definitions as follows: ;; ;; (provide 'mhc-foo) ;; (put 'mhc-foo 'summary-filename 'mhc-foo-summary-filename) ;; (put 'mhc-foo 'summary-display-article 'mhc-foo-summary-display-article) ;; (put 'mhc-foo 'get-import-buffer 'mhc-foo-get-import-buffer) ;; (put 'mhc-foo 'generate-summary-buffer 'mhc-foo-generate-summary-buffer) ;; (put 'mhc-foo 'insert-summary-contents 'mhc-foo-insert-summary-contents) ;; (put 'mhc-foo 'summary-mode-setup 'mhc-foo-summary-mode-setup) ;; (put 'mhc-foo 'highlight-message 'mhc-foo-highlight-message) ;; (put 'mhc-foo 'eword-decode-string 'mhc-foo-eword-decode-string) ;; (put 'mhc-foo 'decode-header 'mhc-foo-decode-header) (require 'mhc-day) (require 'mhc-compat) (require 'mhc-schedule) (require 'bytecomp) ;;; Global Variables: (defcustom mhc-summary-language 'english "*Language of the summary." :group 'mhc :type '(choice (const :tag "English" english) (const :tag "Japanese" japanese))) (defcustom mhc-summary-use-cw nil "*If non-nil, insert `Calendar week number' instead of `Monday'." :group 'mhc :type '(choice (const :tag "Use" t) (const :tag "No" nil))) (defcustom mhc-use-week-separator t "*If non-nil insert separator in summary buffer." :group 'mhc :type 'boolean) (defcustom mhc-summary-separator ?- "*Character of the separator as 'mhc-use-week-separator'." :group 'mhc :type 'character) (defcustom mhc-use-month-separator t "*Insert separator in summary buffer for wide scope." :group 'mhc :type '(choice (const :tag "Insert (full width)" t) (integer :tag "Insert (number of width)") (const :tag "Not use" nil))) (defcustom mhc-summary-month-separator ?= "*Character of the separator as 'mhc-use-month-separator'." :group 'mhc :type 'character) (defcustom mhc-summary-string-conflict "[C]" "*String which indicates conflicts in summary buffer." :group 'mhc :type 'string) (defcustom mhc-summary-string-recurrence "[R]" "*String which indicates recurrences in summary buffer." :group 'mhc :type 'string) (defcustom mhc-summary-string-secret "[SECRET]" "*String which hides private subjects in summary buffer." :group 'mhc :type 'string) (defcustom mhc-use-icon t "*If non-nil, schedule icon is used." :group 'mhc :type 'boolean) (defcustom mhc-icon-path (if (fboundp 'locate-data-directory) (locate-data-directory "mhc")) "*Icon path for MHC." :group 'mhc :type 'directory) (defcustom mhc-icon-setup-hook nil "*A hook called after icon setup." :group 'mhc :type 'hook) (defcustom mhc-summary-display-todo t "*Display TODO in summary." :group 'mhc :type 'boolean) (defcustom mhc-insert-overdue-todo nil "*Display overdue TODO on TODAY." :group 'mhc :type 'boolean) (defcustom mhc-summary-line-format (if (eq mhc-summary-language 'japanese) "%M%月%D%日%(%曜%) %b%e %c%i%s %p%l" "%M%/%D%S%W %b%e %c%i%s %p%l") "*A format string for summary line of MHC. It may include any of the following format specifications which are replaced by the given information: %Y The year of the line if first line of the day. %M The month of the line if first line of the day. %D The day of the line if first line of the day. %W The weekday name of the line if first line of the day. %b Begin time. %e End time (includes '-'). %c Warning string for conflict (See also `mhc-summary-string-conflict'). %i The icon for the schedule. %s The subject of the schedule. %p The priority of the schedule. %l The location of the schedule. %/ A slash character if first line of the day. %( A left parenthesis character if first line of the day. %) A right parenthesis character if first line of the day. %S A space with face. %年 The '年' of the line if first line of the day. %月 The '月' of the line if first line of the day. %日 The '日' of the line if first line of the day. %曜 The japaneses weekday name of the line if first line of the day. " :group 'mhc :type 'string) (defcustom mhc-todo-line-format " %p %c%i%s %l%d" "*A format string for summary todo line of MHC. It may include any of the following format specifications which are replaced by the given information: %i The icon for the schedule. %c The checkbox of the TODO. %s The subject of the schedule. %l The location of the schedule. %p The priority of the schedule. %d The deadline of the schedule. \(`mhc-todo-string-remaining-day' or `mhc-todo-string-deadline-day' is used\) " :group 'mhc :type 'string) (defcustom mhc-overdue-todo-line-format (concat (if (eq mhc-summary-language 'japanese) " " " ") "%T %p %c%i%s %l%d") "*A format string for summary overdue todo line of MHC. It may include any of the following format specifications which are replaced by the given information: %T The indicator for TODO. %i The icon for the schedule. %c The checkbox of the TODO. %s The subject of the schedule. %l The location of the schedule. %p The priority of the schedule. %d The deadline of the schedule. \(`mhc-todo-string-remaining-day' or `mhc-todo-string-deadline-day' is used\) " :group 'mhc :type 'string) (defcustom mhc-todo-position 'bottom "Variable to specify position of TODO list." :group 'mhc :type '(radio (const :tag "Bottom" 'bottom) (const :tag "Top" 'top)) ;; (const :tag "Above of vertical calender" 'above) ;; (const :tag "Below of vertical calender" 'below)) ) (defcustom mhc-todo-string-remaining-day (if (eq mhc-summary-language 'japanese) "(あと %d 日)" "(%d days to go)") "*String format which is displayed in TODO entry. '%d' is replaced with remaining days." :group 'mhc :type 'string) (defcustom mhc-todo-string-deadline-day (if (eq mhc-summary-language 'japanese) "(〆切日)" "(due this date)") "*String which indicates deadline day in TODO." :group 'mhc :type 'string) (defcustom mhc-todo-string-excess-day (if (eq mhc-summary-language 'japanese) "(%d 日超過)" "(%d days overdue)") "*String format which is displayed in TODO entry. '%d' is replaced with excess days." :group 'mhc :type 'string) (defcustom mhc-todo-string-heading (if (eq mhc-summary-language 'japanese) "TODO(s) at %04d年%02d月%02d日" "TODO(s) at %04d/%02d/%02d") "*String which is displayed as heading of TODO. First %d is replaced with year, second one is replaced with month, third one is replaced with day of month." :group 'mhc :type 'string) (defcustom mhc-todo-mergin 1 "*Mergin line number between TODO and schedule." :group 'mhc :type 'integer) (defcustom mhc-todo-string-done (if (eq mhc-summary-language 'japanese) "■" "[X]") "*String which indicates done TODO." :group 'mhc :type 'string) (defcustom mhc-todo-string-not-done (if (eq mhc-summary-language 'japanese) "□" "[ ]") "*String which indicates not-done TODO." :group 'mhc :type 'string) (defcustom mhc-todo-display-done t "*Display TODO which is marked as done." :group 'mhc :type 'boolean) (defcustom mhc-memo-line-format " %p %i%s %l" "*A format string for summary memo line of MHC. It may include any of the following format specifications which are replaced by the given information: %i The icon for the schedule. %s The subject of the schedule. %l The location of the schedule. %p The priority of the schedule. " :group 'mhc :type 'string) (defcustom mhc-memo-string-heading "MEMO(s)" "*String which is displayed as heading of MEMO." :group 'mhc :type 'string) ;;; Internal Variable: (defconst mhc-summary-major-mode-alist '((mew-summary-mode . mhc-mew) (mew-virtual-mode . mhc-mew) (wl-folder-mode . mhc-wl) (wl-summary-mode . mhc-wl) (gnus-group-mode . mhc-gnus) (gnus-summary-mode . mhc-gnus))) ;; Internal Variables which are bound while inserting line: (defvar mhc-tmp-day-face nil "a face for the day.") (defvar mhc-tmp-dayinfo nil "a dayinfo for the day.") (defvar mhc-tmp-schedule nil "a schedule structure.") (defvar mhc-tmp-begin nil "begin time.") (defvar mhc-tmp-end nil "end time.") (defvar mhc-tmp-conflict nil "non-nil if conflicted schedule.") (defvar mhc-tmp-recurrence nil "non-nil if recurrence schedule.") (defvar mhc-tmp-first nil "non-nil if first schedule.") (defvar mhc-tmp-private nil "non-nil if private display mode.") (defvar mhc-tmp-priority nil "a priority of the schedule.") ;; For TODO. (defvar mhc-tmp-day nil "the day.") (defvar mhc-tmp-deadline nil "a schedule structure.") ;; Inserter (internal variable) (defvar mhc-summary/line-inserter nil) (defvar mhc-todo/line-inserter nil) (defvar mhc-overdue-todo/line-inserter nil) (defvar mhc-memo/line-inserter nil) (defvar mhc-summary-line-format-alist '((?Y (mhc-summary/line-year-string) 'face mhc-tmp-day-face) (?/ (if mhc-tmp-first "/" " ") 'face mhc-tmp-day-face) (?S " " 'face mhc-tmp-day-face) (?M (mhc-summary/line-month-string) 'face mhc-tmp-day-face) (?D (mhc-summary/line-day-string) 'face mhc-tmp-day-face) (?W (mhc-summary/line-day-of-week-string) 'face mhc-tmp-day-face) (?b (if (null mhc-tmp-begin) (make-string 5 ? ) (format "%02d:%02d" (/ mhc-tmp-begin 60) (% mhc-tmp-begin 60))) 'face 'mhc-summary-face-time) (?e (if (null mhc-tmp-end) (make-string 6 ? ) (format "-%02d:%02d" (/ mhc-tmp-end 60) (% mhc-tmp-end 60))) 'face 'mhc-summary-face-time) (?c (if mhc-tmp-conflict (if (and (mhc-use-icon-p) (mhc-icon-exists-p "conflict")) t mhc-summary-string-conflict)) (if (and (mhc-use-icon-p) (mhc-icon-exists-p "conflict")) 'icon 'face) (if (and (mhc-use-icon-p) (mhc-icon-exists-p "conflict")) (list "conflict") 'mhc-summary-face-conflict)) (?r (if (and mhc-tmp-recurrence (not (string= "" mhc-tmp-recurrence))) (if (and (mhc-use-icon-p) (mhc-icon-exists-p "recurrence")) t mhc-summary-string-recurrence)) (if (and (mhc-use-icon-p) (mhc-icon-exists-p "recurrence")) 'icon 'face) (if (and (mhc-use-icon-p) (mhc-icon-exists-p "recurrence")) (list "recurrence") 'mhc-summary-face-recurrence)) (?p (if mhc-tmp-priority (format "[%d]" mhc-tmp-priority)) 'face (cond ((null mhc-tmp-priority) nil) ((>= mhc-tmp-priority 80) 'mhc-summary-face-sunday) ((>= mhc-tmp-priority 50) 'mhc-summary-face-saturday))) (?i (not mhc-tmp-private) 'icon (if (mhc-schedule-in-category-p mhc-tmp-schedule "done") (delete "todo" (copy-sequence (mhc-schedule-categories mhc-tmp-schedule))) (mhc-schedule-categories mhc-tmp-schedule))) (?s (mhc-summary/line-subject-string) 'face (if mhc-tmp-private (mhc-face-category-to-face "Private") (mhc-face-category-to-face (car (mhc-schedule-categories mhc-tmp-schedule))))) (?l (mhc-summary/line-location-string) 'face 'mhc-summary-face-location) (?\( (if mhc-tmp-first "(" " ") 'face mhc-tmp-day-face) (?\) (if mhc-tmp-first ")" " ") 'face mhc-tmp-day-face) (?年 (if mhc-tmp-first "年" (make-string 2 ? )) 'face mhc-tmp-day-face) (?月 (if mhc-tmp-first "月" (make-string 2 ? )) 'face mhc-tmp-day-face) (?日 (if mhc-tmp-first "日" (make-string 2 ? )) 'face mhc-tmp-day-face) (?曜 (mhc-summary/line-day-of-week-ja-string) 'face mhc-tmp-day-face)) "An alist of format specifications that can appear in summary lines. Each element is a list of following: \(SPEC STRING-EXP PROP-TYPE PROP-VALUE\) SPEC is a character for format specification. STRING is an expression to get string to insert. PROP-TYPE is an expression to get one of the two symbols `face' or `icon'. It indicates a type of the property to put on the inserted string. PROP-VALUE is the property value correspond to PROP-TYPE. ") (defvar mhc-todo-line-format-alist '((?T "TODO" 'face 'mhc-category-face-todo) (?i (not mhc-tmp-private) 'icon (delete "todo" (delete "done" (copy-sequence (mhc-schedule-categories mhc-tmp-schedule))))) (?c (if (and (mhc-use-icon-p) (mhc-icon-exists-p "todo") (mhc-icon-exists-p "done")) t (if (mhc-schedule-in-category-p mhc-tmp-schedule "done") mhc-todo-string-done mhc-todo-string-not-done)) (if (and (mhc-use-icon-p) (mhc-icon-exists-p "todo") (mhc-icon-exists-p "done")) 'icon 'face) (if (and (mhc-use-icon-p) (mhc-icon-exists-p "todo") (mhc-icon-exists-p "done")) (list (if (mhc-schedule-in-category-p mhc-tmp-schedule "done") "done" "todo")) 'mhc-summary-face-sunday)) (?s (mhc-summary/line-subject-string) 'face (mhc-face-category-to-face (car (mhc-schedule-categories mhc-tmp-schedule)))) (?l (mhc-summary/line-location-string) 'face 'mhc-summary-face-location) (?p (if mhc-tmp-priority (format "%5s" (format "[%d]" mhc-tmp-priority)) " ") 'face (cond ((null mhc-tmp-priority) nil) ((>= mhc-tmp-priority 80) 'mhc-summary-face-sunday) ((>= mhc-tmp-priority 50) 'mhc-summary-face-saturday))) (?d (unless (mhc-schedule-in-category-p mhc-tmp-schedule "done") (mhc-todo/line-deadline-string)) 'face (mhc-todo/line-deadline-face))) "An alist of format specifications that can appear in todo lines. Each element is a list of following: \(SPEC STRING-EXP PROP-TYPE PROP-VALUE\) SPEC is a character for format specification. STRING is an expression to get string to insert. PROP-TYPE is an expression to get one of the two symbols `face' or `icon'. It indicates a type of the property to put on the inserted string. PROP-VALUE is the property value correspond to PROP-TYPE. ") (defvar mhc-memo-line-format-alist '((?i (not mhc-tmp-private) 'icon (if (mhc-schedule-in-category-p mhc-tmp-schedule "done") (delete "todo" (copy-sequence (mhc-schedule-categories mhc-tmp-schedule))) (mhc-schedule-categories mhc-tmp-schedule))) (?s (mhc-summary/line-subject-string) 'face (mhc-face-category-to-face (car (mhc-schedule-categories mhc-tmp-schedule)))) (?l (mhc-summary/line-location-string) 'face 'mhc-summary-face-location) (?p (if mhc-tmp-priority (format "%5s" (format "[%d]" mhc-tmp-priority)) " ") 'face (cond ((null mhc-tmp-priority) nil) ((>= mhc-tmp-priority 80) 'mhc-summary-face-sunday) ((>= mhc-tmp-priority 50) 'mhc-summary-face-saturday)))) "An alist of format specifications that can appear in memo lines. Each element is a list of following: \(SPEC STRING-EXP PROP-TYPE PROP-VALUE\) SPEC is a character for format specification. STRING is an expression to get string to insert. PROP-TYPE is an expression to get one of the two symbols `face' or `icon'. It indicates a type of the property to put on the inserted string. PROP-VALUE is the property value correspond to PROP-TYPE. ") (defvar mhc-summary/cw-separator nil) (defvar mhc-summary/cw-week nil) ;;; MUA Backend Functions: (defun mhc-summary-mailer-type () "Return mailer backend symbol using currently." (or (cdr (assq major-mode mhc-summary-major-mode-alist)) (intern (concat "mhc-" (symbol-name mhc-mailer-package))))) (defun mhc-summary/true (&rest args) "This is the dummy backend function, which always returns t." t) (defsubst mhc-summary-get-function (operation &optional mailer) "Return appropriate function to do OPERATION for MAILER." (or (get (require (or mailer (mhc-summary-mailer-type))) operation) 'mhc-summary/true)) (defsubst mhc-get-function (operation) "Return appropriate function to do OPERATION." (or (get (require (intern (concat "mhc-" (symbol-name mhc-mailer-package)))) operation) 'mhc-summary/true)) (defsubst mhc-highlight-message (&optional for-draft) "Hilight message in the current buffer. If optional argument FOR-DRAFT is non-nil, Hilight message as draft message." (funcall (mhc-get-function 'highlight-message) for-draft)) (defsubst mhc-eword-decode-string (string) "Decode encoded STRING." (funcall (mhc-get-function 'eword-decode-string) string)) (defsubst mhc-decode-header () "Decode encoded header." (funcall (mhc-get-function 'decode-header))) (defsubst mhc-summary-filename (&optional mailer) "Return file name of article on current line." (funcall (mhc-summary-get-function 'summary-filename mailer))) (defsubst mhc-summary-display-article (&optional mailer) "Display article on current line." (funcall (mhc-summary-get-function 'summary-display-article mailer))) (defsubst mhc-summary-get-import-buffer (&optional get-original mailer) "Return buffer to import article." (funcall (mhc-summary-get-function 'get-import-buffer mailer) get-original)) (defsubst mhc-summary-generate-buffer (date &optional mailer) "Generate buffer with summary mode of MAILER." (funcall (mhc-summary-get-function 'generate-summary-buffer mailer) date)) (defsubst mhc-summary-insert-contents (mhc-tmp-schedule mhc-tmp-private inserter &optional mailer) (if (eq 'direct mailer) (let ((mhc-use-icon nil)) (mhc-summary-line-insert) (insert "\n")) (funcall (mhc-summary-get-function 'insert-summary-contents mailer) inserter))) (defsubst mhc-summary-search-date (date) "Search day in the current buffer." (let (dayinfo) (goto-char (point-min)) (while (and (not (eobp)) (or (null (setq dayinfo (get-text-property (point) 'mhc-dayinfo))) (not (eq (mhc-day-date dayinfo) date)))) (goto-char (next-single-property-change (point) 'mhc-dayinfo))))) (defsubst mhc-summary-mode-setup (date &optional mailer) "Setup buffer as summary mode of MAILER." (funcall (mhc-summary-get-function 'summary-mode-setup mailer) date)) (defun mhc-summary-record (&optional mailer) "Return record on current line." (let ((filename (mhc-summary-filename mailer))) (if filename (let ((key (mhc-slot-directory-to-key (directory-file-name (file-name-directory filename))))) (assoc filename (mhc-slot-records (mhc-slot-get-month-schedule key))))))) (defun mhc-summary-folder-to-path (folder &optional msg) (let ((fld (if (eq (string-to-char folder) ?+) (substring mhc-base-folder 1) folder))) (if msg (format "%s/%s/%s" mhc-mail-path fld msg) (format "%s/%s" mhc-mail-path fld)))) ;;; Codes: (defsubst mhc-summary/make-string (count character) (make-string (max 4 count) character)) ;; xxxx 4 ? (defun mhc-summary/insert-separator (&optional wide str fixwidth) (let ((width (mhc-misc-get-width)) hr) (if wide (if (stringp str) (let ((hr1 (make-string 4 mhc-summary-month-separator)) ;; xxxx 4 ? hr2) (mhc-face-put hr1 'mhc-summary-face-month-separator) (mhc-face-put str 'mhc-summary-face-cw) (setq hr2 (mhc-summary/make-string (- width (if (numberp mhc-use-month-separator) mhc-calendar-width 2) (length hr1) (length str)) mhc-summary-month-separator)) (mhc-face-put hr2 'mhc-summary-face-separator) (setq hr (concat hr1 str hr2))) (setq hr (mhc-summary/make-string (if (numberp mhc-use-month-separator) mhc-use-month-separator (- width 2)) mhc-summary-month-separator)) (mhc-face-put hr 'mhc-summary-face-month-separator)) (if (stringp str) (let ((hr1 (make-string 4 mhc-summary-separator)) ;; xxxx 4 ? hr2) (mhc-face-put hr1 'mhc-summary-face-separator) (mhc-face-put str 'mhc-summary-face-cw) (setq hr2 (mhc-summary/make-string (- width mhc-calendar-width (length hr1) (length str)) mhc-summary-separator)) (mhc-face-put hr2 'mhc-summary-face-separator) (setq hr (concat hr1 str hr2))) (if fixwidth (setq hr (mhc-summary/make-string fixwidth mhc-summary-separator)) (setq hr (mhc-summary/make-string (- width mhc-calendar-width) mhc-summary-separator))) (mhc-face-put hr 'mhc-summary-face-separator))) (insert hr "\n"))) (defvar mhc-summary/today nil) (defun mhc-summary/insert-dayinfo (mhc-tmp-dayinfo mailer category-predicate secret) (let ((time-max -1) (schedules (mhc-day-schedules mhc-tmp-dayinfo)) (mhc-tmp-first t) mhc-tmp-begin mhc-tmp-end mhc-tmp-location mhc-tmp-schedule mhc-tmp-conflict mhc-tmp-recurrence mhc-tmp-priority next-begin displayed) (if schedules (progn (while schedules (if (and (if mhc-summary-display-todo t (not (mhc-schedule-in-category-p (car schedules) "todo"))) (funcall category-predicate (car schedules))) (progn (setq mhc-tmp-begin (mhc-schedule-time-begin (car schedules)) mhc-tmp-end (mhc-schedule-time-end (car schedules)) mhc-tmp-priority (mhc-schedule-priority (car schedules)) next-begin (if (car (cdr schedules)) (mhc-schedule-time-begin (car (cdr schedules)))) mhc-tmp-conflict (or (and mhc-tmp-end next-begin (< next-begin mhc-tmp-end)) (and mhc-tmp-begin time-max (< mhc-tmp-begin time-max))) mhc-tmp-recurrence (mhc-schedule-recurrence-tag (car schedules))) (if mhc-tmp-end (setq time-max (max mhc-tmp-end time-max))) (setq displayed t) (mhc-summary-insert-contents (car schedules) (and secret (mhc-schedule-in-category-p (car schedules) mhc-category-as-private)) 'mhc-summary-line-insert mailer) (setq mhc-tmp-first nil))) (setq schedules (cdr schedules))) (if (not displayed) (mhc-summary-insert-contents nil secret 'mhc-summary-line-insert mailer))) (mhc-summary-insert-contents nil secret 'mhc-summary-line-insert mailer)))) (defun mhc-summary-make-contents (from to mailer &optional category-predicate secret) (let ((dayinfo-list (mhc-db-scan from to)) todo-list overdue deadline mhc-tmp-day) (setq mhc-summary/today (mhc-date-now)) (while dayinfo-list (mhc-summary/insert-dayinfo (car dayinfo-list) mailer (or category-predicate mhc-default-category-predicate-sexp) secret) (when (and mhc-insert-overdue-todo (mhc-date= (mhc-day-date (car dayinfo-list)) mhc-summary/today)) (setq todo-list (mhc-db-scan-todo mhc-summary/today)) (while todo-list (setq deadline (mhc-schedule-todo-deadline (car todo-list))) (when (and deadline (if mhc-summary-display-todo (> (mhc-date- mhc-summary/today deadline) 0) (>= (mhc-date- mhc-summary/today deadline) 0)) (not (mhc-schedule-in-category-p (car todo-list) "done"))) (setq overdue (cons (car todo-list) overdue))) (setq todo-list (cdr todo-list))) (setq mhc-tmp-day mhc-summary/today) (setq overdue (nreverse overdue)) (while overdue (mhc-summary-insert-contents (car overdue) (and secret (mhc-schedule-in-category-p (car overdue) mhc-category-as-private)) 'mhc-overdue-todo-line-insert mailer) (setq overdue (cdr overdue)))) (and mhc-use-week-separator (eq (mhc-day-day-of-week (car dayinfo-list)) (mhc-end-day-of-week)) (> (length dayinfo-list) 1) (mhc-summary/insert-separator nil (when mhc-summary/cw-separator (format " CW %d " (mhc-date-cw (mhc-date++ (mhc-day-date (car dayinfo-list)))))))) (setq dayinfo-list (cdr dayinfo-list))))) (defun mhc-summary-make-todo-memo (today mailer category-predicate secret) (when mhc-insert-todo-list (mhc-summary-make-todo-list today mailer category-predicate secret)) (when mhc-insert-memo-list (mhc-summary-make-memo-list today mailer category-predicate secret))) (defun mhc-summary-make-todo-list (day mailer &optional category-predicate secret) (let ((schedules (mhc-db-scan-todo day)) (mhc-tmp-day day)) (if schedules (progn (insert (mhc-day-let day (format mhc-todo-string-heading year month day-of-month)) "\n") (while schedules (if (and (if (mhc-schedule-in-category-p (car schedules) "done") mhc-todo-display-done t) (funcall category-predicate (car schedules))) (mhc-summary-insert-contents (car schedules) (and secret (mhc-schedule-in-category-p (car schedules) mhc-category-as-private)) 'mhc-todo-line-insert mailer)) (setq schedules (cdr schedules))))))) (defun mhc-summary-make-memo-list (day mailer &optional category-predicate secret) (let ((schedules (mhc-db-scan-memo day)) (mhc-tmp-day day)) (when schedules (insert (format "%s\n" mhc-memo-string-heading)) (while schedules (when (funcall category-predicate (car schedules)) (mhc-summary-insert-contents (car schedules) (and secret (mhc-schedule-in-category-p (car schedules) mhc-category-as-private)) 'mhc-memo-line-insert mailer)) (setq schedules (cdr schedules)))))) (defun mhc-summary/line-year-string () (if mhc-tmp-first (format "%4d" (mhc-day-year mhc-tmp-dayinfo)) (make-string 2 ? ))) (defun mhc-summary/line-month-string () (if mhc-tmp-first (format "%02d" (mhc-day-month mhc-tmp-dayinfo)) (make-string 2 ? ))) (defun mhc-summary/line-day-string () (if mhc-tmp-first (format "%02d" (mhc-day-day-of-month mhc-tmp-dayinfo)) (make-string 2 ? ))) (defun mhc-summary/line-day-of-week-string () (if mhc-tmp-first (let ((week (mhc-day-day-of-week mhc-tmp-dayinfo))) (if (and mhc-summary/cw-week (= week 1) ) (format "%3s" (format "w%d" (mhc-date-cw (mhc-day-date mhc-tmp-dayinfo)))) (aref ["Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat"] week))) (make-string 3 ? ))) (defun mhc-summary/line-day-of-week-ja-string () (if mhc-tmp-first (let ((week (mhc-day-day-of-week mhc-tmp-dayinfo))) (if (and mhc-summary/cw-week(= week 1) ) (format "%2d" (mhc-date-cw (mhc-day-date mhc-tmp-dayinfo))) (aref ["日" "月" "火" "水" "木" "金" "土"] week))) (make-string 2 ? ))) (defun mhc-summary/line-subject-string () (if mhc-tmp-private (and mhc-tmp-schedule mhc-summary-string-secret) (or (mhc-schedule-subject mhc-tmp-schedule) ""))) (defun mhc-summary/line-location-string () (let ((location (mhc-schedule-location mhc-tmp-schedule))) (and (not mhc-tmp-private) location (> (length location) 0) (concat "[" location "]")))) (defun mhc-todo/line-deadline-string () (and mhc-tmp-deadline (if (mhc-date= mhc-tmp-deadline mhc-tmp-day) mhc-todo-string-deadline-day (let ((remaining (mhc-date- mhc-tmp-deadline mhc-tmp-day))) (if (> remaining 0) (format mhc-todo-string-remaining-day remaining) (format mhc-todo-string-excess-day (abs remaining))))))) (defun mhc-todo/line-deadline-face () (and mhc-tmp-deadline (if (> (mhc-date- mhc-tmp-deadline mhc-tmp-day) 0) 'mhc-summary-face-default 'mhc-summary-face-sunday))) ;;; Line format parsing (defmacro mhc-line-insert (string) `(and (stringp ,string) (insert ,string))) (defun mhc-line-parse-format (format spec-alist) (let ((f (mhc-string-to-char-list format)) inserter entry) (setq inserter (list 'let (list 'pos))) (while f (if (eq (car f) ?%) (progn (setq f (cdr f)) (if (eq (car f) ?%) (setq inserter (append inserter (list (list 'insert ?%)))) (setq entry (assq (car f) spec-alist)) (unless entry (error "Unknown format spec %%%c" (car f))) (setq inserter (append inserter (list (list 'setq 'pos (list 'point))) (list (list 'mhc-line-insert (nth 1 entry))) (and (nth 2 entry) (list (append (cond ((eq (eval (nth 2 entry)) 'face) (list 'put-text-property 'pos (list 'point) (list 'quote 'face) (nth 3 entry))) ((eq (eval (nth 2 entry)) 'icon) (list 'if (nth 1 entry) (list 'and (list 'mhc-use-icon-p) (list 'mhc-put-icon (nth 3 entry))))))))))))) (setq inserter (append inserter (list (list 'insert (car f)))))) (setq f (cdr f))) inserter)) (defmacro mhc-line-inserter-setup (inserter format alist) `(let (byte-compile-warnings) (setq ,inserter (byte-compile (list 'lambda () (mhc-line-parse-format ,format ,alist)))) (when (get-buffer "*Compile-Log*") (bury-buffer "*Compile-Log*")) (when (get-buffer "*Compile-Log-Show*") (bury-buffer "*Compile-Log-Show*")))) (defun mhc-summary-line-inserter-setup () "Setup MHC summary and todo line inserter." (interactive) (if (and (interactive-p) (mhc-use-icon-p)) (call-interactively 'mhc-icon-setup)) (setq mhc-summary/cw-separator (and mhc-summary-use-cw mhc-use-week-separator (eq mhc-start-day-of-week 1))) (setq mhc-summary/cw-week (and mhc-summary-use-cw (not mhc-summary/cw-separator))) (mhc-line-inserter-setup mhc-summary/line-inserter mhc-summary-line-format mhc-summary-line-format-alist) (mhc-line-inserter-setup mhc-todo/line-inserter mhc-todo-line-format mhc-todo-line-format-alist) (mhc-line-inserter-setup mhc-overdue-todo/line-inserter mhc-overdue-todo-line-format mhc-todo-line-format-alist) (mhc-line-inserter-setup mhc-memo/line-inserter mhc-memo-line-format mhc-memo-line-format-alist)) (defun mhc-summary-line-insert () "Insert summary line." (let ((mhc-tmp-day-face (cond ((mhc-schedule-in-category-p mhc-tmp-schedule "holiday") 'mhc-category-face-holiday) ((eq (mhc-day-day-of-week mhc-tmp-dayinfo) 0) 'mhc-summary-face-sunday) ((eq (mhc-day-day-of-week mhc-tmp-dayinfo) 6) 'mhc-summary-face-saturday) (t 'mhc-summary-face-default))) (pos (point))) (if (mhc-date= (mhc-day-date mhc-tmp-dayinfo) (mhc-date-now)) (setq mhc-tmp-day-face (mhc-face-get-today-face mhc-tmp-day-face))) (funcall mhc-summary/line-inserter) (put-text-property pos (point) 'mhc-dayinfo mhc-tmp-dayinfo))) (defun mhc-todo-line-insert () "Insert todo line." (let ((mhc-tmp-deadline (mhc-schedule-todo-deadline mhc-tmp-schedule)) (mhc-tmp-priority (mhc-schedule-priority mhc-tmp-schedule))) (funcall mhc-todo/line-inserter))) (defun mhc-overdue-todo-line-insert () "Insert overdue todo line." (let ((mhc-tmp-deadline (mhc-schedule-todo-deadline mhc-tmp-schedule)) (mhc-tmp-priority (mhc-schedule-priority mhc-tmp-schedule))) (funcall mhc-overdue-todo/line-inserter))) (defun mhc-memo-line-insert () "Insert memo line." (let ((mhc-tmp-priority (mhc-schedule-priority mhc-tmp-schedule))) (funcall mhc-memo/line-inserter))) (provide 'mhc-summary) ;;; Copyright Notice: ;; Copyright (C) 1999, 2000 Yoshinari Nomura. All rights reserved. ;; Copyright (C) 2000 MHC developing team. All rights reserved. ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of the team nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' ;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ;; THE TEAM OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, ;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED ;; OF THE POSSIBILITY OF SUCH DAMAGE. ;;; mhc-summary.el ends here. yoshinari-nomura-mhc-815a36a/emacs/mhc-sync.el000066400000000000000000000127601222073515200212550ustar00rootroot00000000000000;;; -*- emacs-lisp -*- ;; mhc-sync.el -- mhc-sync (ruby script) interface ;; ;; Author: Hideyuki SHIRAI ;; ;; Created: 2000/06/12 ;; Revised: $Date: 2002/11/11 05:27:15 $ ;;; Commentary: ;; This file is a part of MHC, includes backend functions to ;; manipulate schedule files. ;;; Customize Variables: (defcustom mhc-sync-id nil "*Identical id of mhc-sync (-x option)." :group 'mhc :type 'string) (defcustom mhc-sync-remote nil "*Remote server repository of mhc-sync ([user@]remote.host[:dir])." :group 'mhc :type 'string) (defcustom mhc-sync-localdir nil "*Local repository directory of mhc-sync (-r option)." :group 'mhc :type 'string) (defcustom mhc-sync-coding-system (if (>= emacs-major-version 20) 'undecided '*autoconv*) "*Default coding system for process of mhc-sync." :group 'mhc :type 'symbol) ;;; Interanal variabiles: (defconst mhc-sync/passwd-regexp "password:\\|passphrase:\\|Enter passphrase") (defvar mhc-sync/process nil) (defvar mhc-sync/req-passwd nil) ;;; Code: (defun mhc-sync/backup-and-remove (file &optional offline) "Backend function to remove FILE." (let ((file (expand-file-name file)) (new-path (expand-file-name "trash" (mhc-summary-folder-to-path mhc-base-folder)))) (or (file-directory-p new-path) (make-directory new-path)) (rename-file file (mhc-misc-get-new-path new-path)))) (defun mhc-sync/start-process (&optional full) (cond ((not (and (stringp mhc-sync-remote) (stringp mhc-sync-id))) (message "No remote server specified.") nil) ((processp mhc-sync/process) (message "another mhc-sync running.") nil) (t (let ((buf (mhc-get-buffer-create " *mhc-sync*")) (ldir (expand-file-name (or mhc-sync-localdir "~/Mail/schedule")))) (mhc-window-push) (pop-to-buffer buf) (setq buffer-read-only nil) (erase-buffer) (setq buffer-read-only t) (message "mhc-sync...") (setq mhc-sync/req-passwd t) (setq mhc-sync/process (apply (function start-process) "mhc-sync" buf "mhc-sync" (list "-x" mhc-sync-id "-r" ldir mhc-sync-remote))) (set-process-coding-system mhc-sync/process mhc-sync-coding-system) (set-process-filter mhc-sync/process 'mhc-sync/filter) (set-process-sentinel mhc-sync/process 'mhc-sync/sentinel) (if (featurep 'xemacs) (while mhc-sync/process (accept-process-output)) (while mhc-sync/process (sit-for 0.1) (discard-input))) (sit-for 1) (mhc-window-pop) (or (and (mhc-summary-buffer-p) (mhc-rescan-month mhc-default-hide-private-schedules)) (and (mhc-calendar-p) (mhc-calendar-rescan))) t)))) (defun mhc-sync/filter (process string) (if (bufferp (process-buffer process)) (let ((obuf (buffer-name))) (unwind-protect (progn (set-buffer (process-buffer process)) (let ((buffer-read-only nil) passwd) (goto-char (point-max)) (insert string) (cond ((and mhc-sync/req-passwd (string-match mhc-sync/passwd-regexp string)) (setq passwd (mhc-misc-read-passwd string)) (process-send-string process (concat passwd "\n"))) ((string-match "---------------------" string) (setq mhc-sync/req-passwd nil))))) (if (get-buffer obuf) (set-buffer obuf)))))) (defun mhc-sync/sentinel (process event) (when (bufferp (process-buffer process)) (pop-to-buffer (process-buffer process)) (let ((buffer-read-only nil)) (goto-char (point-max)) (insert "<<>>"))) (setq mhc-sync/process nil)) (provide 'mhc-sync) (put 'mhc-sync 'remove 'mhc-sync/backup-and-remove) (put 'mhc-sync 'sync 'mhc-sync/start-process) ;;; Copyright Notice: ;; Copyright (C) 2000 MHC developing team. All rights reserved. ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of the team nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' ;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ;; THE TEAM OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, ;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED ;; OF THE POSSIBILITY OF SUCH DAMAGE. ;; mhc-sync.el ends here yoshinari-nomura-mhc-815a36a/emacs/mhc-vars.el000066400000000000000000000122641222073515200212530ustar00rootroot00000000000000;;; -*- mode: Emacs-Lisp; coding: utf-8 -*- ;; Author: Yoshinari Nomura , ;; Created: 2000/04/30 ;; Revised: $Date$ ;;; Commentary: ;; This file is a part of MHC, and includes defintions of global ;; confiration variables. ;;; Code: (require 'mhc-compat) ;;; Constants: (defconst mhc-version "mhc 0.25 + snap (CHECKOUT-FROM-CVS)") ;;; Configration Variables: (defgroup mhc nil "Various sorts of MH Calender." :group 'mail) (defcustom mhc-mailer-package 'mew "*Variable to set your favorite mailer." :group 'mhc :type '(radio (const :tag "Mew" mew) (const :tag "Wanderlust" wl) (const :tag "Gnus" gnus))) (defcustom mhc-base-folder "+schedule" "*Base foler of MHC" :group 'mhc :type 'string) (defcustom mhc-mail-path (expand-file-name (if (and (boundp 'mew-mail-path) mew-mail-path) mew-mail-path "~/Mail")) "*Base directory your mailer recognized as `+'" :group 'mhc :type 'directory) (defcustom mhc-schedule-file (expand-file-name "~/.schedule") "*MHC DB file which contains holiday and anniversary settings." :group 'mhc :type 'file) (defcustom mhc-start-day-of-week 0 "*Day of the week as the start of the week." :group 'mhc :type '(choice (const :tag "Sunday" 0) (const :tag "Monday" 1) (const :tag "Tuesday" 2) (const :tag "Wednesday" 3) (const :tag "Thursday" 4) (const :tag "Friday" 5) (const :tag "Saturday" 6))) (defcustom mhc-insert-calendar t "*If non nil value, display vertical calender." :group 'mhc :type 'boolean) (defcustom mhc-vertical-calendar-length 3 "*Length of vertical calendar in summary buffer." :group 'mhc :type '(radio (integer :tag "Show length (current month is center)" 3) (cons (integer :tag " Show length" 3) (integer :tag "Length of before current" 1)))) (defcustom mhc-insert-todo-list t "*If non nil value, display TODO list." :group 'mhc :type 'boolean) (defcustom mhc-insert-memo-list t "*If non nil value, display MEMO list." :group 'mhc :type 'boolean) (defcustom mhc-default-coding-system (if (>= emacs-major-version 20) 'utf-8-unix '*iso-2022-ss2-7*) "*Default coding system for MHC schedule files." :group 'mhc :type 'symbol) (defcustom mhc-default-hide-private-schedules nil "*If non-nil value, hide private schedules." :group 'mhc :type 'boolean) (defcustom mhc-category-as-private '("private") "*String list of private categories." :group 'mhc :type '(repeat (string :tag "Category"))) (defcustom mhc-default-network-status t "*Flag of the default network status." :group 'mhc :type 'boolean) (defcustom mhc-show-network-status t "*Flag to show the network status." :group 'mhc :type 'boolean) (defcustom mhc-use-cache t "*Flag to decide whether to use cache or not." :group 'mhc :type '(radio (const :tag "Use" t) (const :tag "Lazy check" 0) (const :tag "No use" nil))) (defcustom mhc-use-wide-scope nil "*Wide scope method in summary mode." :group 'mhc :type '(radio (const :tag "No use" nil) (const :tag "Complete week scope" week) (const :tag "Wide week scope" wide) (integer :tag "Scope wide size (>=0)" 3))) (defcustom mhc-default-alarm "5 minute" "*Default alarm string in making draft." :group 'mhc :type 'string) (defcustom mhc-ask-alarm nil "*If non-nil value, ask the alarm string in making draft." :group 'mhc :type 'boolean) (provide 'mhc-vars) ;;; Copyright Notice: ;; Copyright (C) 1999, 2000 Yoshinari Nomura. All rights reserved. ;; Copyright (C) 2000 MHC developing team. All rights reserved. ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of the team nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' ;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ;; THE TEAM OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, ;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED ;; OF THE POSSIBILITY OF SUCH DAMAGE. ;;; mhc-vars.el ends here yoshinari-nomura-mhc-815a36a/emacs/mhc-wl.el000066400000000000000000000254361222073515200207270ustar00rootroot00000000000000;;; -*- mode: Emacs-Lisp; coding: utf-8 -*- ;; Author: Yoshinari Nomura , ;; Created: 2000/05/10 ;; Revised: $Date$ ;;; Commentary: ;; This file is a part of MHC, includes MUA backend methods for ;; Wanderlust. ;;; Code: (require 'wl-summary) (require 'elmo-localdir) (require 'mhc-mime) (require 'static) ;; Setup function: ;;;###autoload (defun mhc-wl-setup () (require 'mhc) (setq mhc-mailer-package 'wl) (mhc-setup) (autoload 'mhc-mode "mhc" nil t) (add-hook 'wl-summary-mode-hook 'mhc-mode) (add-hook 'wl-folder-mode-hook 'mhc-mode) (add-hook 'wl-exit-hook 'mhc-exit)) ;; Backend methods: (static-if (fboundp 'elmo-message-file-name) (defun mhc-wl-summary-filename () "Return FILENAME on current line ." (let ((number (wl-summary-message-number))) (if (and number (not (eq number 100000))) (elmo-message-file-name wl-summary-buffer-elmo-folder number) (error "No schedule data")))) (defun mhc-wl-summary-filename () "Return FILENAME on current line." (let* ((fld-num (elmo-multi-get-real-folder-number wl-summary-buffer-folder-name (wl-summary-message-number))) (fld (car fld-num)) (num (cdr fld-num))) (expand-file-name (number-to-string num) (elmo-localdir-get-folder-directory (elmo-folder-get-spec fld)))))) (defun mhc-wl-summary-display-article () "Display the article on the current." (wl-summary-redisplay)) (defun mhc-wl-mime-get-raw-buffer () (static-if (fboundp 'wl-summary-get-original-buffer) (wl-summary-get-original-buffer) (wl-summary-set-message-buffer-or-redisplay) (wl-message-get-original-buffer))) (defun mhc-wl-mime-get-mime-structure () (wl-summary-set-message-buffer-or-redisplay) (get-text-property (point) 'mime-view-entity)) (defun mhc-wl-highlight-message (for-draft) (static-if (boundp 'wl-highlight-x-face-function) (let ((wl-highlight-x-face-function (unless for-draft wl-highlight-x-face-function))) (wl-highlight-message (point-min) (point-max) t)) (let ((wl-highlight-x-face-func (unless for-draft wl-highlight-x-face-func))) (wl-highlight-message (point-min) (point-max) t)))) ;; mhc-tmp-schedule is already bound. (defun mhc-wl-insert-summary-contents (inserter) (let ((today (mhc-current-date-month)) (date (mhc-day-date mhc-tmp-dayinfo)) head path) (setq path (mhc-record-name (mhc-schedule-record mhc-tmp-schedule)) head (cond ((or (not path) (equal path mhc-schedule-file)) (if mhc-tmp-schedule "100000" "------")) ((string-match "/intersect/" path) (format "1%05d" (string-to-number (file-name-nondirectory path)))) ;; This month ((mhc-date-yymm= today date) (format "2%05d" (string-to-number (file-name-nondirectory path)))) ;; Previous month ((mhc-date-yymm= (mhc-date-mm- today 1) date) (format "3%05d" (string-to-number (file-name-nondirectory path)))) ;; Next month ((mhc-date-yymm= (mhc-date-mm+ today 1) date) (format "4%05d" (string-to-number (file-name-nondirectory path))))) head (concat head (if path "*| " " | "))) (put-text-property 0 (length head) 'invisible t head) (insert head) (funcall inserter) (insert "\n"))) (defsubst mhc-wl/date-to-folder (date) (mhc-date-format date "*%s/intersect,%s/%04d/%02d,%s/%04d/%02d,%s/%04d/%02d" mhc-base-folder mhc-base-folder yy mm mhc-base-folder (if (eq mm 1) (- yy 1) yy) (if (eq mm 1) 12 (- mm 1)) mhc-base-folder (if (eq mm 12) (+ yy 1) yy) (if (eq mm 12) 1 (+ mm 1)))) (defvar mhc-wl-exit-buffer nil) (make-variable-buffer-local 'mhc-wl-exit-buffer) (defun mhc-wl-summary-exit () (let ((buffer mhc-wl-exit-buffer)) (wl-summary-toggle-disp-msg 'off) (kill-buffer (current-buffer)) (when (and buffer (buffer-live-p buffer)) (if (get-buffer-window buffer) (unless (eq (current-buffer) buffer) (delete-window))) (switch-to-buffer buffer) (if (eq (with-current-buffer buffer major-mode) 'wl-folder-mode) (delete-other-windows))))) (defun mhc-wl-summary-next-message (num direction hereto) (if (eq direction 'up) (progn (beginning-of-line) (and (re-search-backward "^ *[0-9]+" nil t) t)) (end-of-line) (and (re-search-forward "^ *[0-9]+" nil t) t))) (defun mhc-wl-summary-mode-setup (date) (let ((original mhc-wl-exit-buffer) wl-summary-lazy-highlight wl-summary-lazy-update-mark (elmo-localdir-folder-path mhc-mail-path)) (wl-summary-mode) ; buffer local variables are killed. (setq mhc-wl-exit-buffer original) (wl-summary-buffer-set-folder (mhc-wl/date-to-folder date)) (make-local-variable 'wl-summary-highlight) (setq wl-summary-highlight nil) (make-local-variable 'wl-message-buffer-prefetch-folder-type-list) (setq wl-message-buffer-prefetch-folder-type-list nil) (static-if (boundp 'wl-summary-buffer-next-folder-function) (setq wl-summary-buffer-next-folder-function (lambda () (mhc-goto-next-month 1) (goto-char (point-min)) (mhc-wl-summary-next-message nil 'down nil))) (setq wl-summary-buffer-next-folder-func (lambda () (mhc-goto-next-month 1) (goto-char (point-min)) (mhc-wl-summary-next-message nil 'down nil)))) (static-if (boundp 'wl-summary-buffer-prev-folder-function) (setq wl-summary-buffer-prev-folder-function (lambda () (mhc-goto-prev-month 1) (goto-char (point-max)) (mhc-wl-summary-next-message nil 'up nil))) (setq wl-summary-buffer-prev-folder-func (lambda () (mhc-goto-prev-month 1) (goto-char (point-max)) (mhc-wl-summary-next-message nil 'up nil)))) (static-if (boundp 'wl-summary-buffer-exit-function) (setq wl-summary-buffer-exit-function 'mhc-wl-summary-exit) (setq wl-summary-buffer-exit-func 'mhc-wl-summary-exit)) (static-if (boundp 'wl-summary-buffer-next-message-function) (setq wl-summary-buffer-next-message-function 'mhc-wl-summary-next-message) (setq wl-summary-buffer-next-message-func 'mhc-wl-summary-next-message)) (make-local-variable 'wl-message-buffer-prefetch-get-next-function) (setq wl-message-buffer-prefetch-get-next-function 'ignore) (setq wl-summary-buffer-target-mark-list '(nil)) (setq wl-summary-buffer-number-regexp "[0-9]+") (setq wl-summary-buffer-folder-indicator (buffer-name)) (setq wl-summary-buffer-mode-line-formatter (lambda () (buffer-name))) (wl-summary-update-modeline) (static-if (fboundp 'elmo-folder-msgdb) (elmo-folder-set-msgdb-internal wl-summary-buffer-elmo-folder '(nil)) (setq wl-summary-buffer-msgdb '(nil))))) (defun mhc-wl-generate-summary-buffer (date) (wl-summary-toggle-disp-msg 'off) (let ((original (and (or (eq major-mode 'wl-summary-mode) (eq major-mode 'wl-folder-mode)) (or mhc-wl-exit-buffer (current-buffer))))) (switch-to-buffer (set-buffer (mhc-get-buffer-create (mhc-date-format date "%s/%02d/%02d" mhc-base-folder yy mm)))) (and original (setq mhc-wl-exit-buffer original)) (setq inhibit-read-only t buffer-read-only nil selective-display t selective-display-ellipses nil indent-tabs-mode nil) (widen) (delete-region (point-min) (point-max)))) (defun mhc-wl-goto-message (&optional view) "Go to a view position on summary buffer." (when view (wl-summary-redisplay))) (provide 'mhc-wl) (put 'mhc-wl 'summary-filename 'mhc-wl-summary-filename) (put 'mhc-wl 'summary-display-article 'mhc-wl-summary-display-article) (put 'mhc-wl 'generate-summary-buffer 'mhc-wl-generate-summary-buffer) (put 'mhc-wl 'insert-summary-contents 'mhc-wl-insert-summary-contents) (put 'mhc-wl 'summary-mode-setup 'mhc-wl-summary-mode-setup) (put 'mhc-wl 'get-import-buffer 'mhc-mime-get-import-buffer) (put 'mhc-wl 'mime-get-raw-buffer 'mhc-wl-mime-get-raw-buffer) (put 'mhc-wl 'mime-get-mime-structure 'mhc-wl-mime-get-mime-structure) (put 'mhc-wl 'highlight-message 'mhc-wl-highlight-message) (put 'mhc-wl 'draft-setup-new 'mhc-mime-draft-setup-new) (put 'mhc-wl 'draft-reedit-buffer 'mhc-mime-draft-reedit-buffer) (put 'mhc-wl 'draft-reedit-file 'mhc-mime-draft-reedit-file) (put 'mhc-wl 'draft-translate 'mhc-mime-draft-translate) (put 'mhc-wl 'eword-decode-string 'mhc-mime-eword-decode-string) (put 'mhc-wl 'decode-header 'mhc-mime-decode-header) (put 'mhc-wl 'goto-message 'mhc-wl-goto-message) ;;; Copyright Notice: ;; Copyright (C) 1999, 2000 Yoshinari Nomura. All rights reserved. ;; Copyright (C) 2000 MHC developing team. All rights reserved. ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of the team nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' ;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ;; THE TEAM OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, ;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED ;; OF THE POSSIBILITY OF SUCH DAMAGE. ;;; mhc-wl.el ends here. yoshinari-nomura-mhc-815a36a/emacs/mhc-xmas.el000066400000000000000000000163251222073515200212520ustar00rootroot00000000000000;;; mhc-xmas.el -- XEmacs stuff for MHC. ;; Author: Yuuichi Teranishi ;; ;; Created: 1999/12/02 ;; Revised: $Date: 2008/03/06 09:40:12 $ (defcustom mhc-xmas-icon-alist '(("Conflict" . "Conflict.xpm") ("Private" . "Private.xpm") ("Holiday" . "Holiday.xpm") ("Todo" . "CheckBox.xpm") ("Done" . "CheckedBox.xpm") ("Link" . "Link.xpm")) "*Alist to define icons. Each element should have the form (NAME . ICON-FILE) It defines icon named NAME created from ICON-FILE. Example: '((\"Holiday\" . \"Holiday.xpm\") (\"Work\" . \"Business.xpm\") (\"Private\" . \"Private.xpm\") (\"Anniversary\" . \"Anniversary.xpm\") (\"Birthday\" . \"Birthday.xpm\") (\"Other\" . \"Other.xpm\") (\"Todo\" . \"CheckBox.xpm\") (\"Done\" . \"CheckedBox.xpm\") (\"Conflict\" . \"Conflict.xpm\"))" :group 'mhc :type '(repeat :inline t (cons (string :tag "Icon Name") (string :tag "XPM File Name")))) (defcustom mhc-icon-function-alist '(("Todo" . mhc-todo-set-as-done) ("Done" . mhc-todo-set-as-not-done) ("Link" . mhc-browse-x-url)) "*Alist to define callback function for icons. Each element should have the form (NAME . FUNCTION) If the icon named NAME is clicked, then FUNCTION is invoked at icon line." :group 'mhc :type '(repeat :inline t (cons (string :tag "Icon Name") (function :tag "Function")))) (defvar mhc-xmas-icon-keymap nil) (if (null mhc-xmas-icon-keymap) (setq mhc-xmas-icon-keymap (make-sparse-keymap))) (define-key mhc-xmas-icon-keymap 'button1 'mhc-xmas-icon-call-function) (define-key mhc-xmas-icon-keymap 'button2 'mhc-xmas-icon-call-function) (defun mhc-xmas-icon-call-function (event) (interactive "e") (save-excursion (goto-char (extent-start-position (event-glyph-extent event))) (when (extent-property (event-glyph-extent event) 'mhc-xmas-icon-function) (call-interactively (extent-property (event-glyph-extent event) 'mhc-xmas-icon-function)) t))) ;; internal variable. (defvar mhc-xmas/icon-glyph-alist nil) (defvar mhc-xmas/icon-function-alist nil) (defsubst mhc-xmas/setup-icons () (let ((alist mhc-xmas-icon-alist)) (setq mhc-xmas/icon-glyph-alist nil) (while alist (setq mhc-xmas/icon-glyph-alist (cons (cons (downcase (car (car alist))) (make-glyph (make-image-instance (vector 'xpm :file (expand-file-name (cdr (car alist)) mhc-icon-path)) nil nil 'no-error))) mhc-xmas/icon-glyph-alist)) (setq alist (cdr alist))) (setq mhc-xmas/icon-function-alist (mapcar (lambda (pair) (cons (downcase (car pair)) (cdr pair))) mhc-icon-function-alist)))) ;; Icon interface (defun mhc-icon-setup () "Initialize MHC icons." (interactive) (if (interactive-p) (setq mhc-xmas/icon-glyph-alist nil)) (or mhc-xmas/icon-glyph-alist (progn (message "Initializing MHC icons...") (mhc-xmas/setup-icons) (run-hooks 'mhc-icon-setup-hook) (message "Initializing MHC icons...done")))) (defun mhc-use-icon-p () "Returns t if MHC displays icon." (and (device-on-window-system-p) (featurep 'xpm) mhc-use-icon)) (defun mhc-icon-exists-p (name) "Returns non-nil if icon with NAME exists." (cdr (assoc (downcase name) mhc-xmas/icon-glyph-alist))) (defun mhc-put-icon (icons) "Put ICONS on current buffer. Icon is decided by `mhc-xmas-icon-alist'." (let (start space extent glyph glyphs) (setq icons (delq nil (mapcar (lambda (icon) (setq glyph (cdr (assoc (downcase icon) mhc-xmas/icon-glyph-alist))) (and glyph (cons glyph (cdr (assoc (downcase icon) mhc-xmas/icon-function-alist))))) icons))) (when icons (setq space (make-string (length icons) ? )) (setq start (point)) (while (setq extent (extent-at (point) nil 'mhc-icon extent 'at)) (setq glyphs (cons (cons (extent-end-glyph extent) (extent-property extent 'mhc-xmas-icon-function)) glyphs))) (insert space space) (setq extent (make-extent start (point))) (set-extent-property extent 'invisible 'mhc-icon)) (setq icons (nreverse icons)) (while icons (setq extent (make-extent (point) (point))) (set-extent-properties extent (list 'mhc-icon t 'keymap mhc-xmas-icon-keymap 'mhc-xmas-icon-function (cdr (car icons)))) (set-extent-end-glyph extent (car (car icons))) (setq icons (cdr icons))) (while glyphs (setq extent (make-extent (point)(point))) (set-extent-properties extent (list 'mhc-icon t 'keymap mhc-xmas-icon-keymap 'mhc-xmas-icon-function (cdr (car glyphs)))) (set-extent-end-glyph extent (car (car glyphs))) (setq glyphs (cdr glyphs))))) (provide 'mhc-xmas) ;;; Copyright Notice: ;; Copyright (C) 1999, 2000 Yoshinari Nomura. All rights reserved. ;; Copyright (C) 2000 MHC developing team. All rights reserved. ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of the team nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' ;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ;; THE TEAM OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, ;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED ;; OF THE POSSIBILITY OF SUCH DAMAGE. ;;; mhc-xmas.el ends here yoshinari-nomura-mhc-815a36a/emacs/mhc.el000066400000000000000000001234621222073515200203050ustar00rootroot00000000000000;;; mhc.el -- MH Calendar. ;; Author: Yoshinari Nomura ;; ;; Created: 1994/07/04 ;; Revised: $Date: 2009/05/31 12:54:50 $ ;;; ;;; Commentay: ;;; ;; Mhc is the personal schedule management package cooperating ;; with Mew, Wanderlust or Gnus. ;; ;; Minimum setup: ;; ;; for Mew user: ;; (autoload 'mhc-mew-setup "mhc-mew") ;; (add-hook 'mew-init-hook 'mhc-mew-setup) ;;; optional setting for Mew-1.94 (Raw JIS header decoding) ;; (add-hook 'mew-message-hook 'mhc-mew-decode-header) ;; ;; for Wanderlust user: ;; (autoload 'mhc-wl-setup "mhc-wl") ;; (add-hook 'wl-init-hook 'mhc-wl-setup) ;; ;; for Gnus user: ;; (autoload 'mhc-gnus-setup "mhc-gnus") ;; (add-hook 'gnus-startup-hook 'mhc-gnus-setup) (eval-when-compile (require 'cl)) ;; For Mule 2.3 (eval-and-compile (when (boundp 'MULE) (require 'poe) (require 'pcustom))) (require 'mhc-vars) (require 'mhc-record) (require 'mhc-file) (require 'mhc-db) (require 'mhc-misc) (require 'mhc-date) (require 'mhc-guess) (require 'mhc-schedule) (require 'mhc-face) (require 'mhc-calendar) (require 'mhc-draft) (cond ((eval-when-compile (and (not (featurep 'xemacs)) (>= emacs-major-version 21) (if (eq system-type 'windows-nt) ;; Meadow2 or NTEmacs21.3(and the later ;; version) supports the image feature. (or (featurep 'meadow) (>= emacs-major-version 22) (>= emacs-minor-version 3)) t))) (require 'mhc-e21)) ((eval-when-compile (condition-case nil (require 'bitmap) (error nil))) (require 'mhc-bm)) ((eval-when-compile (featurep 'xemacs)) (require 'mhc-xmas)) (t (defun mhc-use-icon-p ()))) (require 'mhc-minibuf) (require 'mhc-summary) (provide 'mhc) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Menu setup ;; (defvar mhc-mode-menu-spec '("Mhc" ["This month" mhc-goto-this-month t] ["Next month" mhc-goto-next-month t] ["Prev month" mhc-goto-prev-month t] ["Goto month" mhc-goto-month t] ["Goto date" mhc-goto-date t] ["Import" mhc-import t] ["Set category" mhc-set-default-category t] "----" ["Goto today" mhc-goto-today (mhc-summary-buffer-p)] ["Modify" mhc-modify (mhc-summary-buffer-p)] ["Edit" mhc-edit (mhc-summary-buffer-p)] ["Rescan" mhc-rescan-month (mhc-summary-buffer-p)] ["Delete" mhc-delete (mhc-summary-buffer-p)] ["Insert Schedule" mhc-insert-schedule (not buffer-read-only)] ["3 months Mini calendar" mhc-calendar t] ["Toggle 3 months calendar" mhc-calendar-toggle-insert-rectangle (mhc-summary-buffer-p)] "----" ["Reset" mhc-reset (mhc-summary-buffer-p)] ("Network" ["Online" mhc-file-toggle-offline mhc-file/offline] ["Offline" mhc-file-toggle-offline (not mhc-file/offline)] ["Sync" mhc-file-sync (and (not (and mhc-file/offline (not mhc-file-sync-enable-offline))) (if (eq mhc-file-method 'mhc-sync) (and (stringp mhc-sync-remote) (stringp mhc-sync-id)) mhc-file-method))]) "----" ("PostScript" ["PostScript" mhc-ps t] ["Preview" mhc-ps-preview t] ["Print" mhc-ps-print t] ["Save" mhc-ps-save t] ["Insert buffer" mhc-ps-insert-buffer t]))) (defvar mhc-prefix-key "\C-c." "*Prefix key to call MHC functions.") (defvar mhc-mode-map nil "Keymap for `mhc-mode'.") (defvar mhc-prefix-map nil "Keymap for 'mhc-key-prefix'.") (if (and mhc-mode-map mhc-prefix-map) () (setq mhc-mode-map (make-sparse-keymap)) (setq mhc-prefix-map (make-sparse-keymap)) (define-key mhc-prefix-map "g" 'mhc-goto-month) (define-key mhc-prefix-map "j" 'mhc-goto-date) (define-key mhc-prefix-map "." 'mhc-goto-this-month) (define-key mhc-prefix-map "n" 'mhc-goto-next-month) (define-key mhc-prefix-map "N" 'mhc-goto-next-year) (define-key mhc-prefix-map "p" 'mhc-goto-prev-month) (define-key mhc-prefix-map "P" 'mhc-goto-prev-year) (define-key mhc-prefix-map "f" 'mhc-goto-today) (define-key mhc-prefix-map "|" 'mhc-import) (define-key mhc-prefix-map "m" 'mhc-modify) (define-key mhc-prefix-map "e" 'mhc-edit) (define-key mhc-prefix-map "s" 'mhc-rescan-month) (define-key mhc-prefix-map "d" 'mhc-delete) (define-key mhc-prefix-map "c" 'mhc-set-default-category) (define-key mhc-prefix-map "i" 'mhc-insert-schedule) (define-key mhc-prefix-map "?" 'mhc-calendar) (define-key mhc-prefix-map "t" 'mhc-calendar-toggle-insert-rectangle) (define-key mhc-prefix-map "T" 'mhc-file-toggle-offline) (define-key mhc-prefix-map "S" 'mhc-file-sync) (define-key mhc-prefix-map "R" 'mhc-reset) (define-key mhc-prefix-map "@" 'mhc-todo-toggle-done) (define-key mhc-mode-map mhc-prefix-key mhc-prefix-map) (cond ((featurep 'xemacs) (define-key mhc-mode-map [(button1)] 'mhc-calendar-mouse-goto-date) (define-key mhc-mode-map [(button2)] 'mhc-calendar-mouse-goto-date-view)) (t (define-key mhc-mode-map [mouse-1] 'mhc-calendar-mouse-goto-date) (define-key mhc-mode-map [mouse-2] 'mhc-calendar-mouse-goto-date-view)))) (defvar mhc-mode nil "Non-nil when in mhc-mode.") (defcustom mhc-mode-hook nil "Hook run in when entering MHC mode." :group 'mhc :type 'hook) ;; Avoid warning of byte-compiler. (defvar mhc-mode-menu) (eval-and-compile (autoload 'easy-menu-add "easymenu")) (defun mhc-mode (&optional arg) "\ \\ MHC is the mode for registering schdule directly from email. Requres Mew or Wanderlust or Gnus. Key assinment on mhc-mode. \\[mhc-goto-this-month] Review the schedule of this month \\[mhc-goto-next-month] Review the schedule of next month \\[mhc-goto-prev-month] Review the schedule of previous month \\[mhc-goto-month] Jump to your prefer month \\[mhc-goto-date] Jump to your prefer date \\[mhc-rescan-month] Rescan the buffer of the month \\[mhc-goto-today] Move cursor to today (Only available reviewing this month) \\[mhc-import] Register the reviewing mail to schdule \\[mhc-delete] Delete the schdule on the cursor line \\[mhc-set-default-category] Edit the schdule on the cursor line \\[mhc-modify] Modify the schdule on the cursor line \\[mhc-edit] Create new schdule file \\[mhc-set-default-category] Change default category \\[mhc-calendar] Display 3 months mini calendar \\[mhc-calendar-toggle-insert-rectangle] Toggle 3 months calendar \\[mhc-reset] Reset MHC '\\[universal-argument]' prefix is available on using '\\[mhc-rescan-month]', '\\[mhc-goto-this-month]', '\\[mhc-goto-month]', '\\[mhc-goto-date]' , it works to assign the category (see below). The prefix arg '\\[mhc-goto-next-month]', '\\[mhc-goto-prev-month]' is also available and you can indicate the number of months to forward/back. Field names using by MHC. X-SC-Category: Space-seperated Keywords. You can set default category to scan. You can also indicate keywords by typing '\\[mhc-rescan-month]', '\\[mhc-goto-this-month]', '\\[mhc-goto-month]', '\\[mhc-goto-date]' with C-u. " (interactive "P") (make-local-variable 'mhc-mode) (setq mhc-mode (if (null arg) (not mhc-mode) (> (prefix-numeric-value arg) 0))) (when (featurep 'xemacs) (easy-menu-add mhc-mode-menu)) (force-mode-line-update) (run-hooks 'mhc-mode-hook)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; lexical analyzer part for category. ;; (defsubst mhc-expr/new () (vector nil nil nil nil)) (defsubst mhc-expr/token (expr-obj) ;; literal (aref expr-obj 0)) (defsubst mhc-expr/token-type (expr-obj) ;; symbolized (aref expr-obj 1)) (defsubst mhc-expr/string (expr-obj) ;; currently parsing string. (aref expr-obj 2)) (defsubst mhc-expr/set-token (expr-obj val) (aset expr-obj 0 val)) (defsubst mhc-expr/set-token-type (expr-obj val) (aset expr-obj 1 val)) (defsubst mhc-expr/set-string (expr-obj val) (aset expr-obj 2 val)) (defconst mhc-expr-token-type-alist '( ("[^!&|()\t \n]+" . symbol) ("!" . negop) ("&&" . andop) ("||" . orop) ("(" . lparen) (")" . rparen))) ;; Eat one token from parsing string in obj. (defun mhc-expr/gettoken (obj) (let ((string (mhc-expr/string obj)) (token-alist mhc-expr-token-type-alist) (token-type nil) (token nil)) ;; delete leading white spaces. (if (string-match "^[\t ]+" string) (setq string (substring string (match-end 0)))) (while (and token-alist (not token-type)) (if (string-match (concat "^" (car (car token-alist))) string) (setq token (substring string 0 (match-end 0)) string (substring string (match-end 0)) token-type (cdr (car token-alist)))) (setq token-alist (cdr token-alist))) (mhc-expr/set-token obj token) (mhc-expr/set-string obj string) (mhc-expr/set-token-type obj token-type) obj)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; recursive descent parser for category. ;; ;; ;; expression -> term ("||" term)* ;; (defun mhc-expr/expression (obj) (let ((ret (list (mhc-expr/term obj)))) (while (eq (mhc-expr/token-type obj) 'orop) (mhc-expr/gettoken obj) (setq ret (cons (mhc-expr/term obj) ret))) (if (= 1 (length ret)) (car ret) (cons 'or (nreverse ret))))) ;; ;; term -> factor ("&&" factor)* ;; (defun mhc-expr/term (obj) (let ((ret (list (mhc-expr/factor obj)))) (while (eq (mhc-expr/token-type obj) 'andop) (mhc-expr/gettoken obj) (setq ret (cons (mhc-expr/factor obj) ret))) (if (= 1 (length ret)) (car ret) (cons 'and (nreverse ret))))) ;; ;; factor -> "!"* category_name || "(" expression ")" ;; (defun mhc-expr/factor (obj) (let ((ret) (neg-flag nil)) (while (eq (mhc-expr/token-type obj) 'negop) (setq neg-flag (not neg-flag)) (mhc-expr/gettoken obj)) (cond ;; symbol ((eq (mhc-expr/token-type obj) 'symbol) (setq ret (list 'mhc-schedule-in-category-p 'schedule (mhc-expr/token obj))) (mhc-expr/gettoken obj)) ;; ( expression ) ((eq (mhc-expr/token-type obj) 'lparen) (mhc-expr/gettoken obj) (setq ret (mhc-expr/expression obj)) (if (not (eq (mhc-expr/token-type obj) 'rparen)) (error "Syntax error.")) (mhc-expr/gettoken obj)) ;; error (t (error "Syntax error.") ;; (error "Missing category name or `(' %s %s" ;; mhc-expr-token mhc-expr-parsing-string) )) (if neg-flag (list 'not ret) ret))) (defun mhc-expr-parse (string) (let ((obj (mhc-expr/new)) (ret nil)) (if (or (not string) (string= string "")) t (mhc-expr/set-string obj string) (mhc-expr/gettoken obj) (setq ret (mhc-expr/expression obj)) (if (mhc-expr/token obj) (error "Syntax Error.") ret)))) (defun mhc-expr-compile (string) (byte-compile `(lambda (schedule) ,(mhc-expr-parse string) ))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; category ;; (defvar mhc-default-category nil) (defvar mhc-default-category-predicate-sexp (mhc-expr-compile "")) (defvar mhc-default-category-hist nil) (defun mhc-set-default-category () (interactive) (setq mhc-default-category (read-from-minibuffer "Default Category: " (or mhc-default-category "") nil nil 'mhc-default-category-hist)) (setq mhc-default-category-predicate-sexp (mhc-expr-compile mhc-default-category)) (if (mhc-summary-buffer-p) (mhc-rescan-month))) ; (defun mhc-category-convert (lst) ; (let (ret inv) ; ;; preceding `!' means invert logic. ; (if (and lst (string-match "^!" (car lst))) ; (setq lst (cons (substring (car lst) (match-end 0)) (cdr lst)) ; inv t)) ; (cons inv lst))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; goto-* (defun mhc-goto-month (&optional date hide-private) "*Show schedules of specified month. If HIDE-PRIVATE, priavate schedules are suppressed." (interactive (list (mhc-input-month "Month ") (if mhc-default-hide-private-schedules (not current-prefix-arg) current-prefix-arg))) (mhc-scan-month date (mhc-summary-mailer-type) mhc-default-category-predicate-sexp hide-private)) (defvar mhc-goto-date-func 'mhc-goto-date-calendar) ; or mhc-goto-date-summary (defun mhc-goto-date (&optional hide-private) "*Show schedules of specified date. If HIDE-PRIVATE, private schedules are suppressed." (interactive (list (if mhc-default-hide-private-schedules (not current-prefix-arg) current-prefix-arg))) (let* ((owin (get-buffer-window (current-buffer))) (buf (mhc-summary-get-import-buffer)) (win (if buf (get-buffer-window buf) nil)) date) (save-excursion (when win (select-window win)) (setq date (car (mhc-input-day "Date: " (mhc-date-now) (mhc-guess-date)))) (select-window owin)) (funcall mhc-goto-date-func date hide-private))) (defun mhc-goto-date-calendar (date hide-private) (mhc-calendar-goto-month date)) (defun mhc-goto-date-summary (date hide-private) ;; XXX mhc-calendar-scanのパクリです (mhc-goto-month date hide-private) (goto-char (point-min)) (if (mhc-summary-search-date date) (progn (beginning-of-line) (if (not (pos-visible-in-window-p (point))) (recenter))))) (defun mhc-goto-this-month (&optional hide-private) "*Show schedules of this month. If HIDE-PRIVATE, private schedules are suppressed." (interactive (list (if mhc-default-hide-private-schedules (not current-prefix-arg) current-prefix-arg))) (mhc-goto-month (mhc-date-now) hide-private)) (defun mhc-goto-next-month (&optional arg) (interactive "p") (mhc-goto-month (mhc-date-mm+ (or (mhc-current-date-month) (mhc-date-now)) arg) mhc-default-hide-private-schedules)) (defun mhc-goto-next-year (&optional arg) (interactive "p") (mhc-goto-next-month (* (or arg 1) 12))) (defun mhc-goto-prev-month (&optional arg) (interactive "p") (mhc-goto-next-month (- arg))) (defun mhc-goto-prev-year (&optional arg) (interactive "p") (mhc-goto-next-year (- arg))) (defun mhc-goto-today (&optional no-display) "*Go to the line of today's schedule or first day of month. Unless NO-DISPLAY, display it." (interactive "P") (let ((now (mhc-date-now)) (buf-date (mhc-current-date-month))) (when buf-date (goto-char (point-min)) (mhc-date-let now (if (and (= yy (mhc-date-yy buf-date)) (= mm (mhc-date-mm buf-date))) (when (mhc-summary-search-date now) (forward-line 0) (or (pos-visible-in-window-p (point)) (recenter)) (or no-display (mhc-summary-display-article))) (when (and mhc-use-wide-scope (mhc-summary-search-date (mhc-date-mm-first buf-date))) (forward-line 0) (or (pos-visible-in-window-p (point)) (recenter)) (or no-display (mhc-summary-display-article))))) ;; Emacs-21.3.50 something wrong (beginning-of-line)))) (defun mhc-rescan-month (&optional hide-private) "*Rescan schedules of this buffer. If HIDE-PRIVATE, private schedules are suppressed." (interactive (list (if mhc-default-hide-private-schedules (not current-prefix-arg) current-prefix-arg))) (move-to-column 1) (let ((line (+ (count-lines (point-min) (point)) (if (= (current-column) 0) 1 0)))) (mhc-scan-month (or (mhc-current-date-month) (mhc-date-now)) (mhc-summary-mailer-type) mhc-default-category-predicate-sexp hide-private) (goto-line line) (beginning-of-line))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; make scan form. (defvar mhc-face-week-color-paint-thick nil) (defvar mhc-summary-buffer-current-date-month nil "Indicate summary buffer's month. It is also used by mhc-summary-buffer-p") (make-variable-buffer-local 'mhc-summary-buffer-current-date-month) (defun mhc-scan-month (date mailer category-predicate secret) (let ((from (mhc-date-mm-first date)) (to (mhc-date-mm-last date)) (today (mhc-date-now)) bfrom bto afrom ato wweek0 wweek1 wweek2) (or (eq 'direct mailer) (mhc-summary-generate-buffer date mailer)) (when mhc-use-wide-scope (if (and mhc-use-week-separator (not (eq (mhc-end-day-of-week) 0))) (setq wweek0 0 wweek1 6 wweek2 7) (setq wweek0 1 wweek1 0 wweek2 8)) (cond ((integerp mhc-use-wide-scope) (setq bfrom (mhc-date- from mhc-use-wide-scope)) (setq bto (mhc-date-mm-last bfrom)) (setq ato (mhc-date+ to mhc-use-wide-scope)) (setq afrom (mhc-date-mm-first ato))) ((eq mhc-use-wide-scope 'week) (if (eq (mhc-date-ww from) wweek0) (setq bfrom nil bto nil) (setq bfrom (mhc-date+ (mhc-date- from 7) (% (mhc-date- wweek2 (mhc-date-ww from)) 7))) (setq bto (mhc-date-mm-last bfrom))) (if (eq (mhc-date-ww to) wweek1) (setq afrom nil ato nil) (setq ato (mhc-date+ to (mhc-date- wweek2 (mhc-date-ww to) 1))) (setq afrom (mhc-date-mm-first ato)))) ((eq mhc-use-wide-scope 'wide) (if (eq (mhc-date-ww from) wweek0) (setq bfrom (mhc-date- from 7)) (setq bfrom (mhc-date+ (mhc-date- from 7) (% (mhc-date- wweek2 (mhc-date-ww from)) 7)))) (setq bto (mhc-date-mm-last bfrom)) (if (eq (mhc-date-ww to) wweek1) (setq ato (mhc-date+ to 7)) (setq ato (mhc-date+ to (mhc-date- wweek2 (mhc-date-ww to) 1)))) (setq afrom (mhc-date-mm-first ato))))) (message "%s" (mhc-date-format date "Scanning %04d/%02d..." yy mm)) (unless (eq 'direct mailer) (when (and (eq mhc-todo-position 'top) (or mhc-insert-todo-list mhc-insert-memo-list)) (mhc-summary-make-todo-memo today mailer category-predicate secret) (insert (make-string mhc-todo-mergin ?\n)) (mhc-summary/insert-separator)) (setq mhc-summary-buffer-current-date-month (mhc-date-mm-first date))) (when (and bfrom bto) (mhc-summary-make-contents bfrom bto mailer category-predicate secret) (if mhc-use-month-separator (mhc-summary/insert-separator 'wide (when (eq (mhc-end-day-of-week) (mhc-date-ww bto)) (if mhc-summary/cw-separator (format " CW %d " (mhc-date-cw (mhc-date++ bto))) (make-string (length " CW 00 ") mhc-summary-month-separator)))) (if (and mhc-use-week-separator (eq (mhc-end-day-of-week) (mhc-date-ww bto))) (mhc-summary/insert-separator nil (when mhc-summary/cw-separator (format " CW %d " (mhc-date-cw (mhc-date++ bto)))))))) (mhc-summary-make-contents from to mailer category-predicate secret) (when (and afrom ato) (if mhc-use-month-separator (mhc-summary/insert-separator 'wide (when (eq mhc-start-day-of-week (mhc-date-ww afrom)) (if mhc-summary/cw-separator (format " CW %d " (mhc-date-cw afrom)) (make-string (length " CW 00 ") mhc-summary-month-separator)))) (if (and mhc-use-week-separator (eq mhc-start-day-of-week (mhc-date-ww afrom))) (mhc-summary/insert-separator nil (when mhc-summary/cw-separator (format " CW %d " (mhc-date-cw afrom)))))) (mhc-summary-make-contents afrom ato mailer category-predicate secret)) (unless (eq 'direct mailer) (when (and (eq mhc-todo-position 'bottom) (or mhc-insert-todo-list mhc-insert-memo-list)) (mhc-summary/insert-separator) (insert (make-string mhc-todo-mergin ?\n)) (mhc-summary-make-todo-memo today mailer category-predicate secret)) (when mhc-insert-calendar (mhc-calendar-insert-rectangle-at date (- (mhc-misc-get-width) mhc-calendar-width) mhc-vertical-calendar-length)) (mhc-summary-mode-setup date mailer) (mhc-mode 1) (setq inhibit-read-only nil) (setq buffer-read-only t) (set-buffer-modified-p nil) (setq mhc-summary-buffer-current-date-month (mhc-date-mm-first date)) (mhc-goto-today t) (message "%s" (mhc-date-format date "Scanning %04d/%02d...done" yy mm))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; import, edit, delete, modify (defcustom mhc-input-sequences '(date time subject location category recurrence-tag alarm) "*Sequence of the inputs." :group 'mhc :type '(repeat (choice (const :tag "Date" date) (const :tag "Time" time) (const :tag "Subject" subject) (const :tag "Location" location) (const :tag "Category" category) (const :tag "Recurrence tag" recurrence-tag) (const :tag "Alarm" alarm)))) (defun mhc-edit (&optional import-buffer) "Edit a new schedule. If optional argument IMPORT-BUFFER is specified, import its content. Returns t if the importation was succeeded." (interactive (if current-prefix-arg (list (get-buffer (read-buffer "Import buffer: " (current-buffer)))))) (let ((draft-buffer (generate-new-buffer mhc-draft-buffer-name)) (current-date (or (mhc-current-date) (mhc-calendar-get-date) (mhc-date-now))) (succeed t) msgp date time subject location category recurrence-tag priority alarm) (and (interactive-p) (mhc-window-push)) (set-buffer draft-buffer) (if import-buffer (progn (insert-buffer (if (consp import-buffer) (cdr import-buffer) import-buffer)) (mhc-header-narrowing (setq msgp (or (mhc-header-get-value "from") (mhc-header-get-value "x-sc-subject"))) (mhc-header-delete-header (concat "^\\(" (mhc-regexp-opt mhc-draft-unuse-hdr-list) "\\)") 'regexp)) (mhc-highlight-message) (switch-to-buffer draft-buffer t))) (condition-case () (if import-buffer (progn (delete-other-windows) (if (y-or-n-p "Do you want to import this article? ") (let* ((original (save-excursion (set-buffer (if (consp import-buffer) (cdr import-buffer) import-buffer)) (mhc-parse-buffer))) (schedule (car (mhc-record-schedules original))) (inputs (copy-sequence mhc-input-sequences)) input) (while (setq input (car inputs)) (setq inputs (delq input inputs)) (cond ((eq input 'date) ;; input date (setq date (mhc-input-day "Date: " current-date (mhc-guess-date)))) ((eq input 'time) ;; input time (setq time (mhc-input-time "Time: " (mhc-schedule-time-as-string schedule) (mhc-guess-time (mhc-minibuf-candidate-nth-begin))))) ((eq input 'subject) ;; input subject (setq subject (mhc-input-subject "Subject: " (mhc-misc-sub (or (mhc-record-subject original) (mhc-header-narrowing (mhc-header-get-value "subject"))) "^\\(Re:\\)? *\\(\\[[^\]]+\\]\\)? *" "")))) ((eq input 'location) ;; input location (setq location (mhc-input-location "Location: " (mhc-schedule-location schedule)))) ((eq input 'category) ;; input category (setq category (mhc-input-category "Category: " (mhc-schedule-categories-as-string schedule)))) ;; input recurrence tag ((eq input 'recurrence-tag) (setq recurrence-tag (mhc-input-recurrence-tag "Recurrence Tag: " (mhc-schedule-recurrence-tag-as-string schedule)))) ;; input alarm ((eq input 'alarm) (if mhc-ask-alarm (setq alarm (mhc-input-alarm "Alarm: " mhc-default-alarm)))))) ;; (setq priority (mhc-schedule-priority schedule))) ;; Answer was no. (message "") ; flush minibuffer. (and (interactive-p) (mhc-window-pop)) (setq succeed nil) (kill-buffer draft-buffer))) ;; No import (it succeeds). (let ((inputs (copy-sequence mhc-input-sequences)) input) (while (setq input (car inputs)) (setq inputs (delq input inputs)) (cond ((eq input 'date) (setq date (mhc-input-day "Date: " current-date))) ((eq input 'time) (setq time (mhc-input-time "Time: "))) ((eq input 'subject) (setq subject (mhc-input-subject "Subject: "))) ((eq input 'location) (setq location (mhc-input-location "Location: "))) ((eq input 'category) (setq category (mhc-input-category "Category: "))) ((eq input 'recurrence-tag) (setq recurrence-tag (mhc-input-recurrence-tag "Recurrence Tag: " (or subject "")))) ((eq input 'alarm) (if mhc-ask-alarm (setq alarm (mhc-input-alarm "Alarm: " mhc-default-alarm)))))))) ;; Quit. (quit (and (interactive-p) (mhc-window-pop)) (setq succeed nil) (kill-buffer draft-buffer))) (if succeed (progn (switch-to-buffer draft-buffer t) (set-buffer draft-buffer) (if (and import-buffer msgp) (if (consp import-buffer) (mhc-draft-reedit-buffer (car import-buffer) 'original) ;; Delete candidate overlay if exists. (if mhc-minibuf-candidate-overlay (delete-overlay mhc-minibuf-candidate-overlay)) ;; Already imported to current buffer. (mhc-draft-reedit-buffer (current-buffer))) ;; Delete candidate overlay if exists. (if mhc-minibuf-candidate-overlay (delete-overlay mhc-minibuf-candidate-overlay)) (mhc-draft-setup-new)) (mhc-header-narrowing (mhc-header-delete-header (concat "^\\(" (mhc-regexp-opt (mhc-header-list)) "\\)") 'regexp)) (goto-char (point-min)) (insert "X-SC-Subject: " subject "\nX-SC-Location: " location "\nX-SC-Day: " (mapconcat (lambda (day) (mhc-date-format day "%04d%02d%02d" yy mm dd)) date " ") "\nX-SC-Time: " (if time (let ((begin (car time)) (end (nth 1 time))) (concat (if begin (mhc-time-to-string begin) "") (if end (concat "-" (mhc-time-to-string end)) ""))) "") "\nX-SC-Category: " (mapconcat (function capitalize) category " ") "\nX-SC-Priority: " (if priority (number-to-string priority) "") "\nX-SC-Recurrence-Tag: " recurrence-tag "\nX-SC-Cond: " "\nX-SC-Duration: " "\nX-SC-Alarm: " (or alarm "") "\nX-SC-Record-Id: " (mhc-record-create-id) "\n") (goto-char (point-min)) (mhc-draft-mode) succeed)))) (defcustom mhc-default-import-original-article nil "*If non-nil value, import a schedule with MIME attachements." :group 'mhc :type 'boolean) (defun mhc-import (&optional get-original) "Import a schedule from the current article. The default action of this command is to import a schedule from the current article without MIME attachements. If you want to import a schedule including MIME attachements, call this command with a prefix argument. Set non-nil to `mhc-default-import-original-article', and the default action of this command is changed to the latter." (interactive (list (if mhc-default-import-original-article (not current-prefix-arg) current-prefix-arg))) (mhc-window-push) (unless (mhc-edit (mhc-summary-get-import-buffer get-original)) ;; failed. (mhc-window-pop))) (defun mhc-import-from-region (s e) "Import a schedule from region." (interactive "r") (save-restriction (narrow-to-region s e) (let ((str (buffer-substring s e))) (mhc-import) (goto-char (point-max)) (insert str) (goto-char (point-min))))) (defun mhc-delete () "Delete the current schedule." (interactive) (mhc-delete-file (mhc-summary-record))) (defcustom mhc-delete-file-hook nil "Normal hook run after mhc-delete-file." :group 'mhc :type 'hook) (defun mhc-delete-file (record) (interactive) (if (not (and record (file-exists-p (mhc-record-name record)))) (message "File does not exist (%s)." (mhc-record-name record)) (if (not (y-or-n-p (format "Do you delete %s ?" (mhc-record-subject-as-string record)))) (message "Never mind..") (if (and (mhc-record-occur-multiple-p record) (not (y-or-n-p (format "%s has multiple occurrences. Delete all(=y) or one(=n) ?" (mhc-record-subject-as-string record))))) (mhc-db-add-exception-rule record (or (mhc-current-date) (mhc-calendar-view-date))) (mhc-db-delete-file record)) (or (and (mhc-summary-buffer-p) (mhc-rescan-month mhc-default-hide-private-schedules)) (and (mhc-calendar-p) (mhc-calendar-rescan))) (run-hooks 'mhc-delete-file-hook)))) (defun mhc-modify () "Modify the current schedule." (interactive) (mhc-modify-file (mhc-summary-filename))) (defun mhc-todo-set-as-done () "Set TODO as DONE." (interactive) (mhc-modify-file (mhc-summary-filename)) (mhc-draft-set-as-done) (mhc-draft-finish) (message "")) (defun mhc-todo-set-as-not-done () "Set TODO as NOT-DONE." (interactive) (mhc-modify-file (mhc-summary-filename)) (mhc-draft-set-as-not-done) (mhc-draft-finish) (message "")) (defun mhc-todo-toggle-done () "Toggle between done and not for todo" (interactive) (mhc-modify-file (mhc-summary-filename)) (mhc-draft-toggle-done) (mhc-draft-finish) (message "")) (defcustom mhc-browse-x-url-function 'browse-url "*A function to browse URL." :group 'mhc :type 'function) (defun mhc-browse-x-url () "Browse X-URL field." (interactive) (let ((filename (mhc-summary-filename)) url) (with-temp-buffer (insert-file-contents filename) (if (setq url (mhc-header-narrowing (or (mhc-header-get-value "x-uri") (mhc-header-get-value "x-url")))) (progn (funcall mhc-browse-x-url-function url) (message "X-URL browser started.")) (message "No X-URL field."))))) (defun mhc-modify-file (file) (if (and (stringp file) (file-exists-p file)) (let* ((name (format "*mhc draft %s/%s*" mhc-base-folder (file-relative-name file (file-name-as-directory (mhc-summary-folder-to-path mhc-base-folder))))) (buffer (get-buffer name))) (if (buffer-live-p buffer) (progn (message "Specified file(%s) has already been opened." file) (switch-to-buffer-other-window buffer)) (mhc-window-push) (set-buffer (setq buffer (get-buffer-create name))) (mhc-draft-reedit-file file) (set-buffer-modified-p nil) (switch-to-buffer-other-window buffer) (goto-char (point-min)) (mhc-draft-mode) (set (make-local-variable 'mhc-draft-buffer-file-name) file))) (message "Specified file(%s) does not exist." file))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Window stack ;; (defvar mhc-window-stack nil) (defun mhc-window-push () (interactive) (setq mhc-window-stack (cons (current-window-configuration) mhc-window-stack))) (defun mhc-window-pop () (interactive) (if mhc-window-stack (set-window-configuration (car-safe mhc-window-stack))) (setq mhc-window-stack (cdr-safe mhc-window-stack))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; (Category . (parent-face fg bg)) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; manipulate data from mhc-summary-buffer. (defconst mhc-summary-day-regex "\\([^|]+| +\\)?[0-9]+/\\([0-9]+\\)") (defconst mhc-summary-buf-regex (concat mhc-base-folder "/\\([0-9]+\\)/\\([0-9]+\\)")) ;(defun mhc-summary-buffer-p (&optional buffer) ; (string-match mhc-summary-buf-regex ; (buffer-name ; (or buffer (current-buffer))))) (defun mhc-summary-buffer-p (&optional buffer) (if buffer (set-buffer buffer)) mhc-summary-buffer-current-date-month) (defun mhc-current-date () (when (mhc-summary-buffer-p) (let ((dayinfo (get-text-property (point) 'mhc-dayinfo))) (or (and dayinfo (mhc-day-date dayinfo)) (save-excursion (end-of-line) (while (and (not (bobp)) (null dayinfo)) (or (setq dayinfo (get-text-property (point) 'mhc-dayinfo)) (forward-char -1))) (and dayinfo (mhc-day-date dayinfo))))))) ; (defun mhc-current-date-month () ; (let ((buf (buffer-name)) yy mm dd) ; (if (not (string-match mhc-summary-buf-regex buf)) ; nil ; (mhc-date-new (string-to-number (match-string 1 buf)) ; (string-to-number (match-string 2 buf)) ; 1)))) (defun mhc-current-date-month () mhc-summary-buffer-current-date-month) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; misc. ;; ;; Convinient function when you want to insert your schedule into an ;; editing buffer. ;; (defun mhc-insert-schedule (&optional hide-private) (interactive "P") (set-mark (point)) (mhc-scan-month (mhc-input-month "Month ") 'direct ;; insert into current buffer. mhc-default-category-predicate-sexp hide-private) (exchange-point-and-mark)) (defun mhc-view-file () "View the schedule on the current line in View mode in another window." (interactive) (let ((path (mhc-summary-filename))) (view-file-other-window path))) ;;; Temporary buffers (defvar mhc-tmp-buffer-list nil) (defun mhc-get-buffer-create (name) "Return buffer for temporary use of MHC." (let ((buf (get-buffer name))) (or (and buf (buffer-name buf)) (progn (setq buf (get-buffer-create name) mhc-tmp-buffer-list (cons buf mhc-tmp-buffer-list)) (buffer-disable-undo buf))) buf)) (defun mhc-kill-all-buffers () "Kill all buffers for temporary use of MHC." (while mhc-tmp-buffer-list (if (buffer-name (car mhc-tmp-buffer-list)) (kill-buffer (car mhc-tmp-buffer-list))) (setq mhc-tmp-buffer-list (cdr mhc-tmp-buffer-list)))) ;;; Setup and exit (defcustom mhc-setup-hook nil "Run hook after mhc-setup." :group 'mhc :type 'hook) (defvar mhc-setup-p nil) (defun mhc-setup () (unless mhc-setup-p (condition-case nil (progn (or (featurep 'easymenu) (require 'easymenu)) (easy-menu-define mhc-mode-menu mhc-mode-map "Menu used in mhc mode." mhc-mode-menu-spec) (easy-menu-define mhc-calendar-mode-menu mhc-calendar-mode-map "Menu used in mhc calendar mode." mhc-calendar-mode-menu-spec)) (error nil)) (or (assq 'mhc-mode minor-mode-alist) (setq minor-mode-alist (cons (list 'mhc-mode (mhc-file-line-status)) minor-mode-alist))) (or (assq 'mhc-mode minor-mode-map-alist) (setq minor-mode-map-alist (cons (cons 'mhc-mode mhc-mode-map) minor-mode-map-alist))) (mhc-face-setup) (mhc-calendar-setup) (mhc-file-setup) (setq mhc-default-category-predicate-sexp (mhc-expr-compile mhc-default-category)) (and (mhc-use-icon-p) (mhc-icon-setup)) (and mhc-calendar-link-hnf (mhc-calendar-hnf-face-setup)) (mhc-summary-line-inserter-setup) (mhc-guess-location-setup) (autoload 'mhc-ps "mhc-ps" "*Create PostScript calendar with selected method." t) (autoload 'mhc-ps-preview "mhc-ps" "*Preview PostScript calendar." t) (autoload 'mhc-ps-print "mhc-ps" "*Print PostScript calendar." t) (autoload 'mhc-ps-save "mhc-ps" "*Save PostScript calendar." t) (autoload 'mhc-ps-insert-buffer "mhc-ps" "*Insert PostScript calendar." t) (setq mhc-setup-p t) (run-hooks 'mhc-setup-hook))) (defun mhc-reset () "Reset MHC." (interactive) (message "MHC resetting...") (mhc-slot-clear-cache) (mhc-face-setup) (mhc-calendar-setup) (and (mhc-use-icon-p) (mhc-icon-setup)) (and mhc-calendar-link-hnf (mhc-calendar-hnf-face-setup)) (mhc-summary-line-inserter-setup) (mhc-guess-location-setup) (or (and (mhc-summary-buffer-p) (mhc-rescan-month mhc-default-hide-private-schedules)) (and (mhc-calendar-p) (mhc-calendar-rescan))) (message "MHC resetting...done")) (defcustom mhc-exit-hook nil "Run hook after mhc-exit." :group 'mhc :type 'hook) (defun mhc-exit () (setq mhc-setup-p nil) (mhc-file-exit) (mhc-slot-clear-cache) (mhc-kill-all-buffers) (run-hooks 'mhc-exit-hook)) (defun mhc-version () "Show mhc version." (interactive) (message mhc-version)) ;;; Copyright Notice: ;; Copyright (C) 1999, 2000 Yoshinari Nomura. All rights reserved. ;; Copyright (C) 2000 MHC developing team. All rights reserved. ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of the team nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' ;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ;; THE TEAM OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, ;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED ;; OF THE POSSIBILITY OF SUCH DAMAGE. ;;; mhc.el ends here yoshinari-nomura-mhc-815a36a/emacs/nnmhc.el000066400000000000000000000117511222073515200206360ustar00rootroot00000000000000;;; -*- mode: Emacs-Lisp; coding: utf-8 -*- ;; Author: TSUCHIYA Masatoshi ;; Created: 2000/05/17 ;; Revised: $Date$ ;;; Commentary: ;; This file is a part of MHC, and includes the simplest Gnus backend ;; for MHC. ;;; Code: (require 'nnheader) (require 'nnmail) (require 'nnoo) (eval-when-compile (require 'cl)) (gnus-declare-backend "nnmhc" 'physical-address) (nnoo-declare nnmhc) ;;; Internal Variables: (defvoo nnmhc-article-list nil) (defvoo nnmhc-status-string "" nil) (defvar nnmhc-file-coding-system (if (boundp 'MULE) '*noconv* 'raw-text)) ;;; Interface functions: (nnoo-define-basics nnmhc) (defmacro nnmhc-get-article (num) `(car (nth (1- ,num) nnmhc-article-list))) (defmacro nnmhc-get-subject (num) `(cdr (nth (1- ,num) nnmhc-article-list))) (deffoo nnmhc-retrieve-headers (sequence &optional group server fetch-old) (when (integerp (car sequence)) (save-excursion (set-buffer nntp-server-buffer) (delete-region (point-min) (point-max)) (let ((pathname-coding-system 'binary) file begin) (dolist (article sequence) (when (and (setq file (nnmhc-get-article article)) (file-exists-p file) (not (file-directory-p file))) (insert (format "221 %d Article retrieved.\n" article)) (setq begin (point)) (nnheader-insert-head file) (goto-char begin) (if (search-forward "\n\n" nil t) (forward-char -1) (goto-char (point-max)) (insert "\n\n")) (insert ".\n") (delete-region (point) (point-max)))) (nnheader-fold-continuation-lines) 'headers)))) (deffoo nnmhc-request-close () t) (deffoo nnmhc-request-article (id &optional group server buffer) (let ((nntp-server-buffer (or buffer nntp-server-buffer)) (pathname-coding-system 'binary) path) (when (integerp id) (setq path (nnmhc-get-article id)) (cond ((not path) (nnheader-report 'nnmhc "No such article: %s" id)) ((not (file-exists-p path)) (nnheader-report 'nnmhc "No such file: %s" path)) ((file-directory-p path) (nnheader-report 'nnmhc "File is a directory: %s" path)) ((not (save-excursion (let ((nnmail-file-coding-system nnmhc-file-coding-system)) (nnmail-find-file path)))) (nnheader-report 'nnmhc "Couldn't read file: %s" path)) (t (save-excursion (set-buffer nntp-server-buffer) (goto-char (mhc-header-narrowing (unless (mhc-header-get-value "subject") (insert "Subject: " (nnmhc-get-subject id) "\n")) (mhc-header-delete-header "xref") (insert (format "Xref: %s %s\n" (system-name) path)) (point-max))) ;; Hack for (gnus-bbdb/update-record), which doesn't accept ;; an article consisting of only headers. (if (eobp) (insert "\n"))) (nnheader-report 'nnmhc "Article %s retrieved" id) (cons group id)))))) (deffoo nnmhc-request-group (group &optional server fast) (nnheader-report 'nnmhc "Selected group %s" group) (nnheader-insert "211 1 1 1 %s\n" group)) (deffoo nnmhc-close-group (group &optional server) t) (provide 'nnmhc) ;;; Copyright Notice: ;; Copyright (C) 1999, 2000 Yoshinari Nomura. All rights reserved. ;; Copyright (C) 2000 MHC developing team. All rights reserved. ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. Neither the name of the team nor the names of its contributors ;; may be used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' ;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ;; THE TEAM OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, ;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED ;; OF THE POSSIBILITY OF SUCH DAMAGE. ;;; nnmhc.el ends here. yoshinari-nomura-mhc-815a36a/gemcal.in000066400000000000000000000513341222073515200177020ustar00rootroot00000000000000#!@@MHC_RUBY_PATH@@ ### gemcal -- Ruby/Gtk based calendar. ## ## Author: Yoshinari Nomura ## ## Created: 1999/09/01 ## Revised: $Date: 2006/12/18 09:31:54 $ ## # $DEBUG = 1 LIB = File .expand_path(File .dirname(File .symlink?($0) && File .readlink($0) || $0)) $LOAD_PATH .unshift(LIB + '/ruby-ext/lib') require 'gtk2' require 'mhc-kconv' require 'mhc-signal' require 'mhc-gtk' require 'mhc-date' require 'mhc-schedule' ################################################################ # Immediate class VDateListInput < Gtk::HBox def initialize(sch, title = 'Input Date List') super() @sch = sch frm = Gtk::Frame .new(title) hbx = Gtk::HBox .new(false, 0) .set_border_width(10) @lst = Gtk::ListStore.new(String) @lsv = Gtk::TreeView.new(@lst).set_headers_visible(false) \ .set_rules_hint(true) @lsv.append_column(Gtk::TreeViewColumn.new("Date", Gtk::CellRendererText.new, :text => 0) \ .set_max_width(56)) @lsv.set_width_request(150) # @lst = Gtk::CList .new(['Click to Remove']) # @lst .set_selection_mode(Gtk::SELECTION_SINGLE) # @lst .signal_connect('click_column'){|w, c| # return if c != 0 # @lst .each_selection{|r| # date_str = @lst .get_text(r, 0) # exc = true if date_str =~ /!/ # date_str .gsub!('[ !-]', '') # if exc # @sch .del_exception(MhcDate .new(date_str)) # else # @sch .del_day(MhcDate .new(date_str)) # end # } # update #} swin = Gtk::ScrolledWindow .new(nil, nil) swin .set_policy(Gtk::POLICY_NEVER, Gtk::POLICY_ALWAYS) swin .add(@lsv) @cal = GtkCalendar .new(MhcDate .new, [['prev', 'prev month'], ['next', 'next month'], ['today', 'this month']], true, true, false) hbx .pack_start(swin, false, false, 0) # hbx .pack_start(@lsv, true, true, 0) hbx .pack_start(@cal, false, false, 0) frm .add(hbx) vbx = Gtk::VBox .new(false, 0) .pack_start(frm, false, false, 0) pack_start(vbx, false, false, 0) @cal .signal_connect('next-btn-clicked') {@cal .next_month; update} @cal .signal_connect('prev-btn-clicked') {@cal .prev_month; update} @cal .signal_connect('today-btn-clicked'){@cal .this_month; update} @cal .signal_connect('day-btn-clicked'){|date| if !(@sch .occur_on?(date)) @sch .add_day(date) else @sch .del_day(date) end update } end def set_schedule(sch) @sch = sch update end # def delete_lst(ymd_str) # for i in 0 .. @lst .rows - 1 # s = @lst .get_text(i, 0) .gsub('[ -]', '') # if s == ymd_str # @lst .remove_row(i) # end # end # end def set_date(date) @cal .set_date(date) update end def cal return @cal end def update #@lst .freeze @lst .clear @sch .day .each{|day| iter = @lst.append iter[0] = ' ' + day.to_s1('-') } @sch .exception .each{|day| iter = @lst.append iter[0] = '!' + day.to_s1('-') } @lst .set_sort_column_id(0) @cal .date .m_each_day{|date| if @sch .occur_on?(date) @cal .d(date .d) .set_style('busy') else case (date .w) when 0 @cal .d(date .d) .set_style('holiday') when 6 @cal .d(date .d) .set_style('saturday') else @cal .d(date .d) .set_style('weekday') end end } end end ################################################################ # Indirect class VCondInput < Gtk::HBox LABEL = [ 'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', nil, 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec', nil, nil, nil, nil, nil, nil, nil, nil, '1st', '2nd', '3rd', '4th', '5th', 'Last', nil, 'Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat', nil, nil, nil, nil, nil, nil, nil ] + (1..31) .to_a def initialize(title, &p) super(false, 0) frm = Gtk::Frame .new(title) vbx = Gtk::VBox .new(false, 0) frm .add(vbx) @tbl = GtkToggleTable .new(11, 7, LABEL, &p) vbx .pack_start(@tbl, false, false, 0) pack_start(frm, false, false, 0) end def set_schedule(sch) @tbl .each_button{|btn, lbl| if sch .cond .include?(lbl .capitalize) btn .set_active(true) else btn .set_active(false) end } end def dump return @tbl .dump end end ################################################################ # Immediate class VDateEditor < Gtk::VBox def initialize(sch = MhcScheduleItem .new) super(false, 0) t = Time .now @sch = sch @cond_box = VCondInput .new('Indirect Dates'){|b| if b .active? @sch .add_cond(b .child .text) else @sch .del_cond(b .child .text) end @date_box .update } @cond_box .border_width = 10 @date_box = VDateListInput .new(@sch, 'Immediate Dates') @time_box = GtkTimeRangeEdit .new(MhcTime .new, MhcTime .new){|b, e| @sch .set_time(b, e) } @dur_box = GtkDateRangeEdit .new(MhcDate .new, MhcDate .new .y_succ!){|b, e| @sch .set_duration(b, e) @date_box .update } @alm_box = GtkAlarmEntry .new {|sec| # print "sec:(#{sec}) #{@sch .alarm} -> " @sch .set_alarm(sec) # print "#{@sch .alarm}\n" } hbx = Gtk::HBox .new(false, 0) vbx = Gtk::VBox .new(false, 0) vbx .pack_start(@date_box, false, false, 0) vbx .pack_start(@time_box, false, false, 5) vbx .pack_start(@dur_box, false, false, 0) vbx .pack_start(@alm_box, false, false, 10) hbx .pack_start(@cond_box, false, false, 10) hbx .pack_start(vbx, false, false, 10) pack_start(hbx, false, false, 10) end def set_schedule(sch) @sch = sch @alm_box .set_alarm(sch .alarm) @cond_box .set_schedule(sch) @date_box .set_schedule(sch) @time_box .set_value(sch .time_b, sch .time_e) @dur_box .set_value(sch .duration_b, sch .duration_e) end def cond; @cond_box; end def day; @date_box; end def time; @time_box; end def dur; @dur_box; end def alm; @alm_box; end end ################################################################ class MhcScheduleEdit < GtkToplevel BUTTONS = [ ['save', 'save to DB'], ['delete', 'delete this article'], ['close', 'close'] ] def initialize(db, sch) super() # set_usize(640, 480) # set_size_request(640, 480) set_title('Mhc::ScheduleEdit') vbx = Gtk::VBox .new @sch = sch @db = db ################################################################ hbx = Gtk::HBox .new(false, 0) @dur_box = GtkDateRangeEdit .new(MhcDate .new, MhcDate .new .y_succ!){|b, e| @sch .set_duration(b, e) @date_box .update } @subj_ent = GtkEntry .new("Subject: ") .set_border_width(3) @cat_ent = GtkEntry .new("Category: ") .set_border_width(3) @subj_ent .signal_connect('changed'){ @sch .set_subject(Kconv::tojis(@subj_ent .dump)) } @subj_ent .signal_connect('activate'){ @sch .set_subject(Kconv::tojis(@subj_ent .dump)) update_desc_box } @cat_ent .signal_connect('changed'){ @sch .set_category(Kconv::tojis(@cat_ent .dump)) } @cat_ent .signal_connect('activate'){ @sch .set_category(Kconv::tojis(@cat_ent .dump)) update_desc_box } ################################################################ note0_lbl = Gtk::Label .new("Description") @desc_box = GtkFileViewer .new(true) ## editable ################################################################ note1_lbl = Gtk::Label .new('Occurences') @date_box = VDateEditor .new(@sch) ################################################################ btn_bar = GtkButtonBar .new(BUTTONS) btn_bar .signal_connect('delete-btn-clicked'){ if !(@sch .path) GtkConfirm .new("No file in DB. (no need to delete from DB)\n") else msg = '' msg = "This article has multiple occurences." if @sch .occur_multiple? GtkConfirm .new("#{msg} Delete it?\n", 2){|ans| if ans @db .del_sch(@sch) close end } end } btn_bar .signal_connect('close-btn-clicked'){ if modified_any? GtkConfirm .new("Article is modified, close without save ?\n", 2){|ans| close if ans } else close end } btn_bar .signal_connect('save-btn-clicked'){ if modified_any? if @sch .error? msg = @sch .error_message GtkConfirm .new("#{msg} (Nothing was done).\n") else update_desc_box header, body = conv_description(Kconv::tojis(@desc_box .dump)) @sch .set_non_xsc_header(header .to_s) @sch .set_description(body .to_s) @desc_box .set_modified(false, 'saved') @db .add_sch(@sch) update_desc_box close ## xxx: rescue GtkConfirm .new("#{$!}\n(#{$@}).\n") end else GtkConfirm .new("Not modified (Nothing was done).\n") end } ################################################################ @note = Gtk::Notebook .new .append_page(@desc_box, note0_lbl) \ .append_page(@date_box, note1_lbl) vbx .pack_start(@subj_ent, false, false, 0) vbx .pack_start(@cat_ent, false, false, 0) vbx .pack_start(@note, true, true, 3) vbx .pack_start(btn_bar, false, false, 0) add(vbx) #@note .signal_connect('switch_page'){|w, a, p| #update_desc_box if p == 0 && @sch .modified? #} @sch .set_modified(false, 'init_editor') open(sch) end def close @sch = nil set_modified(false, 'closed') hide_all end def open(sch) p = proc { @sch = sch @subj_ent .set_text(@sch .subject) @cat_ent .set_text(@sch .category_as_string) @desc_box .replace_text(@sch .non_xsc_header + "\n" + @sch .description .to_s) @date_box .set_schedule(@sch) @note .set_page(0) set_modified(false, 'schedule_editor::open') show_all if !visible? self .window .raise } if modified_any? GtkConfirm .new('Open new schedule without saveing ?', 2){|ans| p .call if ans } else p .call end return self end #def dump; @sch .dump ;end private def update_desc_box end def set_modified(bool, msg) @sch .set_modified(bool, msg) if @sch @desc_box .set_modified(bool, msg) if @desc_box end def modified_any? return (@sch && @sch .modified?) || (@desc_box && @desc_box .modified?) end def conv_description(string) part1_is_header = true string .force_encoding("ASCII-8BIT") if RUBY_VERSION .to_f >= 1.9 part1, part2 = string .split("\n\n", 2) if !(part1 =~ /^[ \t]+/ or part1 =~ /^[A-Za-z0-9_-]+:/) part1_is_header = false end part1 .split("\n") .each{|line| if !(string =~ /^[ \t]+/ or string =~ /^[A-Za-z0-9_-]+:/) part1_is_header = false end } if part1_is_header header, body = part1, part2 else header, body = nil, string end return header, body end end ################################################################ ## ## MhcDayBook ## class MhcDayBook class Visual < GtkToplevel BUTTONS = [['month', 'open month'], ['open', 'open schedule editor'], ['prev', 'prev day'], ['next', 'next day'], ['today', 'goto today'], ['close', 'close']] def initialize(date, x = nil, y = nil) @vbx = GtkDayBook .new(date, BUTTONS) super() add(@vbx) set_title('Mhc::DayBook') # set_usize(217, 145) set_size_request(233, 177) set_uposition(x, y) if x && y end def append(*arg) ; @vbx .append(*arg) ; end def set_tip(*arg) ; @vbx .set_tip(*arg) ; end def append_tip(*arg) ; @vbx .append_tip(*arg) ; end def set_date(date) ; @vbx .set_date(date) ; end def date ; @vbx .date ; end def set_style(*arg) ; @vbx .set_style(*arg) ; end def signal_connect(sig, &p) if sig == 'delete_event' super else @vbx .signal_connect(sig, &p) end end end def initialize(date, db, x = nil, y = nil) @sch_edit = nil @date = date @db = db @vdl = Visual .new(@date, x, y) @path = [] @alarm = Alarm .new @db_sd = @db .signal_connect('updated'){scan} @al_sd = @alarm .signal_connect('day-changed'){scan(MhcDate .new)} @vdl .signal_connect('destroy'){destroy_handler} @vdl .signal_connect('delete_event'){@vdl .hide; true} @vdl .signal_connect('month-btn-clicked'){MhcCalendar .new(@date, @db)} @vdl .signal_connect('next-btn-clicked') {scan(@date .succ!)} @vdl .signal_connect('prev-btn-clicked') {scan(@date .dec!)} @vdl .signal_connect('today-btn-clicked'){scan(MhcDate.new)} @vdl .signal_connect('open-btn-clicked') {open_sch_edit} @vdl .signal_connect('close-btn-clicked'){@vdl .hide} @vdl .signal_connect("day-lst-clicked") {|w, r| if @path[r] .nil? GtkConfirm .new("Can not edit ``#{w .get_text(r, 1)}''.\n") else open_sch_edit(@path[r]) end } scan @vdl .show end def destroy_handler print "#{self} destroyed\n" if $DEBUG @vdl = nil @db .signal_disconnect(@db_sd) @alarm .signal_disconnect(@al_sd) end def open_sch_edit(path = nil) print "MhcDayBook open_sch_edit: #{path .inspect}\n" if $DEBUG if path && !File .exists?(path) ## do nothing. else sch = MhcScheduleItem .new(path) sch .add_day(@date) if path .nil? if (@sch_edit .nil? || @sch_edit .destroyed?) @sch_edit = MhcScheduleEdit .new(@db, sch) else @sch_edit .open(sch) end end end def scan(date = @date) print "MhcDayBook::scan #{date .to_js}\n" if $DEBUG @date = date @vdl .set_date(@date) @path = [] @db .search1(@date, @category) .each{|x| @vdl .set_style('holiday') if x .in_category?('Holiday') @vdl .append(x .subject, x .time_b .to_s) @path << x .path } @vdl .show @vdl .window .raise end end ################################################################ ## ## MhcCalendar Class ## class MhcCalendar class Visual < GtkToplevel BUTTONS = [['prev', 'prev month'], ['next', 'next month'], ['prev_year', 'prev year'], ['next_year', 'next year'], ['prev2', 'prev month'], ['next2', 'next month'], ['today', 'this month'], ['close', 'close']] def initialize(date, x = nil, y = nil) @vbx = GtkCalendar .new(date, BUTTONS) super() set_title(date .ym_js) add(@vbx) # set_usize(217, 0) set_size_request(233, 177) set_uposition(x, y) if x && y end def date ; @vbx .date ; end def d(*arg) ; @vbx .d(*arg) ; end def set_date(date); set_title(date .ym_js); @vbx .set_date(date) ; end def signal_connect(sig, &p) ; @vbx .signal_connect(sig, &p) ; end end def initialize(date, db, day_book = nil, x = nil, y = nil) @date = date .m_first_day @db = db @day_book = day_book @vml = Visual .new(@date, x, y) @sch_edit = nil @path = {} @alarm = Alarm .new @db_sd = @db .signal_connect('updated'){scan} @al_sd = @alarm .signal_connect('day-changed'){this_month} @vml .signal_connect('destroy') {destroy_handler} @vml .signal_connect('next-btn-clicked') {move_month(1)} @vml .signal_connect('prev-btn-clicked') {move_month(-1)} @vml .signal_connect('next_year-btn-clicked') {move_month(12)} @vml .signal_connect('prev_year-btn-clicked') {move_month(-12)} @vml .signal_connect('next2-btn-clicked'){move_month2(1)} @vml .signal_connect('prev2-btn-clicked'){move_month2(-1)} @vml .signal_connect('close-btn-clicked'){@vml .destroy} @vml .signal_connect('today-btn-clicked'){this_month} @vml .signal_connect("day-btn-clicked") {|date| open_daybook(date)} @vml .signal_connect("day-lst-clicked") {|w,d,r| if @path[d][r] .nil? GtkConfirm .new("Can not edit ``#{w .get_text(r, 1)}''.\n") else open_sch_edit(@path[d][r]) end } scan @vml .show end def move_month(n) ; scan(@date .m_succ(n)) ; end def move_month2(n); MhcCalendar .new(@date .m_succ(n), @db) ; end def this_month ; scan(MhcDate .new) ; end def destroy_handler print "#{self} destroyed\n" if $DEBUG @vml = nil @db .signal_disconnect(@db_sd) @alarm .signal_disconnect(@al_sd) end def open_sch_edit(path = nil) print "MhcCalendar open_sch_edit: #{path .inspect}\n" if $DEBUG if path && !File .exists?(path) ## do nothing. else sch = MhcScheduleItem .new(path) sch .add_day(@date) if path .nil? if (@sch_edit .nil? || @sch_edit .destroyed?) @sch_edit = MhcScheduleEdit .new(@db, sch) else @sch_edit .open(sch) end end end def open_daybook(date) if @day_book @day_book .scan(date) else @day_book = MhcDayBook .new(date, @db) end end def scan(date = @date) print "MhcCalendar::scan #{date .to_js}\n" if $DEBUG @date = date @vml .set_date(@date) @db .m_search(@date) .each{|date, item| # xxx dd = date .d @path[dd] = [] first = true item .each{|x| @vml .d(dd) .append(x .subject, x .time_b .to_s) s = (x .time_b .to_s + " " + x .subject) # .gsub("\s", "\x07") @vml .d(dd) .append_tip("\n" + MhcKconv::todisp(s)) @path[dd] << x .path if x .in_category?('Holiday') @vml .d(dd) .set_style('holiday') first = true end if first @vml .d(dd) .set_style('busy') first = false end } } end end ################################################################ ## Main ################################################################ repository, file = nil, nil while ARGV[0] argv = ARGV .shift case argv when /^-g(eometry)?$/ geom = ARGV .shift if geom && geom =~ /\+(\d+)\+(\d+)$/ x, y = $1 .to_i, $2 .to_i end when /^-r(epository)?$/ repository = File .expand_path(ARGV .shift) when /^-f(ile)?$/ file = File .expand_path(ARGV .shift) when /-d(aybook)?$/ geom = ARGV .shift if geom && geom =~ /\+(\d+)\+(\d+)$/ dx, dy = $1 .to_i, $2 .to_i end end end if repository if file db = MhcScheduleDB .new(repository, file) else db = MhcScheduleDB .new(repository) end else db = MhcScheduleDB .new end d = MhcDate .new if dx daybook = MhcDayBook .new(d, db, dx, dy) end MhcCalendar .new(d, db, daybook, x, y) alarm = MhcAlarm .new(db) alarm .signal_connect('time-arrived'){|date, sch| GtkConfirm .new("#{date .to_js} #{sch .time_b} " + "#{MhcKconv::todisp(sch .subject)}\n") } alarm .check Gtk .main ### Copyright Notice: ## Copyright (C) 1999, 2000 Yoshinari Nomura. All rights reserved. ## Copyright (C) 2000 MHC developing team. All rights reserved. ## Redistribution and use in source and binary forms, with or without ## modification, are permitted provided that the following conditions ## are met: ## ## 1. Redistributions of source code must retain the above copyright ## notice, this list of conditions and the following disclaimer. ## 2. Redistributions in binary form must reproduce the above copyright ## notice, this list of conditions and the following disclaimer in the ## documentation and/or other materials provided with the distribution. ## 3. Neither the name of the team nor the names of its contributors ## may be used to endorse or promote products derived from this software ## without specific prior written permission. ## ## THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' ## AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ## LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ## FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ## THE TEAM OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ## INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ## (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ## SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ## HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, ## STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ## ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED ## OF THE POSSIBILITY OF SUCH DAMAGE. ### gemcal ends here yoshinari-nomura-mhc-815a36a/icons/000077500000000000000000000000001222073515200172275ustar00rootroot00000000000000yoshinari-nomura-mhc-815a36a/icons/Anniversary.xbm000066400000000000000000000004601222073515200222400ustar00rootroot00000000000000#define Anniversary_width 16 #define Anniversary_height 16 static unsigned char Anniversary_bits[] = { 0x40, 0x02, 0xc8, 0x16, 0xd8, 0x2f, 0x70, 0x56, 0xf8, 0x29, 0x88, 0x6f, 0x08, 0xbc, 0x08, 0xf0, 0x08, 0x90, 0x10, 0x10, 0x10, 0x0c, 0x10, 0x02, 0x90, 0x01, 0x48, 0x00, 0x48, 0x00, 0x78, 0x00, }; yoshinari-nomura-mhc-815a36a/icons/Anniversary.xpm000066400000000000000000000011251222073515200222550ustar00rootroot00000000000000/* XPM */ static char * Anniversary_xpm[] = { "16 16 8 1", " s backgroundColor c None", ". c #FFFF659571C6", "X c #FFFFA699A699", "o c #00009E790000", "O c #FFFFBAEA5144", "+ c #FFFFFFFFFFFF", "@ c #000000000000", "# c #0000FFFF0000", " . X ", " o .OO XX X ", " + o.OO.XXXXX ", " +ooo+.. XXOO ", " @@@@o...o..O ", " @+++@@@o+...O", " @++++++@@#o+ ", " @++++++++@oo ", " @++++++++@+ o", " @+++++++@ ", " @+++++@@ ", " @++++@ ", " @++@@ ", " @++@ ", " @++@ ", " @@@@ "}; yoshinari-nomura-mhc-815a36a/icons/Birthday.xbm000066400000000000000000000004471222073515200215120ustar00rootroot00000000000000#define Birthday_width 16 #define Birthday_height 16 static unsigned char Birthday_bits[] = { 0x00, 0x00, 0x00, 0x00, 0x48, 0x12, 0x00, 0x00, 0x48, 0x12, 0x48, 0x12, 0x48, 0x12, 0xfc, 0x3f, 0x04, 0x20, 0x54, 0x2a, 0xfc, 0x3f, 0xfc, 0x3f, 0xfc, 0x3f, 0xfc, 0x3f, 0xfc, 0x3f, 0x00, 0x00, }; yoshinari-nomura-mhc-815a36a/icons/Birthday.xpm000066400000000000000000000010361222073515200215230ustar00rootroot00000000000000/* XPM */ static char * Birthday_xpm[] = { "16 16 6 1", " s backgroundColor c None", ". c #FFFFB6DA28A2", "X c #FFFFFFFF0000", "o c #00000000FFFF", "O c #000000000000", "+ c #FFFFFFFFFFFF", " ", " ", " . . . . ", " X X X X ", " o o o o ", " o o o o ", " o o o o ", " OOOOOOOOOOOO ", " O++++++++++O ", " O+O+O++O+O+O ", " OO.O.OO.O.OO ", " O..........O ", " O..........O ", " O..........O ", " OOOOOOOOOOOO ", " "}; yoshinari-nomura-mhc-815a36a/icons/Business.xbm000066400000000000000000000004501222073515200215310ustar00rootroot00000000000000#define Business_width 16 #define Business_height 16 static unsigned char Business_bits[] = { 0x00, 0x00, 0x00, 0x00, 0xe0, 0x07, 0xe0, 0x07, 0x60, 0x06, 0xfc, 0x3f, 0xfc, 0x3f, 0xfc, 0x3f, 0xfc, 0x3f, 0xfc, 0x3f, 0xfc, 0x3f, 0xfc, 0x3f, 0xfc, 0x3f, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00}; yoshinari-nomura-mhc-815a36a/icons/Business.xpm000066400000000000000000000010041222073515200215430ustar00rootroot00000000000000/* XPM */ static char * Business_xpm[] = { "16 16 5 1", " s backgroundColor c None", ". c #79E765954924", "X c #CF3CAAAA79E7", "o c #000000000000", "O c #FFFFCF3C9658", " ", " ...... ", " .XXXXXX. ", " .X. .X. ", " oooooooooooooo ", " oOOOOOOOOOOOOo ", " oOXXXXXXXXXX.o ", " oOXXXXXXXXXX.o ", " oOXXXXXXXXXX.o ", " oOXXXXXXXXXX.o ", " oOXXXXXXXXXX.o ", " oOXXXXXXXXXX.o ", " o............o ", " oooooooooooooo ", " ", " "}; yoshinari-nomura-mhc-815a36a/icons/CheckBox.xbm000066400000000000000000000004471222073515200214320ustar00rootroot00000000000000#define CheckBox_width 16 #define CheckBox_height 16 static unsigned char CheckBox_bits[] = { 0x00, 0x00, 0xfe, 0x7f, 0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0xfe, 0x7f, 0x00, 0x00, }; yoshinari-nomura-mhc-815a36a/icons/CheckBox.xpm000066400000000000000000000007541222073515200214510ustar00rootroot00000000000000/* XPM */ static char * CheckBox_xpm[] = { "16 16 5 1", " s backgroundColor c None", ". c #000000", "+ c #717171", "@ c #BEBEBE", "# c #E7E7E7", " ", " .............. ", " .++++++++++++@ ", " .+@@@@@@@@@@@# ", " .+@@@@@@@@@@@# ", " .+@@@@@@@@@@@# ", " .+@@@@@@@@@@@# ", " .+@@@@@@@@@@@# ", " .+@@@@@@@@@@@# ", " .+@@@@@@@@@@@# ", " .+@@@@@@@@@@@# ", " .+@@@@@@@@@@@# ", " .+@@@@@@@@@@@# ", " .+@@@@@@@@@@@# ", " @############# ", " "}; yoshinari-nomura-mhc-815a36a/icons/CheckedBox.xbm000066400000000000000000000004551222073515200217420ustar00rootroot00000000000000#define CheckedBox_width 16 #define CheckedBox_height 16 static unsigned char CheckedBox_bits[] = { 0x00, 0x00, 0xfe, 0x7f, 0x02, 0x58, 0x02, 0x4c, 0x02, 0x4e, 0x22, 0x47, 0x72, 0x47, 0xf2, 0x43, 0xe2, 0x43, 0xc2, 0x43, 0x82, 0x41, 0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0xfe, 0x7f, 0x00, 0x00, }; yoshinari-nomura-mhc-815a36a/icons/CheckedBox.xpm000066400000000000000000000010401222073515200217470ustar00rootroot00000000000000/* XPM */ static char * CheckedBox_xpm[] = { "16 16 6 1", " s backgroundColor c None", ". c #000000000000", "X c #FFFF00000000", "o c #71C671C671C6", "O c #E79DE79DE79D", "+ c #BEFBBEFBBEFB", " ", " ...........XX. ", " .oooooooooXXoO ", " .o+++++++XX++O ", " .o++++++XXX++O ", " .o++X++XXX+++O ", " .o+XXX+XXX+++O ", " .o+XXXXXX++++O ", " .o++XXXXX++++O ", " .o+++XXXX++++O ", " .o++++XX+++++O ", " .o+++++++++++O ", " .o+++++++++++O ", " .o+++++++++++O ", " OOOOOOOOOOOOOO ", " "}; yoshinari-nomura-mhc-815a36a/icons/Conflict.xbm000066400000000000000000000003741222073515200215040ustar00rootroot00000000000000#define Conflict_width 16 #define Conflict_height 16 static char Conflict_bits[] = { 0x80,0x40,0x80,0x30,0xc1,0x19,0xfe,0x1f,0xfc,0x1f,0x78,0x3e,0x78,0xfe,0x7c, 0x3e,0x7f,0x1e,0xfc,0x1f,0x78,0x1e,0xf8,0x3f,0xf8,0x7f,0x9c,0x87,0x02,0x03, 0x00,0x04}; yoshinari-nomura-mhc-815a36a/icons/Conflict.xpm000066400000000000000000000007201222073515200215150ustar00rootroot00000000000000/* XPM */ static char * Conflict_xpm[] = { "16 16 3 1", " s backgroundColor c None", ". c #FFFFFFFF0000", "X c #000000000000", " . . ", " . .. ", ". ... .. ", " ............ ", " ........... ", " ....XX..... ", " ....XX.......", " .....XX..... ", ".......XX.... ", " ........... ", " ....XX.... ", " ........... ", " ............ ", " ... .... .", " . .. ", " . "}; yoshinari-nomura-mhc-815a36a/icons/Date.xbm000066400000000000000000000004031222073515200206110ustar00rootroot00000000000000#define Date_width 16 #define Date_height 14 static unsigned char Date_bits[] = { 0x00, 0x00, 0x00, 0x00, 0x60, 0x1c, 0xf0, 0x3e, 0xf0, 0x3f, 0xf0, 0x3f, 0xf0, 0x1f, 0xf0, 0x1f, 0xe0, 0x0f, 0xc0, 0x07, 0xc0, 0x03, 0x80, 0x01, 0x00, 0x01, 0x00, 0x00, }; yoshinari-nomura-mhc-815a36a/icons/Date.xpm000066400000000000000000000012171222073515200206330ustar00rootroot00000000000000/* XPM */ static char * Date_xpm[] = { "16 14 12 1", " s backgroundColor c None", ". c #FFFF00000000", "X c #FFFF0C300820", "o c #FFFF1C711861", "O c #FFFF28A22081", "+ c #FFFF3CF330C2", "@ c #FFFF49244103", "# c #FFFF59655144", "$ c #FFFF69A65965", "% c #FFFF79E769A6", "& c #FFFF861779E7", "* c #FFFF96588E38", " ", " ", " .. ... ", " XXXX XXXXX ", " oooooooooo ", " OOOOOOOOOO ", " +++++++++ ", " @@@@@@@@@ ", " ####### ", " $$$$$ ", " %%%% ", " && ", " * ", " "}; yoshinari-nomura-mhc-815a36a/icons/Holiday.xbm000066400000000000000000000004441222073515200213320ustar00rootroot00000000000000#define Holiday_width 16 #define Holiday_height 16 static unsigned char Holiday_bits[] = { 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xfe, 0x7f, 0x02, 0x40, 0x82, 0x41, 0xc2, 0x43, 0xe2, 0x47, 0xe2, 0x47, 0xc2, 0x43, 0x82, 0x41, 0x02, 0x40, 0xfe, 0x7f, 0x00, 0x00, 0x00, 0x00, }; yoshinari-nomura-mhc-815a36a/icons/Holiday.xpm000066400000000000000000000010351222073515200213450ustar00rootroot00000000000000/* XPM */ static char * Holiday_xpm[] = { "16 16 6 1", " s backgroundColor c None", ". c #000000000000", "X c #FFFFFFFFFFFF", "o c #FFFF96589658", "O c #FFFF4D344924", "+ c #FFFF00000000", " ", " ", " ", " ", " .............. ", " .XXXXXXXXXXXX. ", " .XXXXXooXXXXX. ", " .XXXXO++OXXXX. ", " .XXXo++++oXXX. ", " .XXXo++++oXXX. ", " .XXXXO++OXXXX. ", " .XXXXXooXXXXX. ", " .XXXXXXXXXXXX. ", " .............. ", " ", " "}; yoshinari-nomura-mhc-815a36a/icons/Link.xbm000066400000000000000000000004341222073515200206350ustar00rootroot00000000000000#define Link_width 16 #define Link_height 16 static unsigned char Link_bits[] = { 0x00, 0x00, 0x00, 0x00, 0x00, 0x30, 0x00, 0x38, 0x00, 0x1d, 0x80, 0x0e, 0xc0, 0x06, 0x60, 0x08, 0x30, 0x0c, 0x10, 0x06, 0x60, 0x03, 0x70, 0x01, 0xb8, 0x00, 0x18, 0x00, 0x00, 0x00, 0x00, 0x00}; yoshinari-nomura-mhc-815a36a/icons/Link.xpm000066400000000000000000000010321222073515200206460ustar00rootroot00000000000000/* XPM */ static char * Link_xpm[] = { "16 16 6 1", " s backgroundColor c None", ". c #30C230C26185", "X c #E79DE79DE79D", "o c #C71BC30BEFBE", "O c #8E388A288E38", "+ c #BEFBBEFBBEFB", " ", " .. ", " .Xo. ", " ...XoO. ", " .o.XoO. ", " .X.XoO. ", " .Xo.OO.. ", " .Xo. ..X. ", " .Xo. .Xo. ", " .o.. .Xo. ", " ..X+.Xo. ", " .XoO.o. ", " .XoO.+. ", " .oO... ", " ... ", " "}; yoshinari-nomura-mhc-815a36a/icons/Other.xbm000066400000000000000000000004361222073515200210230ustar00rootroot00000000000000#define Other_width 16 #define Other_height 16 static unsigned char Other_bits[] = { 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xe0, 0x03, 0xf0, 0x07, 0x30, 0x06, 0x00, 0x06, 0x00, 0x07, 0xc0, 0x03, 0xc0, 0x00, 0xc0, 0x00, 0x00, 0x00, 0x00, 0x00, 0xc0, 0x00, 0xc0, 0x00, 0x00, 0x00, }; yoshinari-nomura-mhc-815a36a/icons/Other.xpm000066400000000000000000000011511222073515200210340ustar00rootroot00000000000000/* XPM */ static char * Other_xpm[] = { "16 16 9 1", " s backgroundColor c None", ". c #FFFF9E79AEBA", "X c #FFFF8A289658", "o c #FFFF75D679E7", "O c #FFFF618569A6", "+ c #FFFF4D345144", "@ c #FFFF38E338E3", "# c #FFFF28A228A2", "$ c #FFFF14511040", " ", " ", " ", " ..... ", " XXXXXXX ", " oo oo ", " OO ", " +++ ", " @@@@ ", " ## ", " $$ ", " ", " .. ", " ++ ", " ", " "}; yoshinari-nomura-mhc-815a36a/icons/Party.xbm000066400000000000000000000004361222073515200210410ustar00rootroot00000000000000#define Party_width 16 #define Party_height 16 static unsigned char Party_bits[] = { 0x00, 0x00, 0xf0, 0x01, 0x08, 0x02, 0x04, 0x04, 0x8c, 0x1f, 0x94, 0x24, 0x54, 0x5c, 0x24, 0x54, 0xfc, 0x57, 0xfc, 0x57, 0xfc, 0x2f, 0xfc, 0x17, 0xfc, 0x0f, 0xfc, 0x07, 0xf8, 0x03, 0x00, 0x00, }; yoshinari-nomura-mhc-815a36a/icons/Party.xpm000066400000000000000000000007471222073515200210640ustar00rootroot00000000000000/* XPM */ static char * Party_xpm[] = { "16 16 4 1", " s backgroundColor c None", ". c #000000000000", "X c #F7DEFFFFE79D", "o c #FFFFE79D2081", " ", " ..... ", " .XXXXX. ", " .XXXXXXX. ", " ..XXX...... ", " .X.XX.XX.XX. ", " .X.X.XXX...X. ", " .XX.XXXX. .X. ", " .ooooooo. .X. ", " .ooooooo. .X. ", " .ooooooo..X. ", " .ooooooo.X. ", " .ooooooo.. ", " .ooooooo. ", " ....... ", " "}; yoshinari-nomura-mhc-815a36a/icons/Private.xbm000066400000000000000000000004451222073515200213540ustar00rootroot00000000000000#define Private_width 16 #define Private_height 16 static unsigned char Private_bits[] = { 0x00, 0x00, 0xc0, 0x03, 0xe0, 0x07, 0x70, 0x0e, 0x30, 0x0c, 0x30, 0x0c, 0xfc, 0x3f, 0x7c, 0x3e, 0x3c, 0x3c, 0x3c, 0x3c, 0x7c, 0x3e, 0x7c, 0x3e, 0x7c, 0x3e, 0xfc, 0x3f, 0x00, 0x00, 0x00, 0x00}; yoshinari-nomura-mhc-815a36a/icons/Private.xpm000066400000000000000000000010671222073515200213730ustar00rootroot00000000000000/* XPM */ static char * Private_xpm[] = { "16 16 7 1", " s backgroundColor c None", ". c #514479E779E7", "X c #8E38C30BC71B", "o c #30C251445144", "O c #61858A288E38", "+ c #B6DAFFFFFFFF", "@ c #186130C230C2", " ", " .XXXXo ", " .Xo...Xo ", " .Xo .Xo ", " .Xo .Xo ", " .Xo .Xo ", " XXOOOOOOOOoooo ", " X++XXXXXXXXOoo ", " X+XXXX@oXXXOoo ", " X+XXX@@@oXXOoo ", " X+XXX@@@oXXOoo ", " X+XXXX@oXXXOoo ", " X+XXXX@oXXXOoo ", " X+XXXXXXXXXOoo ", " XXoooooooooooo ", " "}; yoshinari-nomura-mhc-815a36a/icons/Recurrence.xbm000066400000000000000000000004441222073515200220360ustar00rootroot00000000000000#define Recurrence_width 16 #define Recurrence_height 16 static char Recurrence_bits[] = { 0xFF, 0xFF, 0x7F, 0xEF, 0xBF, 0xFC, 0x6D, 0xE7, 0xEF, 0xD7, 0xFA, 0xFF, 0xBF, 0xFB, 0x7F, 0xFF, 0xFF, 0xFF, 0xBF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, 0xFF, }; yoshinari-nomura-mhc-815a36a/icons/Recurrence.xpm000066400000000000000000000030411222073515200220500ustar00rootroot00000000000000/* XPM */ static char *Recurrence[] = { /* columns rows colors chars-per-pixel */ "16 16 76 1 ", " c #0E5F7A", ". c #0F637E", "X c #106480", "o c #116580", "O c #116884", "+ c #136B87", "@ c #136B88", "# c #126C89", "$ c #136C89", "% c #157290", "& c #157391", "* c #157492", "= c #147493", "- c #157695", "; c #147796", ": c #157796", "> c #167897", ", c #147898", "< c #177A9A", "1 c #167B9B", "2 c #177B9B", "3 c #167C9C", "4 c #177D9E", "5 c #1880A2", "6 c #1981A2", "7 c #1A82A3", "8 c #1A82A4", "9 c #1984A6", "0 c #1986A9", "q c #1A86A9", "w c #1A87A9", "e c #1987AA", "r c #1A87AA", "t c #1B8BAF", "y c #1C8BAF", "u c #1C8CAF", "i c #1D91B6", "p c #1F95BA", "a c #1F95BB", "s c #1F96BD", "d c #1F97BD", "f c #1E99BD", "g c #209AC1", "h c #209BC2", "j c #209CC4", "k c #219CC4", "l c #229DC4", "z c #219EC5", "x c #229EC5", "c c #21A0C6", "v c #23A3CB", "b c #23A4CD", "n c #24A4CD", "m c #24A5CE", "M c #24A5CF", "N c #24ADC9", "B c #24ADCA", "V c #24AAD3", "C c #24ADD0", "Z c #25AED1", "A c #26ACD6", "S c #26ACD7", "D c #27ADD8", "F c #26AFD9", "G c #27AFDA", "H c #26B5D1", "J c #26B5D2", "K c #28B3DF", "L c #29B4E0", "P c #28B5E0", "I c #29B6E2", "U c #29B7E2", "Y c #2ABCE4", "T c #2BBBE8", "R c #2BBDE8", "E c None", /* pixels */ "EEEEEEEEEEEEEEEE", "EEEEEECHHCEEEEEE", "EEEECTTTTTTHEfcE", "EEEVIKKKKKKPFPlE", "EEhFVFmldmVVFFsE", "EEmmmsEEE3lmmmiE", "E0llsEEEE0llllyE", "E9pp0EEEE0y0003E", "E<<3EEEEEEEEEE", "EE+;@;;;;;;EEEEE", "EEE+@@@@@@++EEEE", "EEEE.oooooo.EEEE", "EEEEEE EEEEEE", "EEEEEEEEEEEEEEEE" }; yoshinari-nomura-mhc-815a36a/icons/Vacation.xbm000066400000000000000000000004471222073515200215100ustar00rootroot00000000000000#define Vacation_width 16 #define Vacation_height 16 static unsigned char Vacation_bits[] = { 0x00, 0x00, 0x00, 0x3f, 0x80, 0x20, 0x80, 0x3f, 0x00, 0x12, 0x00, 0x3f, 0x80, 0x2c, 0x40, 0x2c, 0x20, 0x2c, 0xf8, 0x7f, 0xfc, 0x7f, 0xfa, 0x7f, 0xfe, 0x7f, 0xee, 0x6f, 0x38, 0x38, 0x00, 0x00, }; yoshinari-nomura-mhc-815a36a/icons/Vacation.xpm000066400000000000000000000010701222073515200215170ustar00rootroot00000000000000/* XPM */ static char * Vacation_xpm[] = { "16 16 7 1", " s backgroundColor c None", ". c #FFFFFFFFFFFF", "X c #000000000000", "o c #DF7DDF7DDF7D", "O c #0000FFFFFFFF", "+ c #BEFBBEFBBEFB", "@ c #FFFFF7DE8617", " ...... ", " .XXXXXX. ", " .XoooooX. ", " .XXXXXXX. ", " ..X..X. ", " .XXXXXX. ", " .XOO++OX. ", " .XOOO++OX. ", " ..XOOOO++OX. ", " .XXXXXXXXXXXX.", " .XXXXXXXXXXXXX.", ".X@XXXXXXXXXXXX.", ".XXXXXXXXXXXXXX.", ".XXXoXXXXXXXoXX.", " ..XXX.....XXX. ", " ... ... "}; yoshinari-nomura-mhc-815a36a/make.rb.in000066400000000000000000000052361222073515200177710ustar00rootroot00000000000000#!@@MHC_RUBY_PATH@@ # -*- ruby -*- ## make.rb.in -- Installer for Ruby scripts. ## ## Author: MIYOSHI Masanori ## ## Created: 2000/7/12 ## $LOAD_PATH .unshift('@@MHC_TOPDIR@@') require 'mhc-make' include MhcMake install_files = [ 'adb2mhc:0755:@@MHC_BINDIR@@', 'gemcal:0755:@@MHC_BINDIR@@', 'mhc-sync:0755:@@MHC_BINDIR@@', 'mhc2palm:0755:@@MHC_BINDIR@@', 'palm2mhc:755:@@MHC_BINDIR@@', 'today:0755:@@MHC_BINDIR@@', 'xpm/close.xpm:0644:@@MHC_XPM_PATH@@', 'xpm/delete.xpm:0644:@@MHC_XPM_PATH@@', 'xpm/exit.xpm:0644:@@MHC_XPM_PATH@@', 'xpm/month.xpm:0644:@@MHC_XPM_PATH@@', 'xpm/next.xpm:0644:@@MHC_XPM_PATH@@', 'xpm/next2.xpm:0644:@@MHC_XPM_PATH@@', 'xpm/next_year.xpm:0644:@@MHC_XPM_PATH@@', 'xpm/open.xpm:0644:@@MHC_XPM_PATH@@', 'xpm/prev.xpm:0644:@@MHC_XPM_PATH@@', 'xpm/prev2.xpm:0644:@@MHC_XPM_PATH@@', 'xpm/prev_year.xpm:0644:@@MHC_XPM_PATH@@', 'xpm/save.xpm:0644:@@MHC_XPM_PATH@@', 'xpm/today.xpm:0644:@@MHC_XPM_PATH@@' ] if /cygwin|mingw32/ =~ RUBY_PLATFORM install_files << 'mhc2ol:0755:@@MHC_BINDIR@@' end INSTALL_FILES = install_files doit() ### Copyright Notice: ## Copyright (C) 2000 MHC developing team. All rights reserved. ## Redistribution and use in source and binary forms, with or without ## modification, are permitted provided that the following conditions ## are met: ## ## 1. Redistributions of source code must retain the above copyright ## notice, this list of conditions and the following disclaimer. ## 2. Redistributions in binary form must reproduce the above copyright ## notice, this list of conditions and the following disclaimer in the ## documentation and/or other materials provided with the distribution. ## 3. Neither the name of the team nor the names of its contributors ## may be used to endorse or promote products derived from this software ## without specific prior written permission. ## ## THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' ## AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ## LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ## FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ## THE TEAM OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ## INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ## (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ## SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ## HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, ## STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ## ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED ## OF THE POSSIBILITY OF SUCH DAMAGE. ### make.rb.in ends here yoshinari-nomura-mhc-815a36a/mhc-make.rb000066400000000000000000000305171222073515200201310ustar00rootroot00000000000000## mhc-make.rb -- Installer for Ruby scripts. ## ## Author: MIYOSHI Masanori ## Yoshinari Nomura ## Created: 2000/7/12 ## Revised: $Date: 2001/04/10 01:16:21 $ require 'rbconfig' require 'mkmf' require 'fileutils' require 'kconv' require 'getoptlong' def File .which(command) bindir = CONFIG['bindir'] if bindir and File .exist?(path = (bindir + '/' + command)) return path end ENV['PATH'] .split(':') .each{|dir| path = dir + '/' + command if File .exist?(path) return path end } return nil end module MhcMake def default() if File .exists?('Makefile') make_system("make") else ## print "Nothing to do in #{Dir .pwd}.\n" end process_subdirs() end def clean if File .exists?('Makefile') make_system("make clean") else Dir .foreach('.'){|src_file| if src_file =~ /\.in$/ or src_file == 'Makefile' or src_file == 'make.rb' dst_file = src_file .sub(/\.in$/, '') if File .exist?(dst_file) File .delete(dst_file) print "removing: " + dst_file + "\n"; end end } end process_subdirs() end def make_system(*commandline) commandline = commandline .join(' ') echo_flag, exit_flag = true, true if commandline =~ /^-(.*)/ commandline = $1 exit_flag = false end if commandline =~ /^@(.*)/ commandline = $1 echo_flag = false end print commandline, "\n" if echo_flag system(commandline) result = $? >> 8 if result != 0 and exit_flag exit result end end def process_subdirs() target = ARGV .join(' ') Dir .foreach('.'){|entry| if entry !~ /^\./ and File .directory?(entry) if File .exists?("#{entry}/make.rb") print "Making #{target} in #{File .expand_path(entry)}\n" cd = Dir .pwd() Dir .chdir(File .expand_path(entry)) make_system('ruby', 'make.rb', *ARGV) Dir .chdir(cd) elsif File .exists?("#{entry}/Makefile") print "Making #{target} in #{File .expand_path(entry)}\n" cd = Dir .pwd() Dir .chdir(File .expand_path(entry)) make_system('make', *ARGV) Dir .chdir(cd) end end } end def install if File .exists?('Makefile') make_system("make", "install") else INSTALL_FILES .each{|filename_mode_dir| filename, mode, dir = filename_mode_dir .split(':') FileUtils .makedirs(dir) if ! File .directory?(dir) FileUtils .install(filename, dir, {:mode => mode .oct, :verbose => true}) } end process_subdirs() end def print_usage() print "Usage: make.rb [target]\ntarget can be none, install or clean.\n" end def doit if (ARGV .size == 0) default() else case ARGV[0] when "install" install() when "clean" clean() else print_usage(); exit(1); end end end end class MhcConfigTable include RbConfig # ['--kcode', '@@MHC_KCODE@@', GetoptLong::OPTIONAL_ARGUMENT, usage, default] DEFAULT_CONFIG_TABLE = [ ['--help', '@@MHC_HELP@@', GetoptLong::NO_ARGUMENT, "print this message", ''], ['--kcode', '@@MHC_KCODE@@', GetoptLong::REQUIRED_ARGUMENT, "=CODE kanji code (EUC, JIS, SJIS)", (/cygwin|mingw32|os2_emx|sharp-human/ =~ RUBY_PLATFORM) ? 'SJIS' : 'EUC' ], ['--bindir', '@@MHC_BINDIR@@', GetoptLong::REQUIRED_ARGUMENT, "=DIR user executables go to DIR", CONFIG["bindir"]], ['--with-ruby', '@@MHC_RUBY_PATH@@', GetoptLong::REQUIRED_ARGUMENT, "=PATH absolute path of ruby executable", ''], ['--libdir', '@@MHC_LIBDIR@@', GetoptLong::REQUIRED_ARGUMENT, "=DIR Ruby script libraries go to DIR", CONFIG["rubylibdir"]], ['--with-emacs', '@@MHC_EMACS_PATH@@', GetoptLong::REQUIRED_ARGUMENT, "=PATH absolute path of emacs/xemacs executable", ''], ['--with-lispdir', '@@MHC_LISPDIR@@', GetoptLong::REQUIRED_ARGUMENT, "=DIR emacs lisp files go to DIR.", ''], ['--with-xemacs-pkgdir', '@@MHC_XEMACS_PACKAGE_DIR@@', GetoptLong::REQUIRED_ARGUMENT, '=DIR emacs lisp files as package go to DIR.', ''], ['--with-emacs-addpath', '@@MHC_EMACS_ADD_PATH@@', GetoptLong::REQUIRED_ARGUMENT, '=PATH add colon separated dirs list, to `load-path\'', ''] ] def initialize(config_table = []) @config_table = DEFAULT_CONFIG_TABLE + config_table end def getopt_table return @config_table .collect{|ary| [ary[0], ary[2]]} end def usage_string opt_ary, ret, opt_name_max_length = [], '', 0 @config_table .each{|ary| opt_name, opt_usage = ary[0], ary[-2] if opt_usage =~ /^(=\S+)\s+(.*)/ opt_name += $1 opt_usage = $2 end if (opt_name_max_length < opt_name .length) opt_name_max_length = opt_name .length end opt_ary << [opt_name, opt_usage] } opt_ary .each{|opt| ret += format(" %-#{opt_name_max_length}s %s\n", opt[0], opt[1]) } return ret end def macro_hash hash = {} @config_table .each{|ary| hash[ary[1]] = ary[-1]} return hash end def macro_name(option_string) @config_table .each{|ary| return ary[1] if ary[0] == option_string } return nil end def option_name(macro_name) @config_table .each{|ary| return ary[0] if ary[1] == macro_name } return nil end end class MhcConfigure include RbConfig def initialize(local_config_table = []) @macros = {} @config_table = MhcConfigTable .new(local_config_table) ## import macros from rbconfig.rb CONFIG .each{|key, val| @macros[make_macro_name(key)] = val} ## import macros from configure table @macros .update(@config_table .macro_hash) ## set useful macros. @macros['@@MHC_RUBY_VERSION@@'] = RUBY_VERSION .split('.') .collect{|i| format("%02d", i)} .join('') @macros['@@MHC_TOPDIR@@'] = Dir .pwd end def usage STDERR .print "usage: ruby configure.rb [options]\n" STDERR .print @config_table .usage_string end ## parse ARGV and set corresponding macros. def parse_argv() parser = GetoptLong .new() parser .set_options(*@config_table .getopt_table) begin parser .each_option do |name, arg| if name == '--help' usage() exit(0) else @macros[@config_table .macro_name(name)] = (arg == '' ? '1' : arg) end end rescue usage() exit(1) end return self end def [](name); @macros[name]; end def []=(name, val); @macros[name] = val; end def macro(name) return @macros[name] end def set_macro(name, val) return @macros[name] = val end def add_macro(name, val) return @macros[name] += val end def each_macro() @macros .each do |key, val| yield(key, val) end end ## replace keywords in files. in_file_list: ## infile_list is a array of 'filename:mode' ## such like ['mhc-sync.in:0755', 'mhc2palm.in:0755' ...] def replace_keywords(in_file_list) in_file_list .each{|src_file_and_mode| src_file, mode = src_file_and_mode .split(':') dst_file = src_file .sub(/\.in$/, '') print "creating #{dst_file} ..." replace_keywords1(src_file, dst_file , @macros, mode .oct) print "done.\n" } end ## find header file, add to '@@MHC_CFLAGS@@', set macroname. def search_include(search_path, header_file, macroname, force, abort) if @macros[macroname] and @macros[macroname] != '' and !force search_path = [@macros[macroname]] end cflags, found_inc_path = $CFLAGS, nil search_path .each{|inc_path| print "In #{inc_path} .. " $CFLAGS = "-I#{inc_path}" if have_header(header_file) found_inc_path = inc_path # avoiding ruby 1.4.3 bug. $defs .push($defs .pop .sub!(/-DHAVE_PI-DLP_H/, '-DHAVE_PI_DLP_H')) break end } $CFLAGS = cflags if found_inc_path @macros['@@MHC_CFLAGS@@'] += " -I#{found_inc_path} " @macros[macroname] = found_inc_path elsif abort search_abort(header_file, macroname) end return found_inc_path end ## find library file, add to '@@MHC_LDFLAGS@@', set macroname. def search_library(search_path, libname, funcname, macroname, force, abort) if @macros[macroname] and @macros[macroname] != '' and !force search_path = [@macros[macroname]] end ldflags, found_lib_path = $LDFLAGS, nil search_path .each{|lib_path| print "In #{lib_path} .. " $LDFLAGS = "-L#{lib_path}" if have_library(libname, funcname) found_lib_path = lib_path break end } $LDFLAGS = ldflags if found_lib_path @macros['@@MHC_LDFLAGS@@'] += " -L#{found_lib_path} " @macros[macroname] = found_lib_path elsif abort search_abort(libname, macroname) end return found_lib_path end ## find command and set macro name. ## if force is true, overwrite the macro even if previously set. ## if abort is true, stop and exit. def search_command(command, macroname, force, abort) path = @macros[macroname] if (!path) or path == '' or force if path = File .which(command) @macros[macroname] = path end end if path and File .executable?(path) print "#{command} is .. #{path}\n" else search_abort(command, macroname) if abort return nil end end ################################################################a private def search_abort(missing, macroname) if option_name = @config_table .option_name(macroname) helping_option = "#{option_name} or --help" else helping_option = "--help" end STDERR .print "######################################################\n" STDERR .print "Fatal: could not find #{missing} .. aborting.\n" STDERR .print "Fatal: option #{helping_option} may help you.\n" STDERR .print "######################################################\n" exit(1) end def make_macro_name(name) return '@@MHC_' + name .sub(/^-*/, '') .tr('a-z-', 'A-Z_') + '@@' end def replace_keywords1(src_file_name, dst_file_name, keywords, mode = nil) src_file = File .open(src_file_name, "r") or die "#{$!}\n" dst_file = File .open(dst_file_name, "w") or die "#{$!}\n" src_contents = src_file .gets(nil); src_file .close src_contents .force_encoding("ASCII-8BIT") if RUBY_VERSION .to_f >= 1.9 keywords .each{|key, val| src_contents .gsub!(key, val)} if src_contents =~ /(@@MHC_[a-z\d_]+@@)/in STDERR .print "Warn: keyword #{$1} was remiained in #{dst_file_name}.\n" end dst_file << src_contents dst_file .close File .chmod(mode, dst_file_name) if mode end end ### Copyright Notice: ## Copyright (C) 2000 MHC developing team. All rights reserved. ## Redistribution and use in source and binary forms, with or without ## modification, are permitted provided that the following conditions ## are met: ## ## 1. Redistributions of source code must retain the above copyright ## notice, this list of conditions and the following disclaimer. ## 2. Redistributions in binary form must reproduce the above copyright ## notice, this list of conditions and the following disclaimer in the ## documentation and/or other materials provided with the distribution. ## 3. Neither the name of the team nor the names of its contributors ## may be used to endorse or promote products derived from this software ## without specific prior written permission. ## ## THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' ## AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ## LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ## FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ## THE TEAM OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ## INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ## (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ## SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ## HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, ## STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ## ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED ## OF THE POSSIBILITY OF SUCH DAMAGE. ### mhc-make.rb ends here yoshinari-nomura-mhc-815a36a/mhc-sync.in000066400000000000000000000324301222073515200201670ustar00rootroot00000000000000#!@@MHC_RUBY_PATH@@ # -*- ruby -*- ### mhc-sync -- Data synchronization tool for MHC. ## ## Author: Yoshinari Nomura ## ## Created: 2000/04/26 ## Revised: $Date: 2000/10/30 16:43:25 $ ## ## mhc-sync [-n] [-x exchange_id] [-r local_dir] [user@]remote.host[:dir] ## ## -n : Do nothing effectives. Useful for checking. ## -x exchange_id : Set identical id for each pair of machines. ## -r dir : Set local repository directory of the MHC. ## (default: ~/Mail/schedule) ## ## * You must install ssh and mhc-sync in both systems. ## * Before you use it, you must make sure that the remote ## repository and the local repository are identical. ## ## for example on your note pc. ## rsync -a --delete \ ## server_host:/home/someone/Mail/schedule/ /home/someone/Mail/schedule ## (add or not add the trailing / is meaningful) ## TODO: ## Much more Error Checking... ## Repository is not unconfigurable yet. ## ## mhc-sync -s [-n] [-x exchange_id] [-r local_dir] ## -- server mode. do not invoke by hand. ## ## global settings. ## require 'mhc-kconv' require 'mhc-date' require 'mhc-schedule' $DEBUG = false STDOUT .sync = true STDIN .sync = true $SSH = 'ssh' $CMD = 'mhc-sync' $DELIMITER = "\x1\x1\x1\x1\n" $DELIMITER2 = "\x1\x1\x1\x1\x1\x1\x1\x1\n" $CONFLICT_INFO = "-- conflict --" * 5 + "\n" ## ## add some functionalities to MhcScheduleDB ## class MhcScheduleItem def info ret = format("%s (first occurred %s)", subject, occur_min .to_s1('-')) return MhcKconv::todisp(ret) end end class MhcScheduleDB def modify_sch(sch) old_sch = get_record_by_id(sch .rec_id) del_sch(old_sch, false) if old_sch add_sch(sch) end def scan_all @record_id_to_path_hash = {} Dir .glob(@basedir + '/{[0-9]*/[0-9]*,intersect}/[0-9]*') .each{|filename| file = File .open(filename, 'r') header = file .gets("\n\n") file .close if header =~ /^X-SC-Record-Id:\s*(\S+)/i @record_id_to_path_hash[$1] = filename STDERR .print "#{filename} -> #{$1}\n" if $DEBUG end } return self end def get_record_by_id(record_id) if @record_id_to_path_hash[record_id] return MhcScheduleItem .new(@record_id_to_path_hash[record_id]) else return nil end end end ## ## option check ## def usage print ' usage: mhc-sync [-n] [-x exchange_id] [-r local_dir] [user@]remote.host[:dir] -n : Do nothing effectives. Useful for checking. -x exchange_id : Set identical id for each pair of machines. -r local_dir : Set local repository directory of the MHC. (default: ~/Mail/schedule) * You must install ssh and mhc-sync in both systems. * Before you use it, you must make sure that the remote repository and the local repository are identical. ' exit 1 end $flag_noharm, $flag_syncid, $flag_serverp = false, nil, false $flag_server_user, $flag_server_host, $flag_server_dir = nil, nil, nil $flag_dir = File .expand_path("~/Mail/schedule") $flag_log_file = nil while ARGV .length > 0 case ARGV[0] when '-n' $flag_noharm = true when '-s' $flag_serverp = true when '-x' ARGV .shift $flag_syncid = ARGV[0] when '-r' ARGV .shift $flag_dir = ARGV[0] usage() if ! File .directory?($flag_dir) when /^-/ usage() else if ARGV[0] =~ /(([^@]+)@)?([^:\s]+)(:(.*))?/ $flag_server_user, $flag_server_host, $flag_server_dir = $2, $3, $5 else usage() end end ARGV .shift end $flag_log_file = $flag_dir + '/.mhc-db-log' usage() if $flag_serverp and $flag_server_host usage() if !$flag_serverp and !$flag_server_host if $DEBUG STDERR .print "Serverp = #{$flag_serverp .inspect}\n" STDERR .print "Dry run = #{$flag_noharm .inspect}\n" STDERR .print "Sync id = #{$flag_syncid .inspect}\n" STDERR .print "Remote user = #{$flag_server_user .inspect}\n" STDERR .print "Remote host = #{$flag_server_host .inspect}\n" STDERR .print "Remote repository = #{$flag_server_dir .inspect}\n" STDERR .print "Local repository = #{$flag_dir .inspect}\n" STDERR .print "Local logfile = #{$flag_log_file .inspect}\n" end ## ## ## if $flag_serverp STDERR .print "Initalizing remote (exchange_id=#{$flag_syncid}) ..." else STDERR .print "Initalizing local ..." end db = MhcScheduleDB .new($flag_dir).scan_all log = MhcLog .new($flag_log_file) log_entry = log .shrink_entries($flag_syncid) STDERR .print " done.\n" ################ # server side ################ if $flag_serverp ## server sends: ## ## M 2000-05-22 13:45:43 ... (1) ## M 2000-05-22 13:45:43 ... (2) ## DELIMITER ## contents of (1) ## DELIMITER ## contents of (2) ## : ## DELIMITER ## contents of (n) ## DELIMITER2 log_entry .each{|e| print e .to_s, "\n" } log_entry .each{|e| if e .status == 'M' or e .status == 'A' print $DELIMITER sch = db .get_record_by_id(e .rec_id) if sch print sch .dump else STDERR .print "#{e .rec_id} missing\n" end end } print $DELIMITER2 lines = '' got_delimiter = false while line = STDIN .gets if line =~ /^#{$DELIMITER2}/ got_delimiter = true break end lines += line end if got_delimiter commands = lines .split($DELIMITER) commands .each{|command| if command =~ /^DELETE\s+(\S+)/ rec_id = $1 sch = db .get_record_by_id(rec_id) if sch STDERR .print "server: deleting #{sch .info}\n" if !$flag_noharm db .del_sch(sch) else STDERR .print "S:deleting #{sch .info}\n" end end elsif command =~ /^MODIFY/ dummy, sch_string = command .split("\n", 2) sch = MhcScheduleItem .new(sch_string, false) if !$flag_noharm db .modify_sch(sch) else STDERR .print "S:modifiying #{sch .info}\n" STDERR .print "*" * 70, "\n" STDERR .print sch .dump STDERR .print "*" * 70, "\n" end end } logent = MhcLogEntry .new('S', Time .now, $flag_syncid) if !$flag_noharm log .add_entry(logent) else STDERR .print "S:adding log entry #{logent}\n" end end ################ # client side ################ else STDERR .print"Connecting #{$flag_server_host} ...\n" svr = ($flag_server_user ? $flag_server_user + '@':'') + $flag_server_host dry = $flag_noharm ? '-n' : '' xid = $flag_syncid ? "-x #{$flag_syncid}" : '' dir = $flag_server_dir ? "-r #{$flag_server_dir}" : '' STDERR .print "#{$SSH} -x #{svr} #{$CMD} -s #{dry} #{xid} #{dir}\n" if $DEBUG inout = IO .popen("#{$SSH} -x #{svr} #{$CMD} -s #{dry} #{xid} #{dir}", "r+") inout .sync = true lines = '' svr_log_entry = {} svr_sch_entry = {} cli_log_entry = {} while line = inout .gets break if line =~ /^#{$DELIMITER2}/ lines += line end log_lines, sch_lines = lines .split($DELIMITER, 2) if log_lines log_lines .split("\n") .each{|line| STDERR .print "LOGENTRY: #{line}\n" if $DEBUG ent = MhcLogEntry .new(line) svr_log_entry[ent .rec_id] = ent } end if sch_lines sch_lines .split($DELIMITER) .each{|sch_article| sch = MhcScheduleItem .new(sch_article, false) svr_sch_entry[sch .rec_id] = sch } end ################ log_entry .each{|e| cli_log_entry[e .rec_id] = e } ################################################################ # # D ... Deleted # M ... Modified or Created # - ... No entry or no change after last sync. # # Local # +---+---------------------------------+ # R | | D M - | # e +---+---------------------------------+ # m | D | -- CONFLICT L DELETE | # o | M | CONFLICT CONFLICT R->L | # t | - | R DELETE L->R -- | # e +---+---------------------------------+ # # keys = (cli_log_entry .keys + svr_log_entry .keys) .uniq keys .each{|rec_id| l_val = cli_log_entry[rec_id] r_val = svr_log_entry[rec_id] l_status, r_status = '-', '-' r_status = r_val .status if r_val l_status = l_val .status if l_val r_status = 'M' if r_status == 'A' l_status = 'M' if l_status == 'A' lr_status = l_status + r_status r_sch = svr_sch_entry[rec_id] l_sch = db .get_record_by_id(rec_id) # STDERR .print "lr_status(#{rec_id}): #{lr_status}\n" case lr_status when 'DD' # peaceful ;; when 'DM' # conflict ## add the remote article to the local and inform it. STDERR .print "---------------------------------------------------\n" STDERR .print "You modified #{rec_id} : #{r_sch .info} in remote. " STDERR .print "But you deleted it in local at the same time.\n" STDERR .print "I tranferred it from remote to local again.\n" if !$flag_noharm db .add_sch(r_sch) else STDERR .print "C:adding #{r_sch .info}\n" STDERR .print "*" * 70, "\n" STDERR .print r_sch .dump STDERR .print "*" * 70, "\n" end when 'D-' # delete remote STDERR .print "---------------------------------------------------\n" STDERR .print "Delete remote #{rec_id}\n" inout .print "DELETE #{rec_id}\n" inout .print $DELIMITER when 'MD' # conflict ## add the remote article to the local and inform it. STDERR .print "---------------------------------------------------\n" STDERR .print "You modified #{rec_id} : #{l_sch .info} in local. " STDERR .print "But you deleted it in remote at the same time.\n" STDERR .print "I preserve the local one.\n" when 'MM' # conflict ## add the remote article to the local and inform it. STDERR .print "---------------------------------------------------\n" STDERR .print "You modified #{rec_id} : \n#{l_sch .info} in local.\n" STDERR .print "But you modified it in remote at the same time.\n" STDERR .print "I concatinate the remote one to the local one.\n" STDERR .print "Also, I preserved the remote one.\n" STDERR .print "Please reedit the local one and do sync again.\n" l_sch .set_description(l_sch .description .to_s + $CONFLICT_INFO + r_sch .dump) if !$flag_noharm db .modify_sch(l_sch) else STDERR .print "C:modifiying #{l_sch .info}\n" STDERR .print "*" * 70, "\n" STDERR .print l_sch .dump STDERR .print "*" * 70, "\n" end when 'M-' # transfer local to remote STDERR .print "---------------------------------------------------\n" STDERR .print "Transfer local to remote #{l_sch .info}\n" inout .print "MODIFY\n" inout .print "#{l_sch .dump}" inout .print $DELIMITER when '-D' # delete local if l_sch STDERR .print "---------------------------------------------------\n" STDERR .print "Delete local #{l_sch .info}\n" db .del_sch(l_sch) if !$flag_noharm end when '-M' # transfer remote to local STDERR .print "---------------------------------------------------\n" STDERR .print "Transfer remote to local #{r_sch .info}\n" if !$flag_noharm db .modify_sch(r_sch) else STDERR .print "C:modifiying #{r_sch .info}\n" STDERR .print "*" * 70, "\n" STDERR .print r_sch .dump STDERR .print "*" * 70, "\n" end when '--' # peaceful ;; end } inout .print $DELIMITER2 logent = MhcLogEntry .new('S', Time .now, $flag_syncid) if !$flag_noharm log .add_entry(logent) else STDERR .print "C:adding log entry #{logent}\n" end end ### Copyright Notice: ## Copyright (C) 1999, 2000 Yoshinari Nomura. All rights reserved. ## Copyright (C) 2000 MHC developing team. All rights reserved. ## Redistribution and use in source and binary forms, with or without ## modification, are permitted provided that the following conditions ## are met: ## ## 1. Redistributions of source code must retain the above copyright ## notice, this list of conditions and the following disclaimer. ## 2. Redistributions in binary form must reproduce the above copyright ## notice, this list of conditions and the following disclaimer in the ## documentation and/or other materials provided with the distribution. ## 3. Neither the name of the team nor the names of its contributors ## may be used to endorse or promote products derived from this software ## without specific prior written permission. ## ## THIS SOFTWARE IS PROVIDED BY Yoshinari Nomura AND CONTRIBUTORS ``AS IS'' ## AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ## LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ## FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ## Yoshinari Nomura OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ## INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ## (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ## SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ## HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, ## STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ## ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED ## OF THE POSSIBILITY OF SUCH DAMAGE. ### mhc-sync ends here yoshinari-nomura-mhc-815a36a/mhc2ol.in000066400000000000000000000652651222073515200176460ustar00rootroot00000000000000#!@@MHC_RUBY_PATH@@ # -*- coding: utf-8; mode: ruby; -*- ### mhc2ol -- copy articles from mhc to Outlook. ## ## Author: MIYOSHI Masanori ## Yoshinari Nomura ## ## ## Created: 2001/09/15 ## Revised: $Date: 2006/10/27 00:53:10 $ ## $DEBUG = false STDOUT .sync= true STDERR .sync= true require 'win32ole' require 'mhc-kconv' require 'mhc-date' require 'mhc-schedule' module OlConst end module RepeatPattern class Period def initialize(sdate, edate, stime, etime) if stime v = stime .to_a() if v[0] >= 24 stime = MhcTime .new(v[0] - 24, v[1]) sdate = sdate .succ(1) end end if etime v = etime . to_a() if v[0] >= 24 etime = MhcTime .new(v[0] - 24, v[1]) edate = edate .succ(1) end end @sdate = sdate @edate = edate @stime = stime @etime = etime end def get_period() [@sdate, @edate] end def get_duration() if @edate .nil? || @sdate .nil? 60 * 24 else (@edate - @sdate + 1) * 60 * 24 # min end end def get_time() [@stime, @etime] end def get_sdatetime if @stime .nil? Time .local(@sdate. y, @sdate. m, @sdate .d, 0, 0) else Time .local(@sdate. y, @sdate. m, @sdate .d, @stime .hh, @stime .mm) end end def get_edatetime if @stime .nil? Time .local(@edate. y, @edate. m, @edate .d, 0, 0) else Time .local(@edate. y, @edate. m, @edate .d, @etime .hh, @etime .mm) end end def handle_recurrence(ol_appoint) end def get_recurrence(ol_appoint) rp = ol_appoint .GetRecurrencePattern() rp .Interval = @interval if @interval rp .PatternStartDate = Exporter .to_ol_date(@sdate) if @sdate rp .PatternEndDate = Exporter .to_ol_date(@edate) if @edate if @stime || @etime rp .Duration = 0 rp .StartTime = @stime .to_s if @stime rp .EndTime = @etime .to_s if @etime else rp .Duration = 60 * 24 end return rp end end class NonRepeat < Period def initialize(sdate, stime, etime) super(sdate, sdate, stime, etime) end end class Daily < Period def initialize(start, finish, stime, etime, interval) super(start, finish, stime, etime) @interval = interval end end class Weekly < Period def initialize(start, finish, stime, etime, interval, dow) super(start, finish, stime, etime) @interval = interval @dow = dow end def handle_recurrence(ol_appoint) rp = get_recurrence(ol_appoint) mask = 0 for i in 0..6 mask += (1 << i) if @dow[i] end rp .RecurrenceType = OlConst::OlRecursWeekly rp .DayOfWeekMask = mask end end class MonthlyByDate < Period def initialize(start, finish, stime, etime, interval) super(start, finish, stime, etime) @interval = interval end def handle_recurrence(ol_appoint) # DBI: multiple days should be supported. rp = get_recurrence(ol_appoint) rp .RecurrenceType = OlConst::OlRecursMonthly rp .DayOfMonth = @sdate .d() end end class MonthlyByDow < Period def initialize(start, finish, stime, etime, interval, wom, dow) super(start, finish, stime, etime) @interval = interval @wom = wom @dow = dow end def handle_recurrence(ol_appoint) # DBI: multiple days should be supported. rp = get_recurrence(ol_appoint) rp .RecurrenceType = OlConst::OlRecursMonthNth rp .DayOfWeekMask = (1 << @dow) # Instance(week of month) begins with 1 rp .Instance = [@wom + 1, 5] .min() end end class Yearly < Period def initialize(start, finish, stime, etime, interval) super(start, finish, stime, etime) @interval = interval end def handle_recurrence(ol_appoint) # DBI: multiple months should be supported. rp = get_recurrence(ol_appoint) rp .RecurrenceType = OlConst::OlRecursYearly rp .DayOfMonth = @sdate .d() rp .MonthOfYear = @sdate .m() end end class YearlyNth < Period def initialize(start, finish, stime, etime, wom, dow) super(start, finish, stime, etime) @wom = wom @dow = dow end def handle_recurrence(ol_appoint) # DBI: multiple months should be supported. rp = get_recurrence(ol_appoint) rp .RecurrenceType = OlConst::OlRecursYearNth rp .MonthOfYear = @sdate .m() rp .DayOfWeekMask = (1 << @dow) rp .Instance = @wom + 1 # Instance(week of month) begins with 1 end end end def usage print ' usage: mhc2ol [-a | -i | -d | -N] [-A] [-H] [-n] [-s] [-m] [-r dir] [-c category] [YYYYMMDD-yyyymmdd] mhc2ol -- Add/Copy mhc articles to Outlook. -v : Verbose mode. -a : Add mhc articles to Outlook. all the original records of Outlook will remain. -i : Copy mhc articles into Outlook. all the original records of Outlook will be lost. -d : Copy mhc articles into Outlook. Only the records of Outlook in `MHC-sch\' category will be lost. -N : Copy only the articles that have been modified since the last execution. -H : Add/Copy mhc articles to Outlook without HEADER part. -n : Do nothing effectives. Useful for checking. -s : Split appointments and tasks. -m : Append an additional category `MHC-sch\'. -r dir : Set repository directory of the mhc. ~/Mail/schedule -c : Copy only the mhc articles of which the category matches the specified regexp. -A : Disable reminder if the mhc article already has been passed. YYYYMMDD-yyyymmdd : set a start and end date of scanning mhc. if omitted, scan from 3 months ago to 3 months after. ' exit 1 end ## ## sub routines. ## class MhcScheduleItem ## the following method is imported from mhc-schedule.rb ## convert to Outlook Datebook record. def to_outlook() dates = [] day_cp = day .dup() ### for repeat beg, fin = occur_min, occur_max fin = nil if fin == DURATION_MAX ## First, treat X-SC-Day: field. while day_cp .length > 0 if ((day_cp .length > 1 \ && day_cp .length == day_cp .max - day_cp .min + 1) \ && (time_b == nil && time_e == nil)) ## repeat in a series of days -- make up as a daily. dates << RepeatPattern::Daily .new(day_cp .min, day_cp .max, time_b, time_e, 1) day_cp = [] else dates << RepeatPattern::NonRepeat .new(day_cp .shift, time_b, time_e) end end ## Second, treat X-SC-Cond: field. if cond .length == cond_wek .length && cond_wek .length > 0 ## weekly weeks = [] for w in 0 .. 6 weeks << cond_wek .include?(MhcDate::W_LABEL[w]) ? true : false end dates << RepeatPattern::Weekly .new(beg, fin, time_b, time_e, 1, weeks) elsif cond_ord .length >= 1 && !cond_ord .include?('5th') && cond_wek .length >= 1 && cond_num .length == 0 && cond_mon .length == 0 ## monthly by day cond_ord .each{|ord_str| cond_wek .each{|wek_str| ord = MhcDate::O_LABEL .index(ord_str .downcase()) wek = MhcDate::W_LABEL .index(wek_str) sch2 = MhcScheduleItem .new .add_cond(ord_str) .add_cond(wek_str) beg2 = beg .dup while !sch2 .occur_on?(beg2) ## xxx 多分これは不要? beg2 .succ! end dates << RepeatPattern::MonthlyByDow .new(beg2, fin, time_b, time_e, 1, ord, wek) } } elsif cond_num .length == 1 && cond_num .length == cond .length ## monthly by date while !occur_on?(beg) ## xxx こっちは必要 beg .succ! end dates << RepeatPattern::MonthlyByDate .new(beg, fin, time_b, time_e, 1) elsif cond_num .length == 1 && cond_mon .length == 1 && cond_wek .length == 0 && cond_ord .length == 0 ## yearly by date y = beg .y m = MhcDate::M_LABEL .index(cond_mon[0]) + 1 d = cond_num[0] .to_i date = MhcDate .new(y, m, d) if date < beg date .y_succ! end ## 2/29 はどうする? dates << RepeatPattern::Yearly .new(date, fin, time_b, time_e, 1) elsif cond_ord .length == 1 && cond_ord[0] != '5th' && cond_wek .length == 1 && cond_num .length == 0 && cond_mon .length == 1 ## yearly by day ord = MhcDate::O_LABEL .index(cond_ord[0]) wek = MhcDate::W_LABEL .index(cond_wek[0]) m = MhcDate::M_LABEL .index(cond_mon[0]) + 1 date = MhcDate .new(beg .y, m, 1) if date .m < beg .m date .y_succ! end while !occur_on?(date) date .succ! end dates << RepeatPattern::YearlyNth .new(date, fin, time_b, time_e, ord, wek) elsif cond .empty? ## do nothing else ## conversion failed. dates = [] end if dates .empty? # STDERR .print "#{occur_min .to_js} : #{subject} unsupported. ignored..\n" return nil else return dates end end def dump_without_header desc = description .to_s desc += "\n" if desc != '' and desc !~ /\n\z/n return desc end end class Exporter @@sync_file = File .expand_path("~/Mail/schedule/.ol_sync") @@flag_verbose = false @@flag_install = false @@flag_export_part = 'all' # 'all' || 'body_only' @@flag_noharm = false @@flag_timestamp = false @@flag_disable_passed_sch = false @@mhc_category_name = 'MHC-sch' @@additional_category = false def initialize(mdb, outlook) @mhc_db = mdb @outlook = outlook @category_regexp = "" @last_sync_infos = [] if @@flag_timestamp begin fp = open(@@sync_file, 'r') @last_sync_infos = Marshal .load(fp) rescue ensure fp .close() if fp end else begin File .delete(@@sync_file) rescue end end @ol_name_space = @outlook .GetNamespace("MAPI") folder_type = OlConst::OlFolderCalendar @ol_calendar = @ol_name_space .GetDefaultFolder(folder_type) folder_type = OlConst::OlFolderTasks @ol_tasks = @ol_name_space .GetDefaultFolder(folder_type) end def get_ol_appointment(id) ap = nil begin ap = @ol_name_space .GetItemFromID(id, @ol_calendar.StoreID) if ap.Parent.DefaultItemType != OlConst::OlAppointmentItem ap = nil end rescue end ap end private :get_ol_appointment def get_ol_task(id) ap = nil begin tsk = @ol_name_space .GetItemFromID(id, @ol_tasks.StoreID) if tsk.Parent.DefaultItemType != OlConst::OlTaskItem tsk = nil end rescue end tsk end private :get_ol_task def ol_is_update?(ol_infos) is_update = false for info in ol_infos entry_id = info[0] last_modified_time = info[1] appoint = get_ol_appointment(entry_id) if appoint == nil || appoint .LastModificationTime != last_modified_time is_update = false break end is_update = true end is_update end private :ol_is_update? def delete_ol_appointments(ol_infos) for info in ol_infos entry_id = info[0] appoint = get_ol_appointment(entry_id) if appoint print "deleting ", appoint .Subject, "\n" if @@flag_verbose appoint .delete() end entry_id = info[2] task = get_ol_task(entry_id) if entry_id if task print "deleting ", task .Subject, "\n" if @@flag_verbose task .delete() end end end private :delete_ol_appointments def setup_ol_appointments(periods, sch) ol_info = [] for period in periods appoint = @outlook .CreateItem(OlConst::OlAppointmentItem) sdate, edate = period .get_period() sdate = Exporter .to_ol_date(sdate) edate = Exporter .to_ol_date(edate) edate = sdate if !edate print "Subject:", MhcKconv::todisp(sch .subject()), "\n" if @@flag_verbose appoint .Subject = MhcKconv::todisp(sch .subject()) appoint .Location = MhcKconv::todisp(sch .location()) if sch.location() print "Time: ", sch .time_as_string(), "\n" if @@flag_verbose print "Path: ", sch .path(), "\n" if @@flag_verbose stime, etime = period .get_time() sdate += " " + stime .to_s if sdate && stime etime_tmp = if etime then etime else stime end edate += " " + etime_tmp .to_s if edate && etime_tmp print "Date: ", sdate, "-", edate, "\n" if @@flag_verbose appoint .Start = sdate if sdate appoint .End = edate if edate # If any time is not specified, the appointment is a kind of AllDayEvent. if !stime && !etime appoint .AllDayEvent = true appoint .Duration = period .get_duration() end cat_string = sch .category_as_string() if @@flag_additional_category cat_string = @@mhc_category_name + "," + cat_string end appoint .Categories = cat_string case @@flag_export_part when 'all' appoint .Body = MhcKconv::todisp(sch .dump()) when 'body_only' appoint .Body = MhcKconv::todisp(sch .dump_without_header()) end # a reminder is valid for a future schedule. if sch .alarm() != nil then if period .get_sdatetime >= Time .now && $flag_disable_passed_sch appoint .ReminderSet = true appoint .ReminderMinutesBeforeStart = sch .alarm() / 60 else appoint .ReminderSet = false end else appoint .ReminderSet = false end # handle recurrence. period .handle_recurrence(appoint) # contents of appointment cats = sch .category_as_string() .downcase .split(' ') todo_p = true if cats .delete('todo') done_p = true if cats .delete('done') appoint .Sensitivity = OlConst::OlPrivate if cats .include?('private') cat_string = cats .join(',') if @@flag_additional_category cat_string = @@mhc_category_name + "," + cat_string end appoint .Categories = cat_string case @@flag_export_part when 'all' appoint .Body = MhcKconv::todisp(sch .dump()) when 'body_only' appoint .Body = MhcKconv::todisp(sch .dump_without_header()) end appoint .Save() if !$flag_separation || !todo_p # Copy TODO if todo_p task = @outlook .CreateItem(OlConst::OlTaskItem) sdate, edate = sch .duration task .StartDate = Exporter .to_ol_date(sdate) || appoint .Start task .DueDate = Exporter .to_ol_date(edate) || task .StartDate if done_p task .Complete = true task .DateCompleted = appoint .End end if !sch .priority || sch .priority < 50 task .Importance = OlConst::OlImportanceLow elsif sch .priority < 80 task .Importance = OlConst::OlImportanceNormal else task .Importance = OlConst::OlImportanceHigh end task .Categories = appoint .Categories task .Sensitivity = appoint .Sensitivity task .Subject = appoint .Subject task .Body = appoint .Body task .ReminderSet = false task .Save() print " - And set it to Task\n" if @@flag_verbose ol_info << [appoint .EntryID, appoint .LastModificationTime, task .EntryID] else ol_info << [appoint .EntryID, appoint .LastModificationTime, nil] end end ol_info end private :setup_ol_appointments def sync_from_outlook(sch, last_sync_info) ## Outlook側での更新内容をmhcに取り込む. 取り込む内容は場所 ## (Location), 期限(Day), 時間(Time), 完了フラグ(TODO/DONE), 優先 ## 順位(Priority), 期間(Duration) とする. 分類(Category)は変換ルー ## ルが定義できないとまずいハズ. entry_id = last_sync_info[0] appoint = get_ol_appointment(entry_id) if entry_id entry_id = last_sync_info[2] task = get_ol_task(entry_id) if entry_id cats = sch .category_as_string() .split(' ') # ol_appointから 場所, 期限, 時間 を取り込む. if appoint sch.set_location(MhcKconv::toeuc(appoint .Location)) # 期限/時刻: どうしよう？ appoint .Start / .End end # ol_taskから 期間, 完了フラグ, 優先順位 を取り込む if task # 期間: .StartDate, .DueDate # 完了フラグ: Complete, DateCompleted if task .Complete if ! cats .include?('done') # 今回完了した仕事. 作業期間をBodyに埋め込む sch .description = sch .duration + sch .description sch .set_duration( nil , nil) cats .delete('todo') # 削除 cats .add('done') # 追加 end end # 優先順位: .Importance end # 期間変更は ol_task, ol_appoint の変更をマージする必要あり? 基本 # 的に後優先で取り込む. sch .add_sch # 更新されたlast_sync_infoを返す last_sync_info end private :sync_from_outlook def send_to_outlook(periods, sch) if sch. path() file = sch .path() rec_id = sch .rec_id() else file = MhcScheduleDB::DEF_RCFILE rec_id = (sch .subject() + sch .category_as_string()\ + sch .cond_as_string() + "@dot.schedule") end sync_info = [rec_id, File .mtime(file)] # check if schedules are up-to-date. is_update = false last_sync_info = @last_sync_infos .assoc(rec_id) if last_sync_info ## 前回のsync情報がある場合 @last_sync_infos .delete(last_sync_info) mhc_last_modified_time = last_sync_info[1] ol_last_sync_infos = last_sync_info[2] ## mhc側が更新されているか？ mhc_is_modified = (File .mtime(file) != mhc_last_modified_time) ## (mhc未更新のとき)Outlook側が更新されているか？ is_update = ol_is_update?(ol_last_sync_infos) unless mhc_is_modified ## mhc更新済み または mhc未更新かつOutlook未更新のとき ## → Outlookエントリを削除する(mhcエントリを再度提供する). delete_ol_appointments(ol_last_sync_infos) unless is_update end if is_update ## mhc未更新かつOutlook更新済み. Outlookエントリは残してある. sync_info << ol_last_sync_infos #TODO: Outlookにもとづいてmhcを更新する # sync_info << sync_with_outlook(sch, last_sync_info) print "copying to Outlook is skipped!\n" if @@flag_verbose else ## 上記以外. Outlookエントリはもともとないか削除済み. sync_info << setup_ol_appointments(periods, sch) print "\n" if @@flag_verbose end sync_info end private :send_to_outlook def export(from, to) @sync_infos = [] sch_count, sent = 0, 0 @mhc_db .each_sch(from, to) {|sch| next unless @category_regexp .match(sch .category_as_string()) sch_count += 1 print "adding ", MhcKconv::todisp(sch .subject), "\n" if @@flag_verbose if periods = sch .to_outlook() if @@flag_verbose print " converted into #{periods .length} Outlook article(s)." end if !$flag_noharm print " sending to Outlook ...\n " if @@flag_verbose sync_info = send_to_outlook(periods, sch) if ! sync_info .nil? @sync_infos << sync_info sent += 1 print "." else print MhcKconv::todisp("(#{sch .subject}) write_error\n") end else print " not sent.\n" if @@flag_verbose end else print "failed to convert." print MhcKconv::todisp(" subject: #{sch .subject}\n") print " first occured: #{sch .occur_min}\n" print " path: #{file}\n" end print "\n" if @@flag_verbose } print "\n" print "\n#{sent}/#{sch_count} article(s) successfully sent.\n" @sync_infos end def delete_unmanaged_schedules() if !@@flag_noharm for table in @last_sync_infos ol_infos = table[2] for info in ol_infos entry_id = info[0] appoint = get_ol_appointment(entry_id) appoint .delete() if appoint end end end end def write_sync_info() if !@@flag_noharm begin fp = open(@@sync_file, 'w') Marshal .dump(@sync_infos, fp) rescue ensure fp .close() if fp end end end def delete_ol_schedules() if (@@flag_install || @@flag_discreet) && !@@flag_noharm # Appointments print "deleting appointments in Outlook." items = @ol_calendar .items() index = items .Count while index > 0 do cats = items. Item(index) .Categories unless @@flag_discreet && !cats .include?(@@mhc_category_name) items .Remove(index) end index -= 1 print "." end print ".. done.\n" # Tasks print "deleting tasks in Outlook." items = @ol_tasks .items() index = items .Count while index > 0 do cats = items. Item(index) .Categories unless @@flag_discreet && !cats .include?(@@mhc_category_name) items .Remove(index) end index -= 1 print "." end print ".. done.\n" end end def Exporter.set_sync_filename(name) @@sync_file = name end def Exporter.set_flag_verbose(flag) @@flag_verbose = flag end def Exporter.set_flag_install(flag) @@flag_install = flag end def Exporter.set_flag_discreet(flag) @@flag_discreet = flag end def Exporter.set_flag_export_part(flag) @@flag_export_part = flag end def Exporter.set_flag_noharm(flag) @@flag_noharm = flag end def Exporter.set_flag_timestamp(flag) @@flag_timestamp = flag end def Exporter.set_flag_additional_category(flag) @@flag_additional_category = flag end def Exporter.set_flag_disable_passed_sch(flag) @@set_flag_disable_passed_sch = flag end def Exporter.to_ol_date(date) format("%4d/%02d/%02d", date .y(), date .m(), date .d()) if date end def set_category_regexp(category_regexp) @category_regexp = category_regexp end end ## ## option check. ## $flag_verbose = false $flag_noharm, $flag_append, $flag_install = false, false, false $flag_export_part = 'all' # 'all' || 'body_only' $flag_from, $flag_to = nil, nil $flag_timestamp = nil $flag_category_regexp = Regexp .new("") $flag_dir = File .expand_path("~/Mail/schedule") $flag_separation = false $flag_discreet = false $flag_additional_category = false $flag_disable_passed_sch = false while ARGV .length > 0 case ARGV[0] when '-v' $flag_verbose = true when '-a' $flag_append = true when '-i' $flag_install = true when '-d' $flag_discreet = true when '-H' $flag_export_part = 'body_only' when '-n' $flag_noharm = true when '-r' ARGV .shift $flag_dir = ARGV[0] when '-c' ARGV .shift $flag_category_regexp = Regexp .new(ARGV[0], true); when /^(\d{8})-(\d{8})$/ $flag_from, $flag_to = MhcDate .new($1), MhcDate .new($2) when '-N' $flag_timestamp = true when '-s' $flag_separation = true when '-m' $flag_additional_category = true when '-A' $flag_disable_passed_sch = true else usage() end ARGV .shift end $flag_from = MhcDate .new .m_succ!(-3) if !$flag_from $flag_to = MhcDate .new .m_succ!(+3) if !$flag_to usage() unless (($flag_append && !$flag_install \ && !$flag_discreet && !$flag_timestamp) \ ||(!$flag_append && $flag_install \ && !$flag_discreet && !$flag_timestamp) \ || (!$flag_append && !$flag_install \ && $flag_discreet && !$flag_timestamp) \ || (!$flag_append && !$flag_install \ && !$flag_discreet && $flag_timestamp)) ## ## Initialize Outlook OLE Automation object ## begin outlook = WIN32OLE .new('Outlook.Application') WIN32OLE .const_load(outlook, OlConst) rescue STDERR .print("Cannot find Outlook in your PC!\n") STDERR .print("Please install Outlook (*NOT* Outlook Express) before execute this command.\n") exit(1) end ## ## Open mhc & copy to Outlook ## mdb = MhcScheduleDB .new($flag_dir) Exporter .set_sync_filename($flag_dir + "/.ol_sync") Exporter .set_flag_verbose($flag_verbose) Exporter .set_flag_install($flag_install) Exporter .set_flag_export_part($flag_export_part) Exporter .set_flag_discreet($flag_discreet) Exporter .set_flag_noharm($flag_noharm) Exporter .set_flag_timestamp($flag_timestamp) Exporter .set_flag_additional_category($flag_additional_category) Exporter .set_flag_disable_passed_sch($flag_disable_passed_sch) exporter = Exporter .new(mdb, outlook) exporter .set_category_regexp($flag_category_regexp) exporter .delete_ol_schedules() exporter .export($flag_from, $flag_to) exporter .delete_unmanaged_schedules() exporter .write_sync_info() ## ## close Outlook & exit ## exit 0 ### Copyright Notice: ## Copyright (C) 1999, 2000 Yoshinari Nomura. All rights reserved. ## Copyright (C) 2000 MHC developing team. All rights reserved. ## Redistribution and use in source and binary forms, with or without ## modification, are permitted provided that the following conditions ## are met: ## ## 1. Redistributions of source code must retain the above copyright ## notice, this list of conditions and the following disclaimer. ## 2. Redistributions in binary form must reproduce the above copyright ## notice, this list of conditions and the following disclaimer in the ## documentation and/or other materials provided with the distribution. ## 3. Neither the name of the team nor the names of its contributors ## may be used to endorse or promote products derived from this software ## without specific prior written permission. ## ## THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' ## AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ## LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ## FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ## THE TEAM OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ## INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ## (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ## SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ## HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, ## STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ## ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED ## OF THE POSSIBILITY OF SUCH DAMAGE. ### mhc2ol ends here yoshinari-nomura-mhc-815a36a/mhc2palm.in000066400000000000000000000130241222073515200201470ustar00rootroot00000000000000#!@@MHC_RUBY_PATH@@ # -*- ruby -*- ### mhc2palm -- copy articles from mhc to palm. ## ## Author: Yoshinari Nomura ## ## Created: 1999/10/08 ## Revised: $Date: 2001/09/13 05:15:17 $ ## $DEBUG = false STDOUT .sync= true STDERR .sync= true require 'mhc-kconv' require 'mhc-palm' require 'mhc-date' require 'mhc-schedule' def usage print ' usage: mhc2palm [-a | -i] [-n] [-d dev] [-r dir] [YYYYMMDD-yyyymmdd] mhc2palm -- Add/Copy mhc articles to a palm. -v : Verbose mode. -a : Add mhc articles to a palm. all the original records of the palm will remain. -i : Copy mhc articles into the palm. all the original records of palm will be lost. -n : Do nothing effectives. Useful for checking. -d dev : Set the device file connected to the palm. default value is /dev/pilot -r dir : Set repository directory of the mhc. ~/Mail/schedule YYYYMMDD-yyyymmdd : set a start and end date of scanning mhc. if omitted, scan from 3 months ago to 3 months after. ' exit 1 end ## ## sub routines. ## def send_to_palm(pdb, p_rec_array) new_id_array = [] p_rec_array .each{|p_rec| if new_id = pdb .write_record(p_rec) print "(new_id = #{new_id}) " if $flag_verbose new_id_array << new_id else return nil # fail. end } print "\n" if $flag_verbose return new_id_array # success. end ## ## option check. ## $flag_verbose = false $flag_noharm, $flag_append, $flag_install = false, false, false $flag_device, $flag_from, $flag_to = '/dev/pilot', nil, nil $flag_dir = File .expand_path("~/Mail/schedule") while ARGV .length > 0 case ARGV[0] when '-v' $flag_verbose = true when '-a' $flag_append = true when '-i' $flag_install = true when '-n' $flag_noharm = true when '-d' ARGV .shift $flag_device = ARGV[0] when '-r' ARGV .shift $flag_dir = ARGV[0] when /^(\d{8})-(\d{8})$/ $flag_from, $flag_to = MhcDate .new($1), MhcDate .new($2) else usage() end ARGV .shift end $flag_from = MhcDate .new .m_succ!(-3) if !$flag_from $flag_to = MhcDate .new .m_succ!(+3) if !$flag_to usage() if !($flag_append || $flag_install) || ($flag_append && $flag_install) ## ## Initialize & open palm ## if !$flag_noharm if !File .exist?($flag_device) STDERR .print "Can not open #{$flag_device}.\n" exit 1 end psock = Pilot .new($flag_device) STDERR .print "Press Sync Button\n" psock .listen pdb = PilotApptDB .new(psock, "DatebookDB") end if $flag_install print "delete all articles in the palm." if !$flag_noharm print (pdb .delete_all ? ".. succeed." : ".. failed.") end print "\n" end ## ## Open mhc & copy to palm ## sch_count, sent = 0, 0 mdb = MhcScheduleDB .new($flag_dir) mdb .each_sch($flag_from, $flag_to){ sch_count += 1 } mdb .each_sch($flag_from, $flag_to){|sch| print "adding ", MhcKconv::todisp(sch .subject), "\n" if $flag_verbose if p_rec_array = sch .to_palm if $flag_verbose print " converted into #{p_rec_array .length} palm article#{p_rec_array .length == 1 ? '' : 's'}." end if !$flag_noharm print " sending to palm ...\n " if $flag_verbose if (! (send_to_palm(pdb, p_rec_array) .nil?)) sent += 1 print "#{sent}/#{sch_count}\r" else print MhcKconv::todisp("\n(#{sch .subject}) write_error\n") end else print " not sent.\n" if $flag_verbose end else print "failed to convert." print MhcKconv::todisp(" subject: #{sch .subject}\n") print " first occured: #{sch .occur_min}\n" print " path: #{sch .path}\n" end print "\n" if $flag_verbose } print "#{sent}/#{sch_count} article#{sent == 1 ? '' : 's'} successfully sent.\n" ## ## close palm & exit ## if !$flag_noharm pdb .reset_sync_flags ## remove all dirty flag in palm. pdb .close psock .close end exit 0 ### Copyright Notice: ## Copyright (C) 1999, 2000 Yoshinari Nomura. All rights reserved. ## Copyright (C) 2000 MHC developing team. All rights reserved. ## Redistribution and use in source and binary forms, with or without ## modification, are permitted provided that the following conditions ## are met: ## ## 1. Redistributions of source code must retain the above copyright ## notice, this list of conditions and the following disclaimer. ## 2. Redistributions in binary form must reproduce the above copyright ## notice, this list of conditions and the following disclaimer in the ## documentation and/or other materials provided with the distribution. ## 3. Neither the name of the team nor the names of its contributors ## may be used to endorse or promote products derived from this software ## without specific prior written permission. ## ## THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' ## AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ## LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ## FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ## THE TEAM OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ## INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ## (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ## SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ## HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, ## STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ## ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED ## OF THE POSSIBILITY OF SUCH DAMAGE. ### mhc2palm ends here yoshinari-nomura-mhc-815a36a/palm2mhc.in000066400000000000000000000114031222073515200201460ustar00rootroot00000000000000#!@@MHC_RUBY_PATH@@ # -*- ruby -*- ### palm2mhc -- copy articles from palm to new mhc repository. ## ## Author: Yoshinari Nomura ## ## Created: 1999/10/08 ## Revised: $Date: 2005/09/08 02:56:14 $ ## $DEBUG = false require 'mhc-kconv' require 'mhc-palm' require 'mhc-date' require 'mhc-schedule' def yes_no(message = '') STDOUT .print message + '? ' STDOUT .flush ans = STDIN .gets return (ans =~ /^ye?s?$/i) end def usage print " palm2mhc -- Add palm articles to a mhc repository. usage: palm2mhc [-a | -u] [-n] [-i] [-d dev] [-r dir] -a : Add all articles of a palm to a mhc repository. -u : Add modified articles of a palm to a mhc repository. -n : Do nothing effectives to mhc. Useful for checking. -i : Interactive. Confirm before install to a mhc repository. -d dev : Set the device file connected to the palm. default value is #{$flag_device} -r dir : Set repository directory of mhc. if not exists, palm2mhc makes the directory. default value is #{$flag_dir} " exit 1 end ## ## option check. ## $flag_interactive = false $flag_update = false $flag_append = false $flag_noharm = false $flag_dir = MhcScheduleDB::DEF_BASEDIR $flag_device = '/dev/pilot' while ARGV .length > 0 case ARGV[0] when '-i' $flag_interactive = true when '-n' $flag_noharm = true when '-u' $flag_update = true when '-a' $flag_append = true when '-d' ARGV .shift $flag_device = ARGV[0] when '-r' ARGV .shift $flag_dir = ARGV[0] else usage() end ARGV .shift end if $flag_device != "net:" && !File .exist?($flag_device) STDERR .print "Can not open #{$flag_device}.\n" exit 1 end usage() if !($flag_update || $flag_append) || ($flag_update && $flag_append) ## ## Open palm & copy to new mhc repository. ## psock = Pilot .new($flag_device) STDERR .print "Press Sync Button\n" if psock .listen pdb = PilotApptDB .new(psock, "DatebookDB") else STDERR .print "Can not open #{$flag_device}.\n" exit 1 end STDERR .print "Connected..\n" mdb = MhcScheduleDB .new($flag_dir) pdb .each_record{|rec| if $flag_append || ($flag_update && rec .attribute_dirty?) x = rec .to_xsc if x print "***************************************************************\n" print MhcKconv::todisp(x .dump) print "***************************************************************\n" if !$flag_noharm if $flag_interactive if yes_no("Do you install this artice to mhc ") mdb .add_sch(x) print "Installed.\n" else print "Ignored.\n" end else mdb .add_sch(x) end end end end } ## ## close palm & exit ## if $flag_noharm ## do nothing else if !$flag_interactive or yes_no("Do you clear dirty flag of the palm ") # commit if ! File .method_defined?("fsync") system("sync") system("sync") end # done. pdb .reset_sync_flags ## remove all dirty flag in palm. print "Dirty flag cleared.\n" else print "Dirty flag not cleared.\n" end end pdb .close psock .close exit 0 ### Copyright Notice: ## Copyright (C) 1999, 2000 Yoshinari Nomura. All rights reserved. ## Copyright (C) 2000 MHC developing team. All rights reserved. ## Redistribution and use in source and binary forms, with or without ## modification, are permitted provided that the following conditions ## are met: ## ## 1. Redistributions of source code must retain the above copyright ## notice, this list of conditions and the following disclaimer. ## 2. Redistributions in binary form must reproduce the above copyright ## notice, this list of conditions and the following disclaimer in the ## documentation and/or other materials provided with the distribution. ## 3. Neither the name of the team nor the names of its contributors ## may be used to endorse or promote products derived from this software ## without specific prior written permission. ## ## THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' ## AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ## LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ## FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ## THE TEAM OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ## INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ## (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ## SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ## HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, ## STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ## ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED ## OF THE POSSIBILITY OF SUCH DAMAGE. ### palm2mhc ends here yoshinari-nomura-mhc-815a36a/ruby-ext/000077500000000000000000000000001222073515200176735ustar00rootroot00000000000000yoshinari-nomura-mhc-815a36a/ruby-ext/README000066400000000000000000000020701222073515200205520ustar00rootroot00000000000000 Created: 2000-02-09 Revised: 2000-05-29 This directory contains some libraries required by Ruby stuffs of the MHC -- gemcal, palm2mhc, mhc2palm and so on. palm2mhc and mhc2palm also require `libpisock', which is a part of the `pilot-link'. gemcal requires Gtk and ruby-gtk. Related web pages: Ruby -- http://www.ruby-lang.org/en/ Gtk -- http://www.gtk.org/ ruby-gtk -- http://www.ueda.info.waseda.ac.jp/~igarashi/ruby/gtk.html.en Pilot-link -- ftp://ryeham.ee.ryerson.ca/pub/PalmOS/ Install: 1. If you want to use gemcal,you must install Gtk and ruby-gtk. see http://www.ueda.info.waseda.ac.jp/~igarashi/ruby/gtk.html.en and http://www.gtk.org/ 2. If you want to mhc2palm and palm2mhc, you must install pilot-link lib. (see ftp://ryeham.ee.ryerson.ca/pub/PalmOS/) After that, edit below lines in extconf.rb $LDFLAGS = "-L/usr/local/pilot/lib" # dir libpisock is in. $CFLAGS = "-I/usr/local/pilot/include" # dir pi-version.h is in. 4. Compile & install. ruby ./extconf.rb make make install yoshinari-nomura-mhc-815a36a/ruby-ext/ext-helper.c000066400000000000000000000227201222073515200221170ustar00rootroot00000000000000/* ext-helper.c ** ** Author: Yoshinari Nomura ** ** Created: 1999/09/01 ** Revised: $Date: 2000/05/29 14:59:25 $ ** ** */ #include "ruby.h" #include "ext-helper.h" #include #include #include int STRING_LENGTH = 0; #define cp_Check_Type(c, c_type_id, message) {\ if (c != c_type_id) TypeError(message); \ } /******************************************************************/ /******************** Common definitions ************************/ /******************************************************************/ int IS_CLASS_OF(VALUE obj, char *class_name) { char *class_name2 = rb_class2name(CLASS_OF(obj)); return (strcmp(class_name2, class_name) == 0) ? 1 : 0; } /******************************************************************/ /******************** Time <-> struct tm ************************/ /******************************************************************/ VALUE TM2TIME(struct tm *tp) { time_t sec; dprintf(("%d-%d-%d %d:%d:%d\n", tp->tm_year, tp->tm_mon, tp->tm_mday, tp->tm_hour, tp->tm_min, tp->tm_sec)); /* check -- sometimes, mktime() takes long time with a messy tm */ if ((0 <= tp->tm_sec && tp->tm_sec <= 60) && (0 <= tp->tm_min && tp->tm_min < 60) && (0 <= tp->tm_hour && tp->tm_hour < 24) && (1 <= tp->tm_mday && tp->tm_mday <= 31) && (0 <= tp->tm_mon && tp->tm_mon <= 11) && (70 <= tp->tm_year && tp->tm_year <= 137)){ sec = mktime(tp); } else { sec = 0; /* xxx */ } if (sec < 0){ sec = 0; /* xxx: ruby Time class does not deal with a minus sec. */ } dprintf(("sec: %d\n", sec)); return time_new(sec, 0); } void TIME2TM(VALUE obj, struct tm* dst) { time_t sec; struct tm *tmp; sec = NUM2ULONG(rb_funcall(obj, rb_intern("tv_sec"), 0)); tmp = localtime(&sec); dprintf(("before memcpy dst: %d\n", dst)); memcpy(dst, tmp, sizeof(struct tm)); dprintf(("after memcpy\n")); } #define IS_TIME(obj) IS_CLASS_OF(obj, "Time") /****************************************************************/ /*************** array operations **************************/ /****************************************************************/ VALUE ary_copy(VALUE dst, VALUE src) { int i; Check_Type(src, T_ARRAY); Check_Type(dst, T_ARRAY); for (i = 0; i < RARRAY_LEN(src); i++){ ary_push(dst, RARRAY_PTR(src)[i]); } return dst; } /****************************************************************/ /********** set C values to ruby object ********************/ /****************************************************************/ /**************************************************************** "app.repeatType" のような C 構造体の参照名から、 "@repeatType" のような ruby のインスタンス変数名を得る。 ****************************************************************/ char *iv_conv_name(char *name, char *ret) { int c, i, len, pos = 0; if (name == NULL) return NULL; len = strlen(name); for (i = 0; i < len; i++){ c = *(name + i); if (!isalpha(c) && !isdigit(c) && c != '_'){ pos = i + 1; } } *ret = '@'; strcpy(ret + 1, name + pos); return ret; } /**************************************************************** obj の ivname というインスタンス変数に *cval を代入する ivname が NULL の場合は、obj を配列とみなし、push する cval から ruby VALUE への変換ヒントは fmt で与える。 ****************************************************************/ int cp_set1(VALUE obj, char *fmt, char *ivname, void *cval) { char at_name[100]; int len, c; VALUE val; switch (*fmt){ case 'b': dprintf(("converting %d into BOOL\n", *(int*)cval)); val = (*(int*)cval ? TRUE : FALSE); len = sizeof(int); break; case 'c': dprintf(("converting %d into uchar\n", *(unsigned char*)cval)); val = INT2FIX(*(unsigned char *)cval); len = sizeof(unsigned char); break; case 'i': dprintf(("converting %d into FIXNUM\n", *(int*)cval)); val = INT2FIX(*(int*)cval); len = sizeof(int); break; case 't': dprintf(("converting %d into Time\n", ((struct tm*)cval)->tm_year)); val = TM2TIME((struct tm*)cval); len = sizeof(struct tm); break; case 's': dprintf(("converting into String\n")); if ((c = atoi(fmt + 1)) > 0){ val = str_new2((char*)cval != NULL ? (char*)cval : ""); len = sizeof(char) * c; } else { val = str_new2(*(char**)cval != NULL ? *(char**)cval : ""); len = sizeof(char*); } break; case 'v': dprintf(("converting %d into VALUE\n", (VALUE*)cval)); val = *(VALUE*)cval; len = sizeof(VALUE); break; default: TypeError(ivname != NULL ? ivname : "???"); } if (ivname == NULL) { Check_Type(obj, T_ARRAY); ary_push(obj, val); } else { iv_conv_name(ivname, at_name); rb_iv_set(obj, at_name, val); } return len; } /**************************************************************** 新しく ruby 配列 x を作る。cval を C の配列(0番目を指すポインタ) だと思って cp_set1 でx に対してどんどん push。 obj の インスタンス変数 ivname に x をセット。 ivname が NULL の場合は、obj を配列とみなし obj に x を push。 ****************************************************************/ void cp_set2(VALUE obj, char *fmt, char *ivname, void *cval, int len) { int i, s; VALUE ary = ary_new(); for (i = 0; i < len; i++){ cval += cp_set1(ary, fmt, NULL, cval); } cp_set1(obj, "v", ivname, &ary); } /****************************************************************/ /********** set ruby obects to C variables ********************/ /****************************************************************/ /**************************************************************** ****************************************************************/ int cp_get1(VALUE obj, char *fmt, char *ivname, void *cval) { int len; char at_name[100]; VALUE val; at_name[0] = '\0'; if (ivname == NULL){ Check_Type(obj, T_ARRAY); val = ary_shift(obj); } else { iv_conv_name(ivname, at_name); val = rb_iv_get(obj, at_name); } dprintf(("converting name:%s class:%s\n", at_name == NULL ? "???" : at_name, rb_class2name(CLASS_OF(val)))); switch (TYPE(val)){ case T_TRUE: case T_FALSE: cp_Check_Type(*fmt, 'b', at_name); *(int*)cval = (TYPE(val) == T_TRUE ? 1 : 0); len = sizeof(int); break; case T_FIXNUM: if (*fmt == 'i'){ cp_Check_Type(*fmt, 'i', at_name); *(int*)cval = FIX2INT(val); len = sizeof(int); } else if (*fmt == 'c'){ *(unsigned char *)cval = FIX2INT(val); len = sizeof(unsigned char); } else { TypeError(at_name); } break; case T_STRING: cp_Check_Type(*fmt, 's', at_name); STRING_LENGTH = RSTRING_LEN(val); if (STRING_LENGTH > 0){ *(char**)cval = StringValuePtr(val); } else { *(char**)cval = NULL; } len = sizeof(char*); break; case T_ARRAY: cp_Check_Type(*fmt, 'v', at_name); *(VALUE*)cval = val; len = sizeof(VALUE); break; default: dprintf(("converted Time\n")); cp_Check_Type(*fmt, 't', at_name); dprintf(("converted Time\n")); if (!IS_TIME(val)){TypeError("Time required");} dprintf(("converted Time cval: %d\n", cval)); TIME2TM(val, (struct tm*)cval); dprintf(("converted Time\n")); len = sizeof(struct tm); dprintf(("converted Time\n")); break; } return len; } void cp_get2(VALUE obj, char *fmt, char *ivname, void *cval, int len) { int i; VALUE val, ary; char at_name[100]; ary = ary_new(); cp_get1(obj, "v", ivname, &val); Check_Type(val, T_ARRAY); ary_copy(ary, val); dprintf(("cp_get2: %d(length) cval:%d\n", len, cval)); for (i = 0; i < len; i++){ cval += cp_get1(ary, fmt, NULL, cval); } } /* *** Copyright Notice: ** ** Copyright (C) 1999, 2000 Yoshinari Nomura. All rights reserved. ** Copyright (C) 2000 MHC developing team. All rights reserved. ** ** Redistribution and use in source and binary forms, with or without ** modification, are permitted provided that the following conditions ** are met: ** ** 1. Redistributions of source code must retain the above copyright ** notice, this list of conditions and the following disclaimer. ** 2. Redistributions in binary form must reproduce the above copyright ** notice, this list of conditions and the following disclaimer in the ** documentation and/or other materials provided with the distribution. ** 3. Neither the name of the team nor the names of its contributors ** may be used to endorse or promote products derived from this software ** without specific prior written permission. ** ** THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' ** AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ** LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ** FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ** THE TEAM OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ** INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ** (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ** SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, ** STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ** ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED ** OF THE POSSIBILITY OF SUCH DAMAGE. ** *** ext-helper.c ends here */ yoshinari-nomura-mhc-815a36a/ruby-ext/ext-helper.h000066400000000000000000000074451222073515200221330ustar00rootroot00000000000000/* ext-helper.h ** ** Author: Yoshinari Nomura ** ** Created: 1999/09/01 ** Revised: $Date: 2000/05/29 14:59:25 $ ** */ #ifndef EXT_HELPER_H #define EXT_HELPER_H #include "ruby.h" #include #ifdef NEW_NAMING #define cObject rb_cObject #define TRUE Qtrue #define FALSE Qfalse #define time_new rb_time_new #define str_new rb_str_new #define str_new2 rb_str_new2 #define ary_new rb_ary_new #define ary_new2 rb_ary_new2 #define ary_new3 rb_ary_new3 #define ary_push rb_ary_push #define ary_shift rb_ary_shift #define obj_call_init rb_obj_call_init #define Fail(x) rb_raise(rb_eRuntimeError, "%s", x) #define TypeError(x) rb_raise(rb_eTypeError, "%s", x) #endif #if 0 # define dprintf(x) printf x #else # define dprintf(x) #endif #define ARRAY_LEN(x) (sizeof(x)/sizeof(x[0])) /****************************************************************/ /********** set C values to ruby object ********************/ /****************************************************************/ #define iv_set1(obj, fmt, name) cp_set1(obj, fmt, #name, &(name)) #define iv_set2(obj, fmt, name, n) cp_set2(obj, fmt, #name, name, n) #define ar_set1(ary, fmt, name) cp_set1(ary, fmt, NULL, &(name)) #define ar_set2(ary, fmt, name, n) cp_set2(ary, fmt, NULL, name, n) #define iv_get1(obj, fmt, name) cp_get1(obj, fmt, #name, &(name)) #define iv_get2(obj, fmt, name, n) cp_get2(obj, fmt, #name, name, n) #define ar_get1(ary, fmt, name) cp_get1(ary, fmt, NULL, &(name)) #define ar_get2(ary, fmt, name, n) cp_get2(ary, fmt, NULL, name, n) extern int STRING_LENGTH; extern int IS_CLASS_OF(VALUE obj, char *class_name); extern VALUE TM2TIME(struct tm *tp); extern void TIME2TM(VALUE obj, struct tm* dst); extern VALUE ary_copy(VALUE dst, VALUE src); extern char *iv_conv_name(char *name, char *ret); extern int cp_set1(VALUE obj, char *fmt, char *ivname, void *cval); extern void cp_set2(VALUE obj, char *fmt, char *ivname, void *cval, int len); extern int cp_get1(VALUE obj, char *fmt, char *ivname, void *cval); extern void cp_get2(VALUE obj, char *fmt, char *ivname, void *cval, int len); #endif /* ifndef EXT_HELPER_H */ /* *** Copyright Notice: ** ** Copyright (C) 1999, 2000 Yoshinari Nomura. All rights reserved. ** Copyright (C) 2000 MHC developing team. All rights reserved. ** ** Redistribution and use in source and binary forms, with or without ** modification, are permitted provided that the following conditions ** are met: ** ** 1. Redistributions of source code must retain the above copyright ** notice, this list of conditions and the following disclaimer. ** 2. Redistributions in binary form must reproduce the above copyright ** notice, this list of conditions and the following disclaimer in the ** documentation and/or other materials provided with the distribution. ** 3. Neither the name of the team nor the names of its contributors ** may be used to endorse or promote products derived from this software ** without specific prior written permission. ** ** THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' ** AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ** LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ** FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ** THE TEAM OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ** INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ** (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ** SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, ** STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ** ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED ** OF THE POSSIBILITY OF SUCH DAMAGE. ** *** ext-helper.h ends here */ yoshinari-nomura-mhc-815a36a/ruby-ext/extconf.rb.in000066400000000000000000000022571222073515200223010ustar00rootroot00000000000000#!@@MHC_RUBY_PATH@@ # -*- ruby -*- ################################################################ # create make file. if '@@MHC_PILOT_LINK_LIB@@' != '' and '@@MHC_PILOT_LINK_INC@@' != '' require 'mkmf' $CFLAGS = "@@MHC_CFLAGS@@" $CFLAGS += " -DNEW_NAMING " if '@@MHC_RUBY_VERSION@@' >= '010300' $LDFLAGS = "@@MHC_LDFLAGS@@" # CONFIG["LDSHARED"] = "LD_RUN_PATH=@@MHC_PILOT_LINK_LIB@@ " + # CONFIG["LDSHARED"] have_library('socket') have_library('pisock') create_makefile("mhc_pilib") else print "creating make.rb\n" mfile = open("make.rb", "w") mfile .print < ## ## Created: 1999/07/16 ## Revised: $Date: 2004/10/25 02:28:57 $ ## require 'mhc-kconv' class MhcTime include Comparable def initialize(h = 0, m = 0) if h .is_a?(String) && h =~ /^(\d+):(\d+)$/ @sec = ($1 .to_i) * 3600 + ($2 .to_i) * 60 else @sec = (h .to_i) * 3600 + (m .to_i) * 60 end end def day; @sec / 86400 ;end def hour; (@sec % 86400) / 3600 ;end def minute; (@sec % 3600) / 60 ;end def hh; @sec / 3600 ;end def mm; (@sec % 3600) / 60 ;end def <=>(o) if o .kind_of?(MhcTime) return @sec <=> o .to_i else return nil end end def to_s return format("%02d:%02d", hh, mm) end def to_i return @sec end def to_a return [hh, mm] end def to_t(date = MhcDate .new(1970, 1, 2)) date = date .succ(day) Time .local(date .y, date .m, date .d, hour, minute) end end ################################################################ ## MhcDate class class MhcDate include Comparable D_TABLE = [0, 306, 337, 0, 31, 61, 92, 122, 153, 184, 214, 245, 275] O_LABEL = %w(1st 2nd 3rd 4th 5th Last) M_LABEL = %w(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec) W_LABEL = %w(Sun Mon Tue Wed Thu Fri Sat) W_JLABEL = %w(日 月 火 水 木 金 土) M_LONG_LABEL = %w(January February March April May June July August September October November December) W_LONG_LABEL = %w(Sunday Monday Tuesday Wednesday Thursday Friday Saturday) def initialize(y = -1, m = 1, d = 1) if y .kind_of?(String) && y =~ /^(\d{4})(\d\d)(\d\d)$/ @y, @m, @d = $1 .to_i, $2 .to_i, $3 .to_i else if (y == -1) t = Time .now @y, @m, @d = t .year, t .month, t .day else @y, @m, @d = y, m, d end end end attr :y attr :m attr :d def w; return (days + 4) % 7 ; end def o; return (@d - 1) / 7 ; end def ym_a; return [@y, @m] ; end def md_a; return [@m, @d] ; end def to_a; return [@y, @m, @d] ; end #def to_t(hh, mm); return Time .local(@y, @m, @d, hh, mm); end def to_t(tim = MhcTime .new(0, 0)) return Time .local(@y, @m, @d, tim .hour, tim .minute) + (tim .day * 86400) end ## X-SC- で使われる表現形式 def y_s; format("%04d", @y) ; end def m_s; M_LABEL[@m - 1] ; end def d_s; format("%02d", @d) ; end def w_s; W_LABEL[w] ; end def o_s; O_LABEL[o] ; end def to_s; format("%04d%02d%02d", @y, @m, @d) ; end ## できるだけ数字で表す表現形式 alias y_s1 y_s def m_s1 (s = ''); format("%02d", @m) ; end def d_s1 (s = ''); format("%02d", @d) ; end def ym_s1(s = ''); format("%04d#{s}%02d", @y, @m) ; end def md_s1(s = ''); format("%02d#{s}%02d", @m, @d) ; end def to_s1(s = ''); format("%04d#{s}%02d#{s}%02d", @y, @m, @d); end #alias inspect to_s1 ## できるだけ人間に分かりやすい表現形式 if ENV['LANG'] =~ /^ja/i def ym_js MhcKconv::todisp(format("%04d年%02d月", @y, @m)) end def md_js MhcKconv::todisp(format("%02d月%02d日(%s)", @m, @d, W_JLABEL[w])) end def to_js MhcKconv::todisp(format("%04d年%02d月%02d日(%s)", @y, @m, @d, W_JLABEL[w])) end else def ym_js; format("%s %d", m_s, @y) ; end def md_js; format("%s, %d %s", w_s, @d, m_s) ; end def to_js; format("%s, %d %s %d", w_s, @d, m_s, @y) ; end end def w_js; W_LABEL[w] ; end ################ ## year def leap? return true if (@y % 4 == 0 and @y % 100 != 0) or @y % 400 == 0 return false end def leap return leap? ? 1 : 0 end def y_succ!(n = 1) @y += n return self end def y_succ(n = 1) return MhcDate .new(@y, @m, @d) .y_succ!(n) end ################ ## order def o_last? return @d > m_days - 7 end ################ ## month def m_days return [31, 28 + leap, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31][@m - 1] end def m_succ!(n = 1) months = (@y - 1) * 12 + @m + n @y = (months - 1) / 12 + 1 @m = (months - 1) % 12 + 1 @d = 1 return self end # def m_succ!(n = 1) # xx = @m + n # pp = 0 < xx ? (xx - 1) / 12 : (xx - 12) / 12 # @y += pp # @m = xx - (pp * 12) # @d = 1 # return self # end def m_first_day return MhcDate .new(@y, @m, 1) end def m_last_day return MhcDate .new(@y, @m, m_days) end def m_succ(n = 1) return MhcDate .new(@y, @m, @d) .m_succ!(n) end def m_each_day for i in (1 .. m_days) dd = MhcDate .new(@y, @m, i) yield dd end end ################ ## week def w_this(week_str_or_num = self .w) if week_str_or_num .kind_of?(String) week_number = W_LABEL .index(week_str_or_num[0,3] .capitalize) else week_number = week_str_or_num end return succ(week_number - w) end def w_first_day ## xxx currently, 0 means Sunday, ## but definition of `the first day of a week' should be able to be changed. return w_this(0) end def w_last_day ## xxx currently, 6 means Saturday, ## but definition of `the last day of a week' should be able to be changed. return w_this(6) end ################ ## date ## xxx: succ and dec are very stupid. def succ!(n = 1) if (n < 0) dec!(- n) else for i in (1 .. n) if @d == m_days @d = 1 m_succ!(1) else @d += 1 end end end return self end def succ(n = 1) return MhcDate .new(@y, @m, @d) .succ!(n) end def dec!(n = 1) if (n < 0) succ!(- n) else for i in (1 .. n) if @d == 1 m_succ!(-1) @d = m_days else @d -= 1 end end end return self end def dec(n = 1) return MhcDate .new(@y, @m, @d) .dec!(n) end def days yy = @m < 3 ? @y - 1 : @y return yy * 365 + yy / 4 - yy / 100 + yy / 400 + D_TABLE[@m] + @d - 719469 end def hash return (@y << 9) + (@m << 5) + @d end ## alias hash days def today? t = Time .now return ((@y == t .year) and (@m == t .month) and (@d == t .day)) end def <=>(other) if other .kind_of?(MhcDate) return days <=> other .days else return nil end end def eql?(other) return @d == other .d && @m == other .m && @y == other .y end ## alias eql? == def -(other) return days - other .days end end ### Copyright Notice: ## Copyright (C) 1999, 2000 Yoshinari Nomura. All rights reserved. ## Copyright (C) 2000 MHC developing team. All rights reserved. ## Redistribution and use in source and binary forms, with or without ## modification, are permitted provided that the following conditions ## are met: ## ## 1. Redistributions of source code must retain the above copyright ## notice, this list of conditions and the following disclaimer. ## 2. Redistributions in binary form must reproduce the above copyright ## notice, this list of conditions and the following disclaimer in the ## documentation and/or other materials provided with the distribution. ## 3. Neither the name of the team nor the names of its contributors ## may be used to endorse or promote products derived from this software ## without specific prior written permission. ## ## THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' ## AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ## LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ## FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ## THE TEAM OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ## INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ## (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ## SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ## HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, ## STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ## ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED ## OF THE POSSIBILITY OF SUCH DAMAGE. ### mhc-date.rb ends here yoshinari-nomura-mhc-815a36a/ruby-ext/lib/mhc-gtk.rb.in000066400000000000000000000676251222073515200227450ustar00rootroot00000000000000# -*- coding: utf-8 -*- # -*- ruby -*- ### mhc-gtk.rb ## ## Author: Yoshinari Nomura ## ## Created: 1999/07/16 ## Revised: $Date: 2007/02/19 03:01:16 $ ## #$DEBUG = true require 'gtk2' require 'mhc-kconv' require 'mhc-date' require 'mhc-signal' module MhcKconv def todisp(string) Kconv::kconv(string, Kconv::UTF8, Kconv::AUTO) end module_function :todisp end Gtk.init # xxx: from ruby-gtk 0.23, Gtk::CAN_* changed to Gtk::Widget::CAN_* # CAN_DEFAULT = Gtk::Widget::CAN_DEFAULT || Gtk::CAN_DEFAULT CAN_FOCUS = Gtk::Widget::CAN_FOCUS || Gtk::CAN_FOCUS ################################################################ ################## Gtk Setup ################################# ################################################################ XPM_PATH = '@@MHC_XPM_PATH@@' TIPS = Gtk::Tooltips .new # TIPS .set_delay(500) if RUBY_PLATFORM =~ /cygwin/ ## for windows FONTSET = "-unknown-ms ui gothic-normal-r-normal-*-*-100-*-*-p-*-windows-shiftjis" FONTSET2 = "-unknown-ms ui gothic-bold-r-normal-*-*-100-*-*-p-*-windows-shiftjis" FONT = Gdk::Font .font_load(FONTSET) # FONT2 = Gdk::Font .font_load(FONTSET2) Gtk::RC::parse_string < STYLE_SATURDAY, 'holiday' => STYLE_HOLIDAY, 'today' => STYLE_TODAY, 'weekday' => STYLE_WEEKDAY, } STYLE_ARRAY = [ STYLE_HOLIDAY, STYLE_WEEKDAY, STYLE_WEEKDAY, STYLE_WEEKDAY, STYLE_WEEKDAY, STYLE_WEEKDAY, STYLE_SATURDAY, ] ################################################################ ################# Common GUI classes ########################### ################################################################ ################################################################ ## input alarm class GtkAlarmEntry < Gtk::HBox UNIT_LABEL = ['minute', 'hour', 'day'] UNIT_INSEC = {'minute' => 60, 'hour' => 60 * 60, 'day' => 60 * 60 * 24} UNIT_REGEX = UNIT_LABEL .join('|') def initialize(&p) super(false, 0) @hbx = Gtk::HBox .new(false, 0) @item = nil @unit = 'minute' @btn = Gtk::CheckButton .new('No Alarm') menu = get_omenu(&p) ## setup @item and @unit and @omenu @num = GtkNumericSpin .new(0, 99, 10, 1, 10) lbl = Gtk::Label .new('Alarm:') @hbx .pack_start(lbl, false, false, 0) @hbx .pack_start(@num, false, false, 0) @hbx .pack_start(menu, false, false, 0) @num .signal_connect('changed'){ p .call(dump) } @btn .signal_connect('toggled'){ if @btn .active? have_paticular_value(false) p .call(nil) else have_paticular_value(true) p .call(dump) end } pack_start(@hbx, false, false, 0) pack_start(@btn, false, false, 0) end def set_alarm(sec) if !sec have_paticular_value(false) return self end have_paticular_value(true) UNIT_LABEL .reverse .each{|unit| in_sec = UNIT_INSEC[unit] if sec > in_sec @num .set_value(sec / in_sec) @item[unit] .set_active(true) return self end } @num .set_value(0) @item['minute'] .set_active(true) return self end def dump if @btn .active? return nil else return (@num .value_as_int) * UNIT_INSEC[@unit] end end private def have_paticular_value(bool) @hbx .set_sensitive(bool) @btn .set_active(!bool) end def get_omenu(&p) @item = {} menu = Gtk::Menu .new @omenu = Gtk::OptionMenu .new group = nil UNIT_LABEL .each{|unit| item = Gtk::RadioMenuItem::new(group, unit) item .signal_connect('activate', unit){|w, unit| @unit = unit @omenu .set_history(UNIT_LABEL .index(unit)) p .call(dump) if p } group = item .group menu .append(item) item .set_active(true) if unit == 'minute' item .show @item[unit] = item } @omenu .set_menu(menu) @omenu .set_history(0) return @omenu end end ################################################################ ## Input Time hh:mm class GtkTimeEdit < Gtk::Table FILL = Gtk::FILL def initialize(time, &p) hh, mm = time .to_a super(2, 2, false) @min_time = MhcTime .new(23, 59) @h = GtkNumericCombo .new(0, 23, hh, 1, 5) @m = GtkNumericCombo .new(0, 59, mm / 5 * 5, 10, 30) @h .entry .signal_connect('changed'){p .call} @m .entry .signal_connect('changed'){p .call} h_lbl = Gtk::Label .new('Hour:') .set_alignment(0, 0.5) m_lbl = Gtk::Label .new('Min:') .set_alignment(0, 0.5) attach(h_lbl, 0, 1, 0, 1, FILL, FILL, 0, 0) attach(m_lbl, 1, 2, 0, 1, FILL, FILL, 0, 0) attach(@h, 0, 1, 1, 2, FILL, FILL, 0, 0) attach(@m, 1, 2, 1, 2, FILL, FILL, 0, 0) end def set_value(t) @h .set_number(t .hh) @m .set_number(t .mm) return self end def get_value h, m = @h .dump, @m .dump return MhcTime .new(h, m) end alias dump get_value def set_min(time) @min_time = time @h .set_min(time .hh) if @h .dump == @min_time .hh @m .set_min(@min_time .mm) end return self end end ################################################################ ## TimeRange class GtkTimeRangeEdit < Gtk::VBox def initialize(b, e, &p) super(false, 0) @hbx = Gtk::HBox .new(false, 0) @b = GtkTimeEdit .new(b){ hh, mm = @b .dump .to_a @e .set_min(MhcTime .new(hh + 1, 0)) # @e .set_min(@b .dump) p .call(@b .dump, @e .dump) } @e = GtkTimeEdit .new(e){p .call(@b .dump, @e .dump)} @btn = Gtk::CheckButton .new('No Particular Time') lbl = Gtk::Label .new(' -- ') .set_alignment(0, 0.75) @hbx .pack_start(@b , false, false, 0) @hbx .pack_start(lbl, false, false, 0) @hbx .pack_start(@e , false, false, 0) pack_start(@hbx, false, false, 0) pack_start(@btn, false, false, 0) @btn .signal_connect('toggled'){ if @btn .active? have_paticular_value(false) p .call(nil, nil) else have_paticular_value(true) @hbx .set_sensitive(true) p .call(@b .dump, @e .dump) end } end def set_value(b, e) if b have_paticular_value(true) @b .set_value(b) if e @e .set_value(e) else @e .set_value(b) end else have_paticular_value(false) end return self end def have_paticular_value(bool) @hbx .set_sensitive(bool) @btn .set_active(!bool) end def dump if @btn .active? return 'None' else return [@b .get_value, @e .get_value] end end end ################################################################ ## Input Date class GtkDateEdit < Gtk::Table #FILL = Gtk::FILL | Gtk::EXPAND | Gtk::SHRINK FILL = Gtk::FILL def initialize(date, &p) super(3, 3, false) yyyy, mm, dd = date .to_a @y = GtkNumericSpin .new(1970, yyyy + 30, yyyy, 1, 5) @m = GtkNumericCombo .new(1, 12, mm, 1, 5) @d = GtkNumericSpin .new(1, 31, dd, 1, 5) [@y, @m, @d] .each{|box| box .entry .signal_connect('changed'){ p .call } } y_lbl = Gtk::Label .new('Year:') .set_alignment(0, 0.5) m_lbl = Gtk::Label .new('Mon:') .set_alignment(0, 0.5) d_lbl = Gtk::Label .new('Day:') .set_alignment(0, 0.5) self .attach(y_lbl, 0, 1, 0, 1, FILL, FILL, 0, 0) self .attach(m_lbl, 1, 2, 0, 1, FILL, FILL, 0, 0) self .attach(d_lbl, 2, 3, 0, 1, FILL, FILL, 0, 0) self .attach(@y, 0, 1, 1, 2, FILL, FILL, 0, 0) self .attach(@m, 1, 2, 1, 2, FILL, FILL, 0, 0) self .attach(@d, 2, 3, 1, 2, FILL, FILL, 0, 0) end def set_value(d) @y .set_number(d .y) @m .set_number(d .m) @d .set_number(d .d) return self end def btn return @b end def get_value return MhcDate .new(@y .dump, @m .dump, @d .dump) end alias dump get_value end ################################################################ ## Date Range class GtkDateRangeEdit < Gtk::VBox def initialize(date1, date2, &p) super(false, 0) @hbx = Gtk::HBox .new(false, 0) @b = GtkDateEdit .new(date1){p .call(@b .dump, @e .dump)} @e = GtkDateEdit .new(date2){p .call(@b .dump, @e .dump)} @btn = Gtk::CheckButton .new('No Particular Duration') lbl = Gtk::Label .new(' -- ') .set_alignment(0, 0.75) @hbx .pack_start(@b , false, false, 0) @hbx .pack_start(lbl, false, false, 0) @hbx .pack_start(@e , false, false, 0) pack_start(@hbx, false, false, 0) pack_start(@btn, false, false, 0) @btn .signal_connect('toggled'){ if @btn .active? have_paticular_value(false) #@hbx .set_sensitive(false) p .call(nil, nil) else have_paticular_value(true) #@hbx .set_sensitive(true) p .call(@b .dump, @e .dump) end } #have_paticular_value(false) end def have_paticular_value(bool) @hbx .set_sensitive(bool) @btn .set_active(!bool) end def set_value(b, e) if b have_paticular_value(true) @b .set_value(b) if e @e .set_value(e) else @e .set_value(b) end else have_paticular_value(false) end return self end # def get_value # return [@b .get_value, @e .get_value] # end # alias dump get_value end ################################################################ ## Japanese Himekuri Calendar (What do you call it in English ?) class GtkDayBook < Gtk::VBox def initialize(date = MhcDate .new, buttons = nil, need_clist = true) super(false, 0) set_border_width(0) @date = date @tip = '' @hbx = GtkButtonBar .new(buttons) if buttons @btn = Gtk::Button .new('') .set_border_width(0) \ .unset_flags(CAN_FOCUS) .set_relief(Gtk::RELIEF_NONE) if need_clist @lst = Gtk::ListStore.new(String, String) @lsv = Gtk::TreeView.new(@lst).set_headers_visible(false) \ .set_rules_hint(true) @lsv.append_column(Gtk::TreeViewColumn.new("Time", Gtk::CellRendererText.new, :text => 0) \ .set_max_width(42)) @lsv.append_column(Gtk::TreeViewColumn.new("Desc", Gtk::CellRendererText.new, :text => 1) \ .set_max_width(56)) end pack_start(@btn, false, false, 0) pack_start(@lsv, true, true, 0) if need_clist pack_start(@hbx, false, true, 0) if buttons set_date(@date) end def append(item, time = '') if @lst iter = @lst.append iter[0] = time iter[1] = MhcKconv::todisp(item) end return self end def set_tip(tip) # @tip = tip ? MhcKconv::todisp(tip .to_s).tr("\007", " ") : nil @tip = tip ? MhcKconv::todisp(tip .to_s) : nil TIPS .set_tip(@btn, @tip, nil) return self end def append_tip(tip) @tip = (@tip .to_s) + tip # + tip.tr("\007", " ") set_tip(MhcKconv::todisp(@tip)) return self end def set_date(date, title_short = false) @date = date @btn .set_relief(Gtk::RELIEF_NONE) @btn .set_sensitive(true) @lst .clear if @lst set_tip(nil) set_style(STYLE_ARRAY[@date .w]) set_style('today') if @date .today? @btn .child .set_text(title_short ? @date .d .to_s : @date .to_js) return self end def date return @date end def set_style(c) if c .is_a?(String) case c when 'today' @btn .set_relief(Gtk::RELIEF_NORMAL) return self when 'busy' c = @btn .child .style .dup .set_font_desc(FONT2) else c = STYLE_HASH[c] end end @btn .set_style(c) @btn .child .set_style(c) return self end def get_text(r, c) @lst .get_text(r, c) if @lst end def signal_connect(sig, &p) case sig when 'day-btn-clicked' @btn .signal_connect('clicked', p) when 'day-lst-clicked' if @lst @lsv .signal_connect('row-activated'){|w,path,t| p .call(self, path.indices[0].to_i) } end when /-btn-clicked$/ @hbx .signal_connect(sig, &p) else super end end end ################################################################ ## Original Calendar Widget class GtkCalendar < Gtk::VBox FILL = Gtk::FILL | Gtk::SHRINK | Gtk::EXPAND NONE = Gtk::SHRINK if ENV['LANG'] =~ /^ja/i WEEK_L = ['日', '月', '火', '水', '木', '金', '土'] WEEK_S = ['日', '月', '火', '水', '木', '金', '土'] else WEEK_L = ['Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat'] WEEK_S = ['Su', 'Mo', 'Tu', 'We', 'Th', 'Fr', 'Sa'] end def initialize(date, buttons = nil, need_title = false, is_small = false, need_clist = true) super(false, 0) week_label = is_small ? WEEK_S : WEEK_L @SignalConduit = SignalConduit .new @dList = [] @date = date @hbx = GtkButtonBar .new(buttons) if buttons @m_tbl = Gtk::Table .new(6, 7, true) w_tbl = Gtk::Table .new(1, 7, true) @title = Gtk::Label .new(@date .ym_js) if need_title ## add week label for w in 0 .. 6 wlabel = Gtk::Label .new(MhcKconv::todisp(week_label[w])) wlabel .set_style(STYLE_ARRAY[w]) w_tbl .attach(wlabel, w, w + 1, 0, 1, FILL, NONE, 5, 0) end (0 .. 41) .each{|i| x = i % 7 y = i / 7 @dList[i] = GtkDayBook .new(date, nil, need_clist) @m_tbl .attach(@dList[i], x, x + 1, y, y + 1, FILL, FILL, 0, 0) @dList[i] .signal_connect('day-btn-clicked'){ @SignalConduit .signal_emit('day-btn-clicked', pos_to_date(i)) } @dList[i] .signal_connect('day-lst-clicked'){|w, r| @SignalConduit .signal_emit('day-lst-clicked', w, pos_to_d(i), r) } } pack_start(@title, false, false, 0) if need_title pack_start(@hbx, false, false, 0) if buttons pack_start(w_tbl, false, false, 0) pack_start(@m_tbl, true, true, 0) set_date(@date) signal_connect('show'){hide_garbage} end def set_date(date) @date = date .m_first_day @offset = @date .w - 1 for i in 0 .. 41 if on?(i) dd = pos_to_date(i) @dList[i] .set_date(dd, true) \ .set_tip(MhcKconv::todisp("#{dd .d}日")) .show else @dList[i] .hide end end @title .set_text(@date .ym_js) if @title return self end def next_month @date .m_succ! set_date(@date) end def prev_month @date .m_succ!(-1) set_date(@date) end def this_month @date = MhcDate .new set_date(@date) end def date; return @date; end def d(dd); return @dList[dd + @offset]; end def signal_connect(sig, &p) case sig when 'day-lst-clicked' @SignalConduit .signal_connect('day-lst-clicked', &p) when 'day-btn-clicked' @SignalConduit .signal_connect('day-btn-clicked', &p) when /-btn-clicked$/ @hbx .signal_connect(sig, &p) else super end end private def hide_garbage for i in 0 .. 41 @dList[i] .hide if !on?(i) end return self end def pos_to_date(p) return MhcDate .new(@date .y, @date .m, p - @offset) end def on?(p) d = p - @offset return (d > 0 and d <= @date .m_days) end def pos_to_d(p) return p - @offset end end ################################################################ ## confirm class GtkConfirm < Gtk::Dialog def initialize(msg, btns = 1, &p) b = [[Gtk::Stock::OK, Gtk::Dialog::RESPONSE_ACCEPT]] if btns > 1 b << [Gtk::Stock::CANCEL, Gtk::Dialog::RESPONSE_REJECT] end super(msg, nil, Gtk::Dialog::MODAL, *b) self.vbox.pack_start(Gtk::Label.new(msg)).show_all run do |response| case response when Gtk::Dialog::RESPONSE_ACCEPT p.call(true) if p when Gtk::Dialog::RESPONSE_REJECT p.call(false) if p end end destroy end end ################################################################ ## Watch toplevel windows. class GtkToplevel < Gtk::Window def initialize super(Gtk::Window::TOPLEVEL) signal_connect('destroy'){ print "GtkToplevel destroyed\n" if $DEBUG Gtk.main_quit if active_other_windows == 0 } end def destroyed? return self .inspect =~ / destroyed/ end def active_other_windows c = 0 ObjectSpace::each_object(GtkToplevel){|obj| c += 1 if (!obj .destroyed? && obj != self && obj .visible?) } return c end # def show # pop_position # super # end def show_all pop_position if !visible? super end alias show show_all def hide print "GtkToplevel hide\n" if $DEBUG Gtk.main_quit if active_other_windows == 0 push_position super end def hide_all print "GtkToplevel hide_all\n" if $DEBUG Gtk.main_quit if active_other_windows == 0 push_position super end def push_position @pos = self .position print "push_position #{@pos .inspect}\n" if $DEBUG end def pop_position if @pos print "pop_position #{@pos[0]}, #{@pos[1]}\n" if @pos && $DEBUG self .move(@pos[0], @pos[1]) end end def confirm top = Gtk::Window .new(Gtk::WINDOW_POPUP) vbx = Gtk::VBox .new(false, 0) hbx = Gtk::HBox .new(true , 0) y = Gtk::Button .new('OK') y .flags |= CAN_DEFAULT y .signal_connect('clicked'){Gtk.main_quit} hbx .pack_start(y, true, true, 0) n = Gtk::Button .new('Cancel') n .flags |= CAN_DEFAULT n .grab_default n .signal_connect('clicked'){top .destroy} hbx .pack_start(n, true, true, 0) vbx .pack_start(Gtk::Label .new('Exit GtkCalendar?')) vbx .pack_start(hbx, false, false, 0) top .add(vbx) .set_modal(true).set_size_request(250,100)#set_usize(250,100) top .set_position(Gtk::WIN_POS_CENTER) .show_all end end ################################################################ ## Simple file viewer class GtkFileViewer < Gtk::VBox # RED = Gdk::Color .new(0xffff, 0x0000, 0x0000) # GREEN = Gdk::Color .new(0x0000, 0xffff, 0x0000) # BLUE = Gdk::Color .new(0x0000, 0x0000, 0xffff) # BLACK = Gdk::Color .new(0x0000, 0x0000, 0x0000) # PURPLE = Gdk::Color .new(0xffff, 0x0000, 0xffff) # WHITE = Gdk::Color .new(0xffff, 0xffff, 0xffff) # ORANGE = Gdk::Color .new(56360, 24247, 6553) def initialize(text_editable = false) super(false, 0) @modified = false @text_editable = text_editable hbx = Gtk::HBox .new(false, 0) ## @txt = Gtk::Text .new(nil, vad) @txt = Gtk::TextView .new(nil) ## @txt .set_editable(@text_editable) ## vad = Gtk::Adjustment .new(0, 0, 0, 0, 0, 0) ## @vsc = Gtk::VScrollbar .new(vad) @vsc = Gtk::ScrolledWindow .new(nil, nil) ## @vsc .set_policy(Gtk::POLICY_NEVER, Gtk::POLICY_AUTOMATIC) ## @vsc .add(@txt) ## @height = 14 ## (@txt .get_style .font .string_width '0') * 2 ## xxxx # @txt .signal_connect('key_press_event'){|w, ev| less_key(w, ev .string)} @txt .buffer .signal_connect('changed'){|w| @modified = true} ## hbx .pack_start(@txt, true, true, 0) ## hbx .pack_start(@vsc, false, false, 0) hbx .pack_start(@vsc, true, true, 0) ## pack_start(hbx, true, true, 0) #open(path) end def less_key(w, key) value = @vsc .vadjustment .value lower = @vsc .vadjustment .lower upper = @vsc .vadjustment .upper page_size = @vsc .vadjustment .page_size value_min = lower value_max = upper - page_size case key when 'j' value += @height when 'k' value -= @height when ' ' value += page_size when 'b', "\x08" value -= page_size when '<' value = value_min when '>' value = value_max end if value > value_max value = value_max elsif value < value_min value = value_min end @vsc .vadjustment .value= value end # def open(path) # if path .kind_of?(String) and File .exist?(path) # text = Kconv::toeuc(File .open(path) .read) # replace_text(text) # else # replace_text("\n\n") # end # set_modified(false, 'open') # end def replace_text(text) @txt .set_editable(true) # .freeze @txt .buffer .set_text("") # hdr, value = text .split("\n\n", 2) # hdr .to_s .each_line{|line| # case line # when /^Subject:/ ;color = BLUE # when /^X-SC-Subject:/ ;color = BLUE # when /^From:/ ;color = PURPLE # #when /^To:|Cc:/ ;color = ORANGE # #when /^Date:/ ;color = GREEN # when /^X-SC-(Time|Day):/ ;color = RED # else ;color = BLACK # end # @txt .insert(nil, color, nil, line) if line != '' # } # @txt .insert(nil, RED, WHITE, hdr .to_s) # @txt .insert(nil, BLACK, nil, "\n\n" + value .to_s) @txt .buffer .insert(@txt.buffer.start_iter, MhcKconv::todisp(text)) @txt .set_editable(@text_editable) #.thaw end def set_modified(bool, msg) @modified = bool end def modified? return @modified end def dump return @txt .buffer.text end end ################################################################ ## Combo widget for numeric values class GtkNumericCombo < Gtk::Combo def initialize(min, max, default = min, step1 = 1, step2 = 1) super() @min, @max, @len = min, max, max .to_s .length @step1, @step2 = step1, step2 set_min_max(min, max) set_number(default) self .entry .signal_connect('changed'){ adjust_number } end def adjust_number s = self .entry .text i = s .to_i if (s !~ /^\d*$/) || (i != 0 && (i < @min || i > @max)) set_number(i) end end def set_min_max(min, max) @min, @max, @len = min, max, max .to_s .length a = [] while (min <= max) a << format("%0#{@len}d", min) min += @step1 end self .set_popdown_strings(a) # self .set_usize(7 * @len + 30, 0) self .set_width_request(7 * @len + 30) self .entry .set_max_length(@len) end def set_min(i) set_min_max(i, @max) end def set_max(i) set_min_max(@min, i) end def set_number(i) i = i .to_i if (i < @min) i = @min elsif (i > @max) i = @max end self .entry .set_text(format("%0#{@len}d", i)) end def dump return self .entry .text .to_i end end ################################################################ ## Spin buttons for numeric values. class GtkNumericSpin < Gtk::SpinButton def initialize(from, to, default = from, step = 1, step2 = 5) adj = Gtk::Adjustment .new(from, from, to, step, step2, 0) len = to .to_s .length super(adj) self .set_wrap(true) # self .set_usize(7 * len + 30, 0) self .set_max_length(len) #self .set_update_policy(Gtk::SpinButton::UPDATE_ALWAYS) #self .set_update_policy(Gtk::SpinButton::UPDATE_IF_VALID) self .set_value(default) end def set_min(n) end def set_value(n) super(n .to_i) end alias set_number set_value def entry return self end def get_value return value_as_int .to_s end def dump value_as_int end end ################################################################ ## Entry with label class GtkEntry < Gtk::HBox def initialize(label, text = '') super() lbl = Gtk::Label .new(label) @ent = Gtk::Entry .new .set_text(text) self .pack_start(lbl, false, false, 5) self .pack_start(@ent, true, true, 5) end def get_text text end def text return @ent .text end def set_text(str) @ent .set_text(MhcKconv::todisp(str)) return self end def signal_connect(sig, &p) @ent .signal_connect(sig, &p) end alias dump get_text end ################################################################ ## Table of Toggle buttons. class GtkToggleTable < Gtk::Table #FILL = Gtk::FILL | Gtk::EXPAND | Gtk::SHRINK FILL = Gtk::FILL NONE = Gtk::SHRINK def initialize(ys, xs, label, &p) @symbols = [] super(ys, xs, true) for y in 0 .. ys - 1 for x in 0 .. xs - 1 lbl = label[xs * y + x] if lbl b = Gtk::ToggleButton .new(lbl .to_s) b .unset_flags(CAN_FOCUS) .set_border_width(0) @symbols << b b .signal_connect('toggled'){|w| p .call(w) } self .attach(b, x, x + 1, y, y + 1, FILL, FILL, 0, 0) end end end end def each_button @symbols .each{|b| yield(b, b .child .text) } end def dump ret = [] @symbols .each{|b| if b .active? ret << b .child .text end } return ret .join(' ') end end ################################################################ ## Toolbar like widget. class GtkButtonBar < Gtk::HBox TOP = Gtk::Window .new(Gtk::Window::TOPLEVEL) TOP .realize def initialize(btn) super(false, 0) @btn = {} btn .each{|xpm_tip| name, tip = *xpm_tip path = XPM_PATH + '/' + name + '.xpm' if !File .exists?(path) path = File .dirname($0) + '/xpm/' + name + '.xpm' end w = TOP .window s = TOP .style .bg(Gtk::STATE_NORMAL) pix, map = Gdk::Pixmap .create_from_xpm(w, s, path) xpm = Gtk::Image .new(pix, map) b = Gtk::Button .new() .unset_flags(CAN_FOCUS) .set_border_width(0) b .add(xpm) TIPS .set_tip(b, MhcKconv::todisp(tip), nil) self .pack_start(b, false, false, 0) @btn[name] = b } end def signal_connect(sig, &p) if sig =~ /(.*)-btn-clicked$/ @btn[$1] .signal_connect('clicked', &p) else super end end end ### Copyright Notice: ## Copyright (C) 1999, 2000 Yoshinari Nomura. All rights reserved. ## Copyright (C) 2000 MHC developing team. All rights reserved. ## Redistribution and use in source and binary forms, with or without ## modification, are permitted provided that the following conditions ## are met: ## ## 1. Redistributions of source code must retain the above copyright ## notice, this list of conditions and the following disclaimer. ## 2. Redistributions in binary form must reproduce the above copyright ## notice, this list of conditions and the following disclaimer in the ## documentation and/or other materials provided with the distribution. ## 3. Neither the name of the team nor the names of its contributors ## may be used to endorse or promote products derived from this software ## without specific prior written permission. ## ## THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' ## AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ## LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ## FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ## THE TEAM OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ## INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ## (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ## SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ## HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, ## STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ## ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED ## OF THE POSSIBILITY OF SUCH DAMAGE. ### mhc-gtk.rb ends here yoshinari-nomura-mhc-815a36a/ruby-ext/lib/mhc-kconv.rb000066400000000000000000000045201222073515200226540ustar00rootroot00000000000000# -*- coding: utf-8 -*- # -*- ruby -*- ### mhc-kconv.rb ## ## Author: MIYOSHI Masanori ## ## require 'kconv' module MhcKconv env = ENV['LC_ALL'] || ENV['LC_CTYPE'] || ENV['LANG'] if env =~ /euc/i DISP_CODE = Kconv::EUC elsif env =~ /sjis|shift_jis/i DISP_CODE = Kconv::SJIS elsif env =~ /^ja$/i DISP_CODE = Kconv::EUC else DISP_CODE = Kconv::UTF8 end def todisp(string) Kconv::kconv(string, DISP_CODE, Kconv::AUTO) end module_function :todisp def tomail(string) Kconv::tojis(string) end module_function :tomail def tohtml(string) Kconv::tojis(string) end module_function :tohtml def tops(string) Kconv::toeuc(string) end module_function :tops end ### Copyright Notice: ## Copyright (C) 2000 MHC developing team. All rights reserved. ## All rights reserved. ## Redistribution and use in source and binary forms, with or without ## modification, are permitted provided that the following conditions ## are met: ## ## 1. Redistributions of source code must retain the above copyright ## notice, this list of conditions and the following disclaimer. ## 2. Redistributions in binary form must reproduce the above copyright ## notice, this list of conditions and the following disclaimer in the ## documentation and/or other materials provided with the distribution. ## 3. Neither the name of the team nor the names of its contributors ## may be used to endorse or promote products derived from this software ## without specific prior written permission. ## ## THIS SOFTWARE IS PROVIDED BY Yoshinari Nomura AND CONTRIBUTORS ``AS IS'' ## AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ## LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ## FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ## Yoshinari Nomura OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ## INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ## (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ## SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ## HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, ## STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ## ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED ## OF THE POSSIBILITY OF SUCH DAMAGE. ### mhc-kconv.rb ends here yoshinari-nomura-mhc-815a36a/ruby-ext/lib/mhc-palm.rb000066400000000000000000000564051222073515200224760ustar00rootroot00000000000000# -*- coding: utf-8 -*- ### mhc-palm.rb ## ## Author: Yoshinari Nomura ## ## Created: 1999/09/01 ## Revised: $Date: 2009/01/07 00:15:05 $ ## require 'mhc-date' begin require 'mhc_pilib' rescue LoadError # STDERR .print "Warning: require 'mhc_pilib' was failed." end ################################################################ ## ## fundamental class 1/4 ## ## Pilot -- connection management. ## class Pilot attr :sd def initialize(port = '/dev/pilot') @sd = PiLib .openSock(port) end def listen @sd = PiLib .listenSock(@sd) return nil if @sd .nil? return self end def close PiLib .closeSock(@sd) return self end ## Add an entry into the HotSync log on the Pilot. ## \n is OK, as usual. You may invoke this command once or more before ## calling EndOfSync (sockClose), but it is not required. def add_synclog(string) PiLib .dlp_AddSyncLogEntry(@sd, string) return self end ## reset lastSyncPC in the UserInfo to 0 def reset_lastsync_pc PiLib .dlp_ResetLastSyncPC(@sd) return self end def get_time return PiLib .dlp_GetSysDateTime(@sd) end def set_time(time) PiLib .dlp_SetSysDateTime(@sd, time) return self end end ################################################################ ## ## fundamental classe 2/4 ## ## PilotDB ## class PilotDB def initialize(pi, dbname) @sd = pi .sd @db = PiLib .dlp_OpenDB(@sd, dbname) @recClass = PilotRecord end def close PiLib .dlp_CloseDB(@sd, @db) end def record_by_index(i) ary = PiLib .dlp_ReadRecordByIndex(@sd, @db, i) return nil if ary .nil? return @recClass .new(*ary) end def record_by_id(id) ary = PiLib .dlp_ReadRecordById(@sd, @db, id) return nil if ary .nil? return @recClass .new(*ary) end def each_record i = 0 while (rec = record_by_index(i)) != nil yield rec i += 1 end end def write_record(rec) rec_array = rec .to_a new_id = PiLib .dlp_WriteRecord(@sd, @db, rec_array) return new_id end def delete_by_id(id) PiLib .dlp_DeleteRecord(@sd, @db, false, id) return self end def delete_all PiLib .dlp_DeleteRecord(@sd, @db, true, 0) return self end ## Deletes all records in the opened database which are marked as archived ## or deleted. def cleanup_record PiLib .dlp_CleanUpDatabase(@sd, @db) return self end ## For record databases, reset all dirty flags. For both record and ## resource databases, set the last sync time to now. def reset_sync_flags PiLib .dlp_ResetSyncFlags(@sd, @db) return self end def get_app_info() return PiLib .dlp_ReadAppBlock(@sd, @db) end end ################################################################ ## ## fundamental class 3/4 ## ## PilotRecord -- PilotDB record ## class PilotRecord def initialize(id = 0, attr = 0, category = 0, data = '') @id, @attr, @category, @data = id, attr, category, data unpack check end attr :id def set_id(id) raise "Integer required." if !(id .is_a?(Integer)) @id = id return self end def attribute_deleted? ; return (@attr & 0x80 != 0) ;end def attribute_dirty? ; return (@attr & 0x40 != 0) ;end def attribute_busy? ; return (@attr & 0x20 != 0) ;end def attribute_secret? ; return (@attr & 0x10 != 0) ;end def attribute_archived? ; return (@attr & 0x08 != 0) ;end def set_attribute_deleted ; @attr |= 0x80; return self ;end def set_attribute_dirty ; @attr |= 0x40; return self ;end def set_attribute_busy ; @attr |= 0x20; return self ;end def set_attribute_secret ; @attr |= 0x10; return self ;end def set_attribute_archived ; @attr |= 0x08; return self ;end def reset_attribute_deleted ; @attr &= ~0x80; return self ;end def reset_attribute_dirty ; @attr &= ~0x40; return self ;end def reset_attribute_busy ; @attr &= ~0x20; return self ;end def reset_attribute_secret ; @attr &= ~0x10; return self ;end def reset_attribute_archived ; @attr &= ~0x08; return self ;end def set_attribute(attr) raise "Integer required." if !(attr .is_a?(Integer)) @attr = attr return self end def attribute return @attr end def attribute_string attr_str = [] attr_str << 'Deleted' if (@attr & 0x80 != 0) attr_str << 'Dirty' if (@attr & 0x40 != 0) attr_str << 'Busy' if (@attr & 0x20 != 0) attr_str << 'Secret' if (@attr & 0x10 != 0) attr_str << 'Archived' if (@attr & 0x08 != 0) return attr_str .join(' ') end attr :category def set_category(category) raise "Integer required." if !(category .is_a?(Integer)) @category = category return self end def data pack return @data end def set_data(data) raise "String required." if !(data .is_a?(String)) @data = data return self end def to_a check pack return [@id, @attr, @category, @data] end private def pack; end def unpack; end def check raise "Id must be Integer." if !(@id .is_a?(Integer)) raise "Attribute must be Integer." if !(@attr .is_a?(Integer)) raise "Category must be Integer." if !(@category .is_a?(Integer)) raise "Data must be String." if !(@data .is_a?(String)) return self end end ################################################################ ## ## fundamental class 4/4 ## ## PilotFile -- File DB ## class PilotFile ## these methods are defined in pilib.c ## get_app_info ## read_record ## close def initialize(filename, recClass = PilotRecord) @recClass = recClass end def each_record i = 0 while (rec = record_by_index(i)) != nil yield rec i += 1 end end def record_by_index(i) ary = read_record(i) return nil if ary .nil? return @recClass .new(*ary) end end ################################################################ ## ## classes for Memo ## class PilotMemoDB < PilotDB def initialize(pi, dbname) super @recClass = PilotMemoRecord end end class PilotMemoRecord < PilotRecord undef set_data def set_memo_data(string) @memo_data = string return self end def memo_data return @memo_data end def unpack @memo_data = @data .sub(/\0$/, '') return self end def pack @data = Kconv::tosjis(@memo_data || '') + "\0" return self end end ################################################################ ## ## classes for Datebook ## class PilotApptDB < PilotDB def initialize(pi, dbname) super @recClass = PilotApptRecord end end class PilotApptRecord < PilotRecord UNIT_TYPE = %w(minute hour day) ORDER_TYPE = %w(1st 2nd 3rd 4th Last) WEEK_TYPE = %w(Sun Mon Tue Wed Thu Fri Sat) MONTH_TYPE = %w(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec) REPEAT_TYPE = %w(None Daily Weekly MonthlyByDay MonthlyByDate Yearly) undef set_data def repeat? ; return @repeatType != 0 ;end def event? ; return @event ;end def alarm? ; return @alarm ;end def category? ; return @category == 0 ? false : true ;end def forever? ; return @repeatForever ;end def repeatType ; return REPEAT_TYPE[@repeatType] ;end def repeatDay return "#{ORDER_TYPE[@repeatDay / 7]} #{WEEK_TYPE[@repeatDay % 7]}" end def alarm if alarm? return @advance .to_s + ' ' + UNIT_TYPE[@advanceUnits] else return '' end end def repeatDays ary = [] for i in (0 .. 6) ary << WEEK_TYPE[i] if @repeatDays[i] end return ary .join(' ') end ## b @event 時間指定がないイベントかどうか ## t @beg 開始日付、時間。 ## (repeat の場合は、duration の開始でもある) ## t @fin 終わりの時間 (date 部分は beg と同じにする) ## event == 1 のときは、time 部分は全部 0 ## b @alarm 1 or 0 ## i @advance 0-99 ## i @advanceUnits units = ['minute', 'hour', 'day']; ## i @repeatType None,Daily Weekly MonthlyByDay, ## MonthlyByDate,Yearly ## byday -> cond (@repeatDay を信用) ## bydate -> num @beg .day を信用。 ## b @repeatForever repeatEnd を信用していいかどうか。 ## repeatEnd は信用してはならない。 ## t @repeatEnd Duration end (date 部分だけ) ## i @repeatFrequency int ## i @repeatDay o = repeatDay /7, w = repeatDay % 7 ## 5th がないのはなぜ? ## b[7] @repeatDays Sun, Mon, Tue, 1 or 0 ## i @repeatWeekstart いつも 0 ## i @exceptions, 0? ## t[x] @exception [] ## s @description NULL or Subject: ## s @note NULL or 本文 ################################################################ ## スケジュールタイプによらない ## ## set alarm in second. def set_alarm(alarm) raise "Type error: requires Integer\n" if alarm && !alarm .is_a?(Integer) if alarm @alarm = true if alarm % 86400 == 0 && alarm <= 86400 * 99 @alarmUnit = 2 ## day @advance = alarm / 86400 elsif alarm % 3600 == 0 && alarm <= 3600 * 99 @alarmUnit = 1 ## hour @advance = alarm / 3600 elsif alarm % 60 == 0 && alarm <= 60 * 99 @alarmUnit = 0 ## minute @advance = alarm / 60 else raise "Could not convert alarm." end else @alarm = false @advance = 0 @advanceUnits = 0 end end def set_time(b = nil, e = nil) raise "Type error: requires MhcTime\n" if b && !b .is_a?(MhcTime) raise "Type error: requires MhcTime\n" if e && !e .is_a?(MhcTime) if b @event = false e = b if !e ## 終了時間を指定していなかったら、開始と同じに @beg = replace_time(@beg, b .hh, b .mm) @fin = replace_time(@fin, e .hh, e .mm) else @event = true @beg = replace_time(@beg, 0, 0) @fin = replace_time(@fin, 0, 0) end end def add_exception(date) ## repeatType = None のときは、exception を設定しても意味がない? raise "Type error: requires MhcDate\n" if !date .is_a?(MhcDate) @exception << date .to_t @exceptions = @exception .length return self end def set_note(txt) raise "Type error: requires String\n" if !txt .is_a?(String) @note = Kconv::tosjis(txt) return self end def set_description(txt) ## subject raise "Type error: requires String\n" if !txt .is_a?(String) @description = Kconv::tosjis(txt) return self end ################################################################ ## スケジュールタイプ別 ## ## 普通の リピートしないやつ ## def set_nonrepeat_date(date) raise "Type error: requires MhcDate\n" if !date .is_a?(MhcDate) @repeatType = 0 @beg = replace_date(@beg, date .y, date .m, date .d) @fin = replace_date(@fin, date .y, date .m, date .d) return self end ## repeatType -> Daily ## ## x-sc-day を sort して、 1日間隔に並んでいる && ## x-sc-cond は空 ## ## n 日毎 ## duration_b - duration_e まで def set_daily(beg, fin, freq) set_duration(beg, fin) ## beg, fin の型チェックもする set_frequency(freq) ## freq の型チェックもする ## xxx: 先に全部チェックしてからでないと rollback できない。。 @repeatType = 1 return self end ## repeatType -> Weekly ## ## x-sc-day は空 && ## x-sc-cond は wek だけ(複数可) ## ## Sun Mon Tue ## duration_b - duration_e まで ## ## weeks = [false, true, true, false, false, false, false] ## -> Mon, Tue ## def set_weekly(beg, fin, freq, weeks) set_duration(beg, fin) ## beg, fin の型チェックもする set_frequency(freq) ## freq の型チェックもする w = [] if weeks .is_a?(Array) && weeks .length == 7 weeks .each{|bool| if !(bool == true || bool == false) raise "Type error: weeks must be bool[7]" end w << bool } else raise "Type error: weeks must be bool[7]" end @repeatType = 2 @repeatDays = w @repeatWeekstart = 0 return self end ## repatType -> Monthly ## ## x-sc-day は空 && ## ((x-sc-cond は ord が 1個 && ord != 5th && wek が一個だけ) || ## x-sc-cond は num が 1個だけ) ## ## 1st Sun -- by day ## 01 -- by date ## duration_b - duration_e まで ## ## ord .. 0 - 4 の整数 1st, 2nd, 3rd, 4th, Last に対応 ## wek .. 0 - 6 の整数 Sun, ... ,Sat に対応 ## def set_monthly_by_day(beg, fin, freq, ord, wek) set_duration(beg, fin) ## beg, fin の型チェックもする set_frequency(freq) ## freq の型チェックもする ## beg の日付が ord, week を満たしているかのチェックが必要 msg = "Type/Range error: (0< ord <4, 0< wek <6) required. (#{ord}, #{wek})" raise msg if !(ord .is_a?(Integer) && 0 <= ord && ord <= 4) raise msg if !(wek .is_a?(Integer) && 0 <= wek && wek <= 6) raise msg if !((ord == 4 && beg .o_last?) || (ord < 4 && beg .o == ord)) @repeatDay = ord * 7 + wek @repeatType = 3 return self end def set_monthly_by_date(beg, fin, freq) set_duration(beg, fin) ## beg, fin の型チェックもする set_frequency(freq) ## freq の型チェックもする ## beg の 日付の部分の 「日」 がそのまま使われる @repeatType = 4 return self end ## repeatType -> yearly ## ## x-sc-day は空 && ## x-sc-cond は mon が 1個と num が1個だけ ## ## Jan 01 ## duration_b - duration_e まで def set_yearly(beg, fin, freq) set_duration(beg, fin) ## beg, fin の型チェックもする set_frequency(freq) ## freq の型チェックもする ## beg の 日付の部分の 「月・日」 がそのまま使われる @repeatType = 5 return self end ################################################################ ## mhc が使う MhcScheduleItem への変換 $last_mid_rand = 'AAAA' $last_mid_time = nil $last_mid_counter = 0 def create_message_id(domain = 'from.your.palm') mid_time = Time .now .strftime("%Y%m%d%H%M%S") mid_user = Process .uid .to_s if $last_mid_time && mid_time == $last_mid_time $last_mid_counter += 1 $last_mid_rand .succ! mid_rand = $last_mid_rand else $last_mid_rand = 'AAAA' mid_rand = $last_mid_rand $last_mid_counter = 0 end mid_rand += '-' + $$ .to_s $last_mid_time = mid_time return '<' + mid_time + mid_rand + '.' + mid_user + '@' + domain + '>' end def to_xsc xsc = {}; xsc["Record-Id"] = create_message_id(@id .to_s) # xxx xsc["Pilot-Attr"] = attribute_string xsc["Pilot-Id"] = @id xsc["Subject"] = Kconv::tojis(Kconv::toeuc(@description) .sub(/\[[^\]]*\]\s*$/, '')) xsc["Location"] = Kconv::tojis($1) if Kconv::toeuc(@description) =~ /\[([^\]]+)\]\s*$/ xsc["Note"] = Kconv::tojis(@note) xsc["Category"] = @category if category? xsc["Alarm"] = alarm xsc["Day"] = @exception .collect{|t| '!' + t .to_xscday} .join(' ') xsc["Day"] += ' ' + @beg .to_xscday if !repeat? if !event? if @beg .to_xsctime == @fin .to_xsctime xsc["Time"] = ' ' + @beg .to_xsctime else xsc["Time"] = ' ' + @beg .to_xsctime + '-' + @fin .to_xsctime end end if repeat? if @repeatFrequency > 1 STDERR .print "#{@beg} : #{Kconv::tojis(@description)} " STDERR .print "unsupported. ignored..\n" return nil end if !forever? b, e = @beg .to_xscday, @repeatEnd .to_xscday xsc["Duration"] = b + '-' + e b_date, e_date = MhcDate .new(b), MhcDate .new(e) end case repeatType when 'Daily' if !forever? && (e_date - b_date < 7) for d in b_date .. e_date xsc["Day"] += ' ' + d .to_s end else xsc["Cond"] = 'Sun Mon Tue Wed Thu Fri Sat' # xxx end when 'Weekly' xsc["Cond"] = repeatDays when 'MonthlyByDay' xsc["Cond"] = repeatDay when 'MonthlyByDate' xsc["Cond"] = @beg .day .to_s when 'Yearly' xsc["Cond"] = MONTH_TYPE[@beg .mon - 1] + ' ' + @beg .day .to_s end end str = '' note = '' xsc .each{|key, val| if key == 'Note' note = val else str += "X-SC-#{key}: #{val}\n" end } x = MhcScheduleItem .new(str, false) note_hdr, note_desc, datebk3_icon = conv_note(note) x .set_non_xsc_header(note_hdr) x .set_description(note_desc) x .add_category(datebk3_icon) if datebk3_icon x .set_pilot_id([@id]) return x end ################################################################ ## private ## Palm のノート -> mhc の body と X-SC-* 以外のヘッダ部分に変換 def conv_note(string) if string =~ /\A(\#\#@@@.@@@)\n([^\z]*)\z/n datebk3_icon, string = $1, $2 end part1_is_header = true part1, part2 = string .split("\n\n", 2) if !(part1 =~ /^[ \t]+/ or part1 =~ /^[A-Za-z0-9_-]+:/) part1_is_header = false end part1 .to_s .split("\n") .each{|line| if !(line =~ /^[ \t]+/ or line =~ /^[A-Za-z0-9_-]+:/) part1_is_header = false end } if part1_is_header header, body = part1, part2 else header, body = nil, string end return header, body, datebk3_icon end ## Time クラスインスタンスの 時間部分だけを置き換える def replace_time(time, hour, min) return Time .local(*time .to_a .indexes(5, 4, 3) + [hour, min]) end ## Time クラスインスタンスの 日付部分だけを置き換える def replace_date(time, y, m, d) return Time .local(y, m, d, *time .to_a .indexes(2, 1)) end ## def set_frequency(freq) raise "Type error: freq must be Integer\n" if !freq .is_a?(Integer) @repeatFrequency = freq end ## 繰り返しの duration 部分を設定する e == nil は forever def set_duration(beg, fin) raise "Type error: begin must be MhcDate\n" if !beg .is_a?(MhcDate) raise "Type error: end must be MhcDate\n" if fin && !fin .is_a?(MhcDate) @beg = replace_date(@beg, beg .y, beg .m, beg .d) ## @fin の日付部分は、常に @beg と同じになる ## duration end は @repeatEnd で設定 @fin = replace_date(@fin, beg .y, beg .m, beg .d) if fin @repeatForever = false @repeatEnd = Time .local(fin .y, fin .m, fin .d) else @repeatForever = true @repeatEnd = Time .local(1970, 1, 2) end end def unpack if @data != '' @event, @beg, @fin, @alarm, @advance, @advanceUnits, @repeatType, @repeatForever, @repeatEnd, @repeatFrequency, @repeatDay, @repeatDays, @repeatWeekstart, @exceptions, @exception, @description, @note = PiLib .unpack_Appointment(@data) else @event = true @beg = Time .local(1970, 1, 2) @fin = Time .local(1970, 1, 2) @alarm = false @advance = 0 @advanceUnits = 0 @repeatType = 0 @repeatForever = false @repeatEnd = Time .local(1970, 1, 2) @repeatFrequency = 0 @repeatDay = 0 @repeatDays = [false] * 7 @repeatWeekstart = 0 @exceptions = 0 @exception = [] @description = 'No Subject' @note = '' end return self end def pack ary = [@event, @beg, @fin, @alarm, @advance, @advanceUnits, @repeatType, @repeatForever, @repeatEnd, @repeatFrequency, @repeatDay, @repeatDays, @repeatWeekstart, @exceptions, @exception, @description, @note] @data = PiLib .pack_Appointment(ary) return self end end class Time def to_xscday return format("%04d%02d%02d", year, mon, day) end def to_xsctime return format("%02d:%02d", hour, min) end end ################################################################ ## ## classes for AddressBook ## class PilotAddressDB < PilotDB def initialize(pi, dbname) super ## set @id, @attr, @category, @data app_info = self .get_app_info @catRenamed, @catName, @catID, @catLastUniqueID, # [22] [22] [8] @labels, @labelsRenamed, @phoneLabels, @country, @sortByCompany = *PiLib .unpack_AddressAppInfo(app_info) ## @labels[22], @labelsRenamed[22] ## ## @phoneLabels[0..7] = ## [会社, 自宅, Fax, その他, E-mail, 代表, ポケベル, 携帯] @recClass = PilotAddRecord end end class PilotAddressRecord < PilotRecord def to_s(labels, ren, phonelabels) ret = '' # 00-03 labels[i] に対応 # 04-11 phoneLabels[@phoneLabel[i - 4]] に対応 # 12-16 labels[i] に対応 # 17-20 labels[i] に対応 (カスタム) # 21 labels[i] に対応 for i in (0 .. 2) ret += "#{labels[i]}: #{@entry[i]}\n" end for i in (3 .. 7) ret += "#{phonelabels[@phoneLabel[i-3]]}: #{@entry[i]}\n" end for i in (8 .. 18) ret += "#{labels[i]}: #{@entry[i]}\n" end return ret end private def unpack # i[5] i s[19] @phoneLabel, @showPhone, @entry = *PiLib .unpack_Address(@data) end def pack @data = PiLib .pack_Address([@phoneLabel, @showPhone, @entry]) end end ### Copyright Notice: ## Copyright (C) 1999, 2000 Yoshinari Nomura. All rights reserved. ## Copyright (C) 2000 MHC developing team. All rights reserved. ## Redistribution and use in source and binary forms, with or without ## modification, are permitted provided that the following conditions ## are met: ## ## 1. Redistributions of source code must retain the above copyright ## notice, this list of conditions and the following disclaimer. ## 2. Redistributions in binary form must reproduce the above copyright ## notice, this list of conditions and the following disclaimer in the ## documentation and/or other materials provided with the distribution. ## 3. Neither the name of the team nor the names of its contributors ## may be used to endorse or promote products derived from this software ## without specific prior written permission. ## ## THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' ## AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ## LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ## FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ## THE TEAM OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ## INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ## (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ## SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ## HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, ## STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ## ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED ## OF THE POSSIBILITY OF SUCH DAMAGE. ### mhc-palm.rb ends here yoshinari-nomura-mhc-815a36a/ruby-ext/lib/mhc-schedule.rb000066400000000000000000001255451222073515200233430ustar00rootroot00000000000000# -*- coding: utf-8 -*- ### mhc-schedule.rb ## ## Author: Yoshinari Nomura ## ## Created: 1999/07/16 ## Revised: $Date: 2008/10/08 03:22:37 $ ## ################################################################ ######## Classes for handling schedule articles. ############### ################################################################ require 'mhc-signal' require 'mhc-palm' require 'mhc-date' ################################################################ ## MHC schedule item class ## ## subject ## get X-SC-Subject: value or '' ## set_subject(aString) ## set X-SC-Subject: ## location ## get X-SC-Location: value or '' ## set_location(aString) ## set X-SC-Location: ## day ## returns active dates exist in X-SC-Day: (means drop !yyyymmdd) ## The return value is a array of MhcDate or [] ## ## day_as_string ## return a string same as X-SC-Day: or '' ## (means !yyyymmdd might be involved) ## ## add_day(aMhcDate) ## add active date to X-SC-Day: ## add_day considers other X-SC-fields smartly. ## if the date is designated for a exception, remove it. ## if the date is encumbered by duration:, raise an error. ## if the date is covered by cond:, do nothing. ## ## del_day(aMhcDate) ## inactivate aMhcDate. ## del day considers other X-SC-fields smartly. ## if the schedule item does not occur on the date, do nothing. ## if the date is covered by cond:, add a exception !yyyymmdd. ## ## exception ## return inactive dates exist in X-SC-Day: (means drop yyyymmdd) ## the return value is a array of MhcDate. ## ## time ## return a time range in a form of [aMhcTime_begin, aMhcTime_end] or nil ## ## time_as_string ## return a time range in a form of "xx:xx-xx:xx" or '' ## ## time_b ## time_e ## get a begin/end time or nil ## ## set_time(aMhcTime_b = nil , aMhcTime_e = nil) ## set begin and end times. ## ## alarm ## return X-SC-Alarm: value in second or nil. ## ## alarm_as_string ## return X-SC-Alarm: in a form of "xx (minute|hour|day)" or '' ## ## set_alarm(aInteger) ## set alarm value in second. ## nil means 'no alarm.' ## ## rec_id ## return X-SC-Record-Id: value in string ## ## set_rec_id ## set record-id for schedule entry ## ################################################################ ## category ## return X-SC-Category: value as an array of String. ## ## category_as_string ## return a string same as X-SC-Category: ## ## set_category(aString or [aString,..]) ## set X-SC-Category: ## A space separated string or an array of string is allowed as an arg. ## ## add_category(String) ## del_category(String) ## add/remove a category. ## ## cond ## return X-SC-Cond: value as an array of String or [] ## ## cond_as_string ## return a string same as X-SC-Cond: ## ## cond_mon ## cond_ord ## cond_wek ## cond_num ## return specified value of X-SC-Cond: as an array of String. ## mon stands for month => Jan .. Dec ## ord stands for order => 1st .. Last ## wek stands for week => Sun .. Sat ## num stands for number => 01 .. 31 ## ## set_cond(String or [String,..]) ## set X-SC-Cond: ## A space separated string or an array of string is allowed as an arg. ## ## add_cond(String) ## del_cond(String) ## add/remove a cond. ## ## duration -> [aMhcDate_begin, aMhcDate_end] or nil ## duration_as_string -> aString "yyyymmdd-yyyymmdd" or '' ## duration_b -> aMhcDate_begin or nil ## duration_e -> aMhcDate_end or nil ## set_duration(aMhcDate_begin = nil, aMhcDate_end = nil) ## ## description -> aString ## set_description(aString) ## ## priority -> aInteger ## priority_as_string -> aString ## set_priority(aInteger) ## ## pilot_flag() ## set_pilot_flag() ## add_pilot_flag() ## ## pilot_id ## pilot_id_as_string ## set_pilot_id([Integer, ..]) ## add_pilot_id(Integer) ## ## path -> aString ## set_path(aString) ## ## dump, dump_header ## ################################################################ ## ## set_modified ## modified? ## ## in_day?(aDate) ## in_exception?(aDate) ## in_duration?(aDate) ## in_cond?(aDate) ## in_category?(aString) ## ## occur_max, occur_min, ## ## occur_on?(aDate) ## occur_intermonth? ## occur_multiple? ## occur_any? ## ## error? ## error_message class MhcScheduleItem DURATION_MIN = MhcDate .new(1970, 1, 2) DURATION_MAX = MhcDate .new(2037, 12, 31) MON_REGEX = MhcDate::M_LABEL .join('|') WEK_REGEX = MhcDate::W_LABEL .join('|') ORD_REGEX = MhcDate::O_LABEL .join('|') MON_LONG_REGEX = MhcDate::M_LONG_LABEL .join('|') WEK_LONG_REGEX = MhcDate::W_LONG_LABEL .join('|') HDR_REGEX = '(Subject|Location|Day|Time|Category|Cond|Duration|Alarm|Record-Id)' ALM_UNITS = {'Minute' => 60, 'Hour' => 60 * 60, 'Day' => 60 * 60 * 24} ALM_LABEL = ALM_UNITS .keys ALM_REGEX = ALM_LABEL .join('|') def initialize(path_or_string = nil, is_path = true) clear if path_or_string if is_path init_by_path(path_or_string) else init_by_string(path_or_string) end end set_rec_id(create_record_id) if ! rec_id set_modified(false, 'initialize') end ################################################################ ## access methods to each field. ## subject ## subject -> aString ## set_subject(aString) def subject return @subject end def set_subject(str) @subject = str .to_s @subject .force_encoding("ASCII-8BIT") if RUBY_VERSION .to_f >= 1.9 set_modified(true, 'set_subject') return self end ## location def location return @location end def set_location(str) @location = str .to_s set_modified(true, 'set_location') return self end ## day def day return @day end def day_as_string return (@day .collect{|x| x .to_s} + @exception .collect{|x| '!' + x .to_s}) .join(' ') end def add_day(date) ## First, check to see if Duration: encumbers raise("Change Duration First\n") if !in_duration?(date) ## if date is in exception, remove, it. if in_exception?(date) @exception .delete(date) set_modified(true, 'add_day') end ## It is happy if Cond: covers the date. return self if in_cond?(date) if !in_day?(date) (@day << date) .uniq! set_modified(true, 'add_day') end return self end def del_day(date) return self if !occur_on?(date) @day .delete(date) # xxx: does it surely delete ymd? set_modified(true, 'del_day') # it may be over estimation if in_cond?(date) (@exception << date) .uniq! end return self end ## exception def exception return @exception end ## time def time return [@time_b, @time_e] if @time_b return nil end def time_as_string return @time_b .to_s + (@time_e ? '-' : '') + @time_e .to_s end def time_b; return @time_b; end def time_e; return @time_e; end def set_time(b, e = nil) @time_b, @time_e = b, e set_modified(true, 'set_time') return self end ## alarm def alarm return @alarm end def alarm_as_string alarm_str = '' if @alarm alarm_str = "#{@alarm /60} minute" if @alarm > 60 * 99 || @alarm % 3600 == 0 alarm_str = "#{@alarm /3600} hour" elsif @alarm > 3600 * 99 || @alarm % 84600 == 0 alarm_str = "#{@alarm /84600} day" end end return alarm_str end def set_alarm(sec) ## set alarm time in sec. ## nil means no alarm. @alarm = sec set_modified(true, 'set_alarm') return self end ## category def category return @category end def category_as_string return @category .join(' ') end def set_category(str) if str .kind_of?(Array) @category = str else @category = [] str .to_s .split .each{|s| s .force_encoding("ASCII-8BIT") if RUBY_VERSION .to_f >= 1.9 @category << s } end @category .uniq! set_modified(true, 'set_category') return self end def add_category(str) @category << str .capitalize return self end def del_category(str) @category .delete(str .capitalize) return self end ## cond def cond return @cond_mon + @cond_ord + @cond_wek + @cond_num end def cond_as_string return (@cond_mon + @cond_ord + @cond_wek + @cond_num) .join(' ') end def cond_mon; return @cond_mon; end def cond_ord; return @cond_ord; end def cond_wek; return @cond_wek; end def cond_num; return @cond_num; end def set_cond(str_or_array) ## arg is String or Array of String. @cond_mon, @cond_ord, @cond_wek, @cond_num = [], [], [], [] set_modified(true, 'set_cond') if str_or_array .kind_of?(Array) array = str_or_array else array = str_or_array .split end array .each{|s| add_cond(s)} return self end def add_cond(cond) cond = cond .capitalize case cond when /^(#{MON_REGEX})$/oi (@cond_mon << cond) .uniq! when /^(#{MON_LONG_REGEX})$/oi cond = MhcDate::M_LABEL[ MhcDate::M_LONG_LABEL .index(cond) ] (@cond_mon << cond) .uniq! when /^(#{ORD_REGEX})$/oi (@cond_ord << cond) .uniq! when /^(#{WEK_REGEX})$/oi (@cond_wek << cond) .uniq! when /^(#{WEK_LONG_REGEX})$/oi cond = MhcDate::W_LABEL[ MhcDate::W_LONG_LABEL .index(cond) ] (@cond_wek << cond) .uniq! when /^\d+$/ (@cond_num << format("%02d", cond .to_i)) .uniq! end set_modified(true, 'add_cond') # it may be over estimation. return self end def del_cond(cond) cond = cond .capitalize case cond when /^(#{MON_REGEX})$/oi @cond_mon .delete(cond) when /^(#{ORD_REGEX})$/oi @cond_ord .delete(cond) when /^(#{WEK_REGEX})$/oi @cond_wek .delete(cond) when /^\d\d?$/ @cond_num .delete(format("%02d", cond .to_i)) end set_modified(true, 'del_cond') # it may be over estimation. return self end ## duration def duration return [@duration_b, @duration_e] if @duration_b || @duration_e return nil end def duration_as_string if @duration_b || @duration_e return @duration_b .to_s + '-' + @duration_e .to_s else return '' end end def duration_b; return @duration_b; end def duration_e; return @duration_e; end def set_duration(b, e) @duration_b, @duration_e = b, e set_modified(true, 'set_duration') return self end ## record-id def rec_id return @rec_id end def set_rec_id(r) @rec_id = r .to_s return self end def dump_without_xsc_header #koie: if no descripton, dont convert non X-SC headers. if description .to_s == '' return '' end hdrs = non_xsc_header .to_s .sub(/\n+\z/n, '') hdrs += "\n" if hdrs != '' desc = description .to_s desc += "\n" if desc != '' and desc !~ /\n\z/n return hdrs + (desc != '' ? "\n" : '') + desc end def dump hdrs = non_xsc_header .to_s .sub(/\n+\z/n, '') hdrs += "\n" if hdrs != '' desc = description .to_s desc += "\n" if desc != '' and desc !~ /\n\z/n return dump_header + hdrs + "\n" + desc end ## non_xsc_header def non_xsc_header return @non_xsc_header end def set_non_xsc_header(txt) @non_xsc_header = txt set_modified(true, 'set_description') return self end ## description def description if @description return @description elsif @path && File .file?(@path) file = File .open(@path, "r") file .gets("\n\n") @description = file .gets(nil) file .close end return @description end def set_description(txt) @description = txt set_modified(true, 'set_description') return self end # ## description # def description(all = false) # if @description # content = @description # elsif @path && File .file?(@path) # file = File .open(@path, "r") # content = file .gets(nil) # file .close # else # content = '' # end # if content =~ /^[a-z-]+:/pi && content !~ /^http:/ip # hdr, val = content .split("\n\n", 2) # hdr << "\n" # hdr .gsub!(/^X-SC-#{HDR_REGEX}:[^\n]+\n([ \t]+[^\n]*\n)*/ino, '') # else # hdr, val = '', content # end # hdr << dump_header if all # hdr << "\n" if hdr != '' # @description = (hdr << val .to_s) # return @description # end ## priority def priority return @priority end def priority_as_string if @priority == 0 return "" else return @priority .to_s end end def set_priority(pri) begin @priority = pri .to_i rescue @priority = 0 ensure end end ## pilot_flag def pilot_flag end def set_pilot_flag end def add_pilot_flag end ## pilot_id def pilot_id end def pilot_id_as_string @pilot_id ? @pilot_id .join(' ') : '' end def set_pilot_id(id_array) @pilot_id = [] id_array .each{|id| add_pilot_id(id) } return self end def add_pilot_id(id) @pilot_id = [] if !@pilot_id @pilot_id << id set_modified(true, 'add_pilot_id') return self end ## path def path return @path end def set_path(path) @path = path set_modified(true, 'set_path') return self end ################################################################ ## dump for save. # def dump # description(true) # end def dump_header return "X-SC-Subject: #{subject}\n" + "X-SC-Location: #{location}\n" + "X-SC-Day: #{day_as_string}\n" + "X-SC-Time: #{time_as_string}\n" + "X-SC-Category: #{category_as_string}\n" + "X-SC-Priority: #{priority_as_string}\n" + "X-SC-Cond: #{cond_as_string}\n" + "X-SC-Duration: #{duration_as_string}\n" + "X-SC-Alarm: #{alarm_as_string}\n" + "X-SC-Record-Id: #{rec_id}\n" ## "X-SC-Debug-Path: #{path}\n" end ################################################################ ## various tests. ## def set_modified(bool, msg) print "#{msg} modified #{self} to #{bool}\n" if $DEBUG @modified = bool end def modified? ## impurity check. return @modified end def in_day?(date) return (@day .include?(date)) ? true : false end def in_exception?(date) ## Does the date exist as a exception? return (@exception .include?(date)) ? true : false end def in_duration?(date) return false if (@duration_b && date < @duration_b) return false if (@duration_e && date > @duration_e) return true end def in_cond?(d) ## Does the date match to the Cond: field? mon, wek, ord, num = [d .m_s, d .w_s, d .o_s, d .d_s] return false if !(@cond_mon .empty? || @cond_mon .include?(mon)) return true if @cond_num .include?(num) return false if !(@cond_ord .empty? || @cond_ord .include?(ord)) && !(d .o_last? && @cond_ord .include?('Last')) return true if @cond_wek .include?(wek) return false end def in_category?(category) if category .kind_of?(String) return @category .include?(category) else ## assumes an array. return !(@category & category) .empty? end end ################################################################ def occur_max if !(@cond_wek .empty? && @cond_num .empty?) max = DURATION_MAX .dup else # Sometimes palm makes empty @day - @exception. # ex. X-SC-Day: 20000911 !20000911 max = (@day - @exception) .max max = DURATION_MAX .dup if !max end max = @duration_e if max && @duration_e && max > @duration_e return max end def occur_min if !(@cond_wek .empty? && @cond_num .empty?) min = DURATION_MIN .dup else min = (@day - @exception) .min # Sometimes palm makes empty @day - @exception. # ex. X-SC-Day: 20000911 !20000911 min = DURATION_MIN .dup if !min end min = @duration_b if min && @duration_b && min < @duration_b return min end def occur_on?(date) return (in_day?(date) || in_cond?(date)) && !in_exception?(date) && in_duration?(date) end def occur_inter_month? if occur_min && occur_max return true if occur_min .y < occur_max .y return true if occur_min .m < occur_max .m return false ## means all occurences are in one month. else return false ## means no occurence exists. end end def todo? return /todo/i =~ category_as_string end def occur_multiple? if occur_min && occur_max return true if occur_min != occur_max else return false ## means no occurrence specified. end return false ## means there is only one occurrence. end def occur_any? ## Does this article have any occurence? return !(occur_min .nil?) end ################################################################ def error? return true if !(@subject && @subject != '') return true if !occur_any? return false end def error_message msg = [] msg << 'no subject' if !(@subject && @subject != '') msg << 'no occurences' if !occur_any? return msg .join(',') end ################################################################ ## convert to palm Datebook record. def to_palm ret = [] day_cp = day .dup ### for repeat beg, fin = occur_min, occur_max fin = nil if fin == DURATION_MAX ## First, treat X-SC-Day: field. while day_cp .length > 0 if day_cp .length > 1 && day_cp .length == day_cp .max - day_cp .min + 1 ## repeat in a series of days -- make up as a daily. ret << mk_palm_skel .set_daily(day_cp .min, day_cp .max, 1) day_cp = [] else ret << mk_palm_skel .set_nonrepeat_date(day_cp .shift) end end ## Second, treat X-SC-Cond: field. if cond .length == cond_wek .length && cond_wek .length > 0 ## weekly weeks = [] for w in 0 .. 6 weeks << cond_wek .include?(MhcDate::W_LABEL[w]) ? true : false end ret << mk_palm_skel .set_weekly(beg, fin, 1, weeks) elsif cond_ord .length >= 1 && !cond_ord .include?('5th') && cond_wek .length >= 1 && cond_num .length == 0 && cond_mon .length == 0 ## monthly by day cond_ord .each{|ord_str| cond_wek .each{|wek_str| ord = MhcDate::O_LABEL .index(ord_str) wek = MhcDate::W_LABEL .index(wek_str) if ord == 5 ord = 4 end sch2 = MhcScheduleItem .new .add_cond(ord_str) .add_cond(wek_str) beg2 = beg .dup while !sch2 .occur_on?(beg2) ## xxx 多分これは不要? beg2 .succ! end ret << mk_palm_skel .set_monthly_by_day(beg2, fin, 1, ord, wek) } } elsif cond_num .length == 1 && cond_num .length == cond .length ## monthly by date while !occur_on?(beg) ## xxx こっちは必要 beg .succ! end ret << mk_palm_skel .set_monthly_by_date(beg, fin, 1) elsif cond_num .length == 1 && cond_mon .length == 1 && cond_wek .length == 0 && cond_ord .length == 0 ## yearly by date y = beg .y m = MhcDate::M_LABEL .index(cond_mon[0]) + 1 d = cond_num[0] .to_i date = MhcDate .new(y, m, d) if date < beg date .y_succ! end ## 2/29 はどうする? ret << mk_palm_skel .set_yearly(date, fin, 1) elsif cond_ord .length == 1 && cond_ord[0] != '5th' && cond_wek .length == 1 && cond_num .length == 0 && cond_mon .length == 1 ## yearly by day ord = MhcDate::O_LABEL .index(cond_ord[0]) wek = MhcDate::W_LABEL .index(cond_wek[0]) m = MhcDate::M_LABEL .index(cond_mon[0]) + 1 date = MhcDate .new(beg .y, m, 1) if date .m < beg .m date .y_succ! end while !occur_on?(date) date .succ! end ret << mk_palm_skel .set_monthly_by_day(date, fin, 12, ord, wek) elsif cond .empty? ## do nothing else ## conversion failed. ret = [] end if ret .empty? # STDERR .print "#{occur_min .to_js} : #{subject} unsupported. ignored..\n" return nil else return ret end end ################################################################ private ################################################################ RECORD_ID_INFO = ['AAAA', nil, 0] def create_record_id(domain = 'from.mhc-schedule.rb') last_id_rand, last_id_time, last_id_counter = RECORD_ID_INFO id_time = Time .now .strftime("%Y%m%d%H%M%S") id_user = Process .uid .to_s if last_id_time && id_time == last_id_time last_id_counter += 1 last_id_rand .succ! id_rand = last_id_rand else last_id_rand = 'AAAA' id_rand = last_id_rand last_id_counter = 0 end id_rand += '-' + $$ .to_s last_id_time = id_time RECORD_ID_INFO[0], RECORD_ID_INFO[1], RECORD_ID_INFO[2] = last_id_rand, last_id_time, last_id_counter return '<' + id_time + id_rand + '.' + id_user + '@' + domain + '>' end def mk_palm_skel pi_rec = PilotApptRecord .new pi_rec .set_alarm(alarm) pi_rec .set_time(time_b, time_e) exception .each{|date| pi_rec .add_exception(date) } datebk3_icon = nil category .each{|cat| datebk3_icon = cat if cat =~ /^\#\#@@@.@@@$/ } contents = dump_without_xsc_header contents = '' if contents =~ /\A\s+\z/n ## \s includes \n contents = datebk3_icon + "\n" + contents if datebk3_icon #koie: if contents is empty, dont set note. if contents != "" pi_rec .set_note(contents) end #koie if (location .to_s != '') pi_rec .set_description(subject + '[' + location .to_s + ']') else pi_rec .set_description(subject) end return pi_rec end def clear @cond_mon, @cond_ord, @cond_wek, @cond_num = [], [], [], [] @day, @exception, @category, @pilot_id = [], [], [], [] @subject, @location, @description, @path = '', nil, nil, nil @time_b, @time_e = nil, nil @duration_b, @duration_e = nil, nil @alarm, @rec_id = nil, nil @modified = false @non_xsc_header = '' return self end def init_by_path(path) ## 1. set instance variables corresponding to X-SC-*: headers. ## 2. set @non_xsc_header as one string by non X-SC-*: headers. ## 3. set @description clear file = File .open(path, "r") all_headers = file .gets("\n\n") file .close @non_xsc_header, xsc_header_hash = select_headers(all_headers) parse_xsc_headers(xsc_header_hash) @path = path # @description will be loaded on demand from the file. return self end def init_by_string(string) clear all_headers, @description = string .split(/\n\n/, 2) @description = nil if @description == '' @non_xsc_header, xsc_header_hash = select_headers(all_headers) parse_xsc_headers(xsc_header_hash) return self end def parse_xsc_headers(hash) hash .each_pair{|key,val| case key when 'day:' while (val != '') case val when /^!/ is_exception = true when /^\d+/ if is_exception @exception << MhcDate .new($&) is_exception = false else @day << MhcDate .new($&) end when /^[^!\d]+/ # discard the word. else # never occured. end val = $' end when 'date:' ## backward compatibility if (val =~ /(\d+)\s+([A-Z][a-z][a-z])\s+(\d+)\s+(\d\d:\d\d)/) dd, mm, yy, hhmm = $1 .to_i, $2, $3 .to_i + 1900 , $4 mm = ("JanFebMarAprMayJunJulAugSepOctNovDec" .index(mm)) / 3 + 1 @time_b = (hhmm == '00:00') ? nil : MhcTime .new(hhmm) @day << MhcDate .new(yy, mm, dd) end when 'subject:' @subject = val when 'location:' @location = val when 'time:' @time_b, @time_e = val .split('-') @time_b = MhcTime .new(@time_b) if @time_b @time_e = MhcTime .new(@time_e) if @time_e when 'duration:' b, e = val .split('-') @duration_b = (b .nil? || b == '') ? nil : MhcDate .new(b) @duration_e = (e .nil? || e == '') ? nil : MhcDate .new(e) when 'category:' val .split .each{|c| @category << c .capitalize} when 'cond:' val .split .each{|d| case d when /^(#{MON_REGEX})$/oi @cond_mon << d .capitalize when /^(#{MON_LONG_REGEX})$/oi d = MhcDate::M_LABEL[ MhcDate::M_LONG_LABEL .index(d) ] @cond_mon << d .capitalize when /^(#{ORD_REGEX})$/oi @cond_ord << d .capitalize when /^(#{WEK_REGEX})$/oi @cond_wek << d .capitalize when /^(#{WEK_LONG_REGEX})$/oi d = MhcDate::W_LABEL[ MhcDate::W_LONG_LABEL. index(d) ] @cond_wek << d .capitalize when /^\d+$/ @cond_num << format("%02d", d .to_i) end } when 'alarm:' if val =~ /^(\d+)\s*(#{ALM_REGEX})$/i @alarm = ($1 .to_i) * ALM_UNITS[$2 .capitalize] end when 'record-id:' @rec_id = val when 'priority:' if val =~ /^(\d+)\s*$/i begin @priority = $1 .to_i rescue @priority = 0 end else @priority = 0 end end ## case ## } return self end # def header_to_hash(header) # hdr = {} # if header # header .gsub(/\n\s+/, ' ') .split("\n") .each{|line| # if (line =~ /^X-SC-([^:]+:)(.*)/ni) # key, val = $1 .downcase, $2 .strip # hdr[key] = val if (val != '') # end # } # end # return hdr # end ## return: X-SC-*: as a hash and ## : non X-SC-*: as one string. def select_headers(header) xsc, non_xsc, xsc_key = {}, '', nil if header # header .gsub(/\n\s+/, ' ') .split("\n") .each{|line| header .split("\n") .each{|line| if line =~ /^\S/ key, val = line .split(':', 2) if (key =~ /^X-SC-(.*)/ni) xsc_key = $1 .downcase + ':' xsc[xsc_key] = (val != '') ? val .strip : '' else xsc_key = nil non_xsc += line + "\n" end elsif line =~ /^\s/ if xsc_key xsc[xsc_key] += ' ' + line else non_xsc += line + "\n" end end } end return non_xsc, xsc end end ################################################################ class File MTIME_FILE = ".mhc-mtime" def File.utime2(atime, mtime, obj) if File .directory?(obj) if File .file?(obj + '/' + MTIME_FILE) File .utime(atime, mtime, obj + '/' + MTIME_FILE) else f = File .open(obj + '/' + MTIME_FILE, "w") f .print 'x' # FreeBSD requires this. f .fsync if f .respond_to?("fsync") f .close end end File .utime(atime, mtime, obj) end def File.mtime2(obj) if (File .directory?(obj)) and (File .file?(obj + '/' + MTIME_FILE)) File .mtime(obj + '/' + MTIME_FILE) else File .mtime(obj) end end end class MhcScheduleDB HOME = ENV['HOME'] || '' DEF_BASEDIR = HOME + '/Mail/schedule' DEF_RCFILE = HOME + '/.schedule' ALL = 'all' def initialize(basedir = DEF_BASEDIR, *rcfiles) @db = {} @mtime = {} @basedir = basedir @rcfiles = rcfiles .length == 0 ? [DEF_RCFILE] : rcfiles @slots = @rcfiles + [@basedir + '/intersect'] @alarm = nil @log = MhcLog .new(@basedir + '/.mhc-db-log') end def signal_connect(sig, &p) if !@alarm @alarm = Alarm .new @alarm .signal_connect('sec-changed'){ if update_all print "MhcScheduleDB: emit updated signal\n" if $DEBUG @alarm .signal_emit('updated') end } end return @alarm .signal_connect(sig, &p) end def signal_disconnect(id) @alarm .signal_disconnect(id) end def del_sch(sch, add_log = true) if (old_path = sch .path) old_slot = File .dirname(old_path) trash_path = get_new_path(@basedir + '/trash') File .rename(old_path, trash_path) now = Time .now File .utime2(now, now, old_slot) print "mv #{old_path} -> #{trash_path}\n" if $DEBUG end if add_log @log .add_entry(MhcLogEntry .new('D', Time .now, sch .rec_id, sch .path, sch .subject)) end sch .set_path(nil) return self end def add_sch(sch, add_log = true) new_slot = sch_to_slot(sch) old_slot = File .dirname(sch .path) if sch .path begin now = Time .now old_path = sch .path if old_slot && new_slot == old_slot new_path = old_path else new_path = get_new_path(new_slot) end contents = sch .dump f = File .open(new_path, "w") f << contents f .fsync if f .respond_to?("fsync") f .close print "#{old_path} -> #{new_path}\n" if $DEBUG File .utime2(now, now, new_slot) sch .set_path(new_path) trash_path = get_new_path(@basedir + '/trash') if old_path && File .exists?(old_path) && old_path != new_path File .rename(old_path, trash_path) File .utime2(now, now, old_slot) print "#{old_path} -> #{trash_path}\n" if $DEBUG end rescue raise("#{$!}\nWrite/Move #{old_path} -> #{new_path} failed.") end if add_log @log .add_entry(MhcLogEntry .new('M', Time .now, sch .rec_id, sch .path, sch .subject)) end sch .set_modified(false, 'add_sch') return self end def each_sch(from = nil, to = nil) if !from || !to now = MhcDate .new from = now .m_succ(-3) to = now .m_succ( 4) end hash = {} search(from, to) .each{|d, sch_ary| sch_ary .each{|sch| if !hash[sch] yield(sch) hash[sch] = true end } } end def search(from, to, category = nil, do_update = true) ret = [] for date in from .. to ret << [date, search1(date, category, do_update)] end return ret end def m_search(date, category = nil) update(date) return search(date .m_first_day, date .m_last_day, category, false) end def holiday?(date) !search1(date, 'Holiday') .empty? end def search1(d, category = nil, do_update = true) mon, wek, ord, day, date = d .m_s, d .w_s, d .o_s, d .d_s, d last = 'Last' ret = [] category_ary, category_is_invert = nil, false if category if category =~ /!/ category_is_invert = true category = category .delete('!') else category_is_invert = false end category_ary = category .split .collect{|x| x .capitalize} end search_key = [date, mon+ord+wek, mon+ALL+wek, ALL+ord+wek, ALL+ALL+wek, mon+day, ALL+day, mon+ALL, ALL+ALL] search_key << mon+last+wek << ALL+last+wek if d .o_last? update(d) if do_update to_slots(d) .each{|slot| search_key .each{|key| if @db[slot][key] .is_a?(Array) @db[slot][key] .each{|item| if (item .in_duration?(date)) && !(item .in_exception?(date)) && (!category || (!category_is_invert && item .in_category?(category_ary)) || ( category_is_invert && !item .in_category?(category_ary))) ret << item end } end } } return ret .sort{|a,b| a .time_b .to_s <=> b .time_b .to_s} .uniq end ################ private ################ def regist(slot, o) day, mon, ord, wek, num = o.day, o.cond_mon, o.cond_ord, o.cond_wek, o.cond_num day .each{|ymd| _regist(slot, ymd, o) } mon = [ALL] if (mon .empty?) ord = [ALL] if (ord .empty?) mon .each{|mon| ord .each{|ord| wek .each{|wek| _regist(slot, mon+ord+wek, o) } } num .each{|num| _regist(slot, mon + format("%02d", num .to_i), o) } if (num.empty? && wek.empty? && (day.empty? || mon != ALL)) _regist(slot, mon + ALL, o) end } end def makedir_or_higher(dir) return true if File .directory?(dir) parent = File .dirname(dir) if makedir_or_higher(parent) Dir .mkdir(dir) File .open(dir, "r") {|f| f .sync} if File .method_defined?("fsync") return true end return false end def get_new_path(slot) return nil if !makedir_or_higher(slot) new = 1 Dir .open(slot) .each{|file| if (file =~ /^\d+$/) num = file .to_i new = num + 1 if new <= num end } return slot + '/' + new .to_s end def to_slots(date) return @slots + [@basedir + '/' + format("%04d/%02d", date .y, date .m)] end def all_slots return @slots + Dir .glob(@basedir + '/[0-9]*/[0-9]*') .sort end def update(date) ret = false to_slots(date) .each{|slot| ret |= update_slot(slot) } return ret end def update_all ret = false @db .each_key{|slot| ret |= update_slot(slot) } return ret end def update_slot(slot) @db[slot] = {} if @db[slot] .nil? return false if !modified?(slot) # STDERR .print "scanning '#{slot}'\n" clear_slot(slot) if (File .file?(slot)) ## read as a rcfile. file = File .open(slot, "r") # while(header = file .gets("\n\n")) # regist(slot, MhcScheduleItem .new(header, false)) # end header = '' while (line = file .gets) line .force_encoding("ASCII-8BIT") if RUBY_VERSION .to_f >= 1.9 next if line =~ /^#/ if line == "\n" if header != '' regist(slot, MhcScheduleItem .new(header, false)) header = '' end else header += line end end file .close if header != '' regist(slot, MhcScheduleItem .new(header, false)) end elsif (File .directory?(slot)) ## read as a yyyy/mm folder. Dir .open(slot) .each{|file| if (file =~ /^\d+$/) path = slot + '/' + file regist(slot, sch = MhcScheduleItem .new(path)) end } end return true end def sch_to_slot(sch) if sch .occur_inter_month? or sch .todo? return @basedir + '/intersect' else date = sch .occur_min return @basedir + '/' + format("%04d/%02d", date .y, date .m) end end def clear_slot(slot) @db[slot] = {} end def _regist(slot, key, obj) # print "_regist #{key .inspect}\n" @db[slot] = {} if @db[slot] .nil? @db[slot][key] = [] if @db[slot][key] .nil? @db[slot][key] << obj end def modified?(slot) return false if !File .exists?(slot) if @mtime[slot] .nil? @mtime[slot] = File .mtime2(slot) return true end if @mtime[slot] < (t = File .mtime2(slot)) @mtime[slot] = t return true else return false end end end ################################################################ # Log maintenance functions. # # M 2000-04-25 00:06:08 <20.nom@.nomcom> ~nom/Mail/schedule/2000/04/1 Luncheon # D 2000-04-25 00:06:08 <20.nom@.nomcom> ~nom/Mail/schedule/2000/04/1 Luncheon # S 2000-04-25 00:06:08 user_id # class MhcLog def initialize(filename) @filename = filename end def add_entry(entry) file = File .open(@filename, "a+") file .print "#{entry}\n" file .fsync if file .respond_to?("fsync") file .close end def each_entry begin file = File .open(@filename) while line = file .gets yield(MhcLogEntry .new(line .chomp)) end file .close rescue end end def entries() arry = [] each_entry{|e| arry << e } return arry end def shrink_entries(user_id) hash = {} each_entry{|e| if e .status == 'S' and e .rec_id == user_id hash .clear else hash[e .rec_id] = e end } return hash .values end end ################ class MhcLogEntry attr :status attr :mtime attr :rec_id attr :path attr :subject def initialize(status, mtime = nil, rec_id = nil, path = nil, subject = nil) if mtime .nil? init_from_string(status) else @status, @mtime, @rec_id, @path, @subject = status, mtime, rec_id, path, subject end end def to_s return [ @status, @mtime .strftime("%Y-%m-%d %H:%M:%S"), @rec_id, @path, @subject ] .join(' ') end ################ private ################ def init_from_string(line) str = line .chomp status, yymmdd, hhmmss, rec_id, path, subject = str .split yy, mm, dd = yymmdd .split('-') h, m, s = hhmmss .split(':') mtime = Time .local(yy .to_i, mm .to_i, dd .to_i, h .to_i, m .to_i, s .to_i) @status, @mtime, @rec_id, @path, @subject = status, mtime, rec_id, path, subject end end ## MHC Alarm クラス ## ## MHC Alarm クラスは、MhcScheduleDB から、先の予定をスキャンしてきて、 ## Alarm を発行してほしい時間順にソートした配列を保存しておく。予定時 ## 間が来たら、signal を発行する。 ## ## 何者かによって、DB が変更されたら、保存している Alarm 情報が無効に ## なってしまうので、再スキャンしする。 ## ## 1. make_alarm_table : @alarm_table へ予定表の保存 ## ## 今日の日付から、LOOK_AHEAD_DAYS 日分先の予定を scan, sort する ## ## aTime はアラーム発行時間 (予定の時間ではない) ## xTime を予定の時間だとすると、 ## ## now <= aTime <= xTime な予定 --> @alarm_table に保存 ## aTime <= now <= xTime な予定 --> 即 signal を発行 ## aTime <= xTime <= now な予定 --> 捨てる ## ## @alarm_table = [[aTime, aMhcScheduleItem], ... ] ## ## ## 2. スケジュールが何者かによって変更されてしまったとき ## ## DB から updated signal を拾って、1 を実行する。そのとき、 ## ## > aTime <= now <= xTime な予定 --> 即 signal を発行 ## ## は実行しない。 ## ## 3. 1分ごとに、 ## ## a. @alarm_table の先頭と現在時刻 now を比較 ## b. aTime <= now なら signal を emit。@alarm_table から捨てて a. に戻る ## ## 4. 1日毎に、 ## ## 日が変わる毎に、最後に scan した日付の 1日先の内容を ## 1. の方法で @alarm_table に追加。 ## class MhcAlarm LOOK_AHEAD_DAYS = 100 def initialize(db = MhcScheduleDB .new) @db = db @date_begin = nil @sig_conduit = Alarm .new @alarm_table = [] @sig_conduit .signal_connect('min-changed'){ print "MhcAlarm: tick\n" if $DEBUG check_alarm_table } @sig_conduit .signal_connect('day-changed'){ print "MhcAlarm: day_changed\n" if $DEBUG update_alarm_table } @db .signal_connect('updated'){ @alarm_table = [] make_alarm_table(MhcDate .new, LOOK_AHEAD_DAYS, false) check_alarm_table } make_alarm_table(MhcDate .new, LOOK_AHEAD_DAYS, true) end def signal_connect(sig, &p) @sig_conduit .signal_connect(sig, &p) end def check check_alarm_table end ## for debug def dump_alarm_table print "DUMP #{@alarm_table .length}\n" if $DEBUG @alarm_table .each{|x| atime, sch = x print "#{atime} #{sch .subject}\n" } end ################################################################ private ## invoked when initialize and rescan. def make_alarm_table(date_begin, ahead_days, is_initialize = false) @date_begin = date_begin now = Time .now for i in 1 .. ahead_days @db .search1(@date_begin) .each{|sch| if (sch .alarm) xtime = @date_begin .to_t(sch .time_b || MhcTime .new(0, 0)) atime = xtime - sch .alarm if now <= atime @alarm_table << [atime, sch] elsif now <= xtime && is_initialize @alarm_table << [atime, sch] end end } @date_begin = @date_begin .succ end @alarm_table .sort!{|a, b| a[0] <=> b[0]} if @alarm_table if $DEBUG print "MhcAlarm::make_alarm_table\n" dump_alarm_table end end ## invoked once a minute def check_alarm_table now = Time .now while @alarm_table[0] && @alarm_table[0][0] <= now atime, sch = @alarm_table .shift xdate = time_to_date(atime + sch .alarm) printf("MhcAlarm: check_alarm_table emit !! %-8s %s\n", atime .to_s, sch .subject) if $DEBUG @sig_conduit .signal_emit('time-arrived', xdate , sch) end end ## invoked once a day def update_alarm_table shortage = MhcDate .new - @date_begin + LOOK_AHEAD_DAYS if $DEBUG print "MhcAlarm: update_alarm_table in? #{@date_begin} + #{shortage}\n" end if shortage > 0 if $DEBUG print "MhcAlarm: update_alarm_table in #{@date_begin} + #{shortage}\n" end make_alarm_table(@date_begin, shortage) end dump_alarm_table if $DEBUG end def time_to_date(time) return MhcDate .new(*time .to_a .indexes(5, 4, 3)) end end if false $alarm = MhcAlarm .new $alarm .signal_connect('time-arrived'){|date, sch| print "signal : #{date .to_js} #{sch .subject}\n" } sleep end ### Copyright Notice: ## Copyright (C) 1999, 2000 Yoshinari Nomura. All rights reserved. ## Copyright (C) 2000 MHC developing team. All rights reserved. ## Redistribution and use in source and binary forms, with or without ## modification, are permitted provided that the following conditions ## are met: ## ## 1. Redistributions of source code must retain the above copyright ## notice, this list of conditions and the following disclaimer. ## 2. Redistributions in binary form must reproduce the above copyright ## notice, this list of conditions and the following disclaimer in the ## documentation and/or other materials provided with the distribution. ## 3. Neither the name of the team nor the names of its contributors ## may be used to endorse or promote products derived from this software ## without specific prior written permission. ## ## THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' ## AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ## LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ## FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ## THE TEAM OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ## INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ## (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ## SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ## HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, ## STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ## ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED ## OF THE POSSIBILITY OF SUCH DAMAGE. ### mhc-schedule.rb ends here yoshinari-nomura-mhc-815a36a/ruby-ext/lib/mhc-signal.rb000066400000000000000000000067131222073515200230170ustar00rootroot00000000000000# -*- coding: utf-8 -*- ### mhc-signal.rb ## ## Author: Yoshinari Nomura ## ## Created: 1999/07/16 ## Revised: $Date: 2001/03/13 07:01:25 $ ## ################################################################ ################# common staff ################################# ################################################################ ################################################################ ## message couduit class SignalConduit def initialize @proc_table = {} @sd = 0 end def signal_emit(sig, *arg) return 0 if @proc_table[sig] .nil? @proc_table[sig] .keys .sort .each{|k| @proc_table[sig][k] .call(*arg) } end def signal_connect(sig, &p) @sd += 1 @proc_table[sig] = {} if @proc_table[sig] .nil? @proc_table[sig][@sd] = p return @sd end def signal_disconnect(sd) @proc_table .each_key{|sig| # @proc_table[sig][sd] = nil @proc_table[sig] .delete(sd) } end def dump @proc_table .each_key{|sig| print "(#{self}) #{sig} -> " # if $DEBUG @proc_table[sig] .each_key{|sd| print @proc_table[sig][sd], " " } print "\n" # if $DEBUG } end end ################################################################ ## message couduit with alarm class Alarm < SignalConduit def initialize super @now = Time .now .localtime @th = Thread .new { while true tick sleep 3 end } @th .abort_on_exception= true end def tick now = Time .now .localtime if (now != @now) signal_emit('sec-changed') end if (now .day != @now .day) signal_emit('day-changed') end if (now .min != @now .min) signal_emit('min-changed') end if (now .month != @now .month) signal_emit('month-changed') end @now = now end end ### Copyright Notice: ## Copyright (C) 1999, 2000 Yoshinari Nomura. All rights reserved. ## Copyright (C) 2000 MHC developing team. All rights reserved. ## Redistribution and use in source and binary forms, with or without ## modification, are permitted provided that the following conditions ## are met: ## ## 1. Redistributions of source code must retain the above copyright ## notice, this list of conditions and the following disclaimer. ## 2. Redistributions in binary form must reproduce the above copyright ## notice, this list of conditions and the following disclaimer in the ## documentation and/or other materials provided with the distribution. ## 3. Neither the name of the team nor the names of its contributors ## may be used to endorse or promote products derived from this software ## without specific prior written permission. ## ## THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' ## AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ## LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ## FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ## THE TEAM OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ## INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ## (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ## SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ## HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, ## STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ## ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED ## OF THE POSSIBILITY OF SUCH DAMAGE. ### mhc-signal.rb ends here yoshinari-nomura-mhc-815a36a/ruby-ext/mhc_pilib.c000066400000000000000000000474151222073515200220000ustar00rootroot00000000000000/* mhc_pilib.c ** ** Author: Yoshinari Nomura ** ** Created: 1999/09/01 ** Revised: $Date: 2008/09/29 00:39:11 $ ** */ /*************************************************************/ /********************* PiLib Module **************************/ /*************************************************************/ #include "ruby.h" #include "ext-helper.h" #include "pi-source.h" #include "pi-socket.h" #include "pi-file.h" #include "pi-dlp.h" #include "pi-todo.h" #include "pi-datebook.h" #include "pi-version.h" #include "pi-address.h" #include "pi-appinfo.h" VALUE mPiLib; /*************************************************************/ /******************** connection management ******************/ /*************************************************************/ /* open socket, return descriptor or nil */ static VALUE rpi_sock_open(VALUE obj, VALUE dev) { int sd, ret; sd = pi_socket(0, PI_SOCK_STREAM, 0); if (sd == -1)return Qnil; ret = pi_bind(sd, StringValuePtr(dev)); if (ret < 0) return Qnil; return INT2FIX(sd); } /* listen socket, return new descriptor or nil */ static VALUE rpi_sock_listen(VALUE obj, VALUE rb_sd) { int sd = FIX2INT(rb_sd); struct SysInfo sys_info; struct PilotUser user; if (pi_listen(sd, 1) < 0) return Qnil; if ((sd = pi_accept(sd, 0, 0)) < 0) return Qnil; /* We must do this to take care of the password being required to sync * on Palm OS 4.x */ if (dlp_ReadSysInfo(sd, &sys_info) < 0)return Qnil; if (dlp_ReadUserInfo(sd, &user) < 0) return Qnil; if (dlp_OpenConduit(sd) < 0) return Qnil; return INT2FIX(sd); } /* close socket, return nil or breakup */ static VALUE rpi_sock_close(VALUE obj, VALUE rb_sd) { int sd = FIX2INT(rb_sd); dlp_CloseDB_All(sd); dlp_EndOfSync(sd, 0); pi_close(sd); return Qnil; } /* Add an entry into the HotSync log on the Pilot. \n is OK, as usual. You may invoke this command once or more before calling EndOfSync (sockClose), but it is not required. */ static VALUE rdlp_AddSyncLogEntry(VALUE obj, VALUE sd, VALUE str) { Check_Type(str, T_STRING); if (dlp_AddSyncLogEntry(INT2FIX(sd), RSTRING_PTR(str)) < 0) return Qnil; return Qtrue; } /* Convenience function to reset lastSyncPC in the UserInfo to 0 */ static VALUE rdlp_ResetLastSyncPC(VALUE obj, VALUE sd) { if (dlp_ResetLastSyncPC(FIX2INT(sd)) < 0) return Qnil; return Qtrue; } /****************************************************************/ /********************* System Information ***********************/ /****************************************************************/ /* Get the time on the Pilot and return it as a local Time value. */ static VALUE rdlp_GetSysDateTime(VALUE obj, VALUE sd) { time_t time; if (dlp_GetSysDateTime(FIX2INT(sd), &time) < 0) return Qnil; return time_new(time, 0); } /* Set the time on the Pilot using a local Time value. */ static VALUE rdlp_SetSysDateTime(VALUE obj, VALUE sd, VALUE time) { time_t sec = NUM2ULONG(rb_funcall(time, rb_intern("tv_sec"), 0)); if (dlp_SetSysDateTime(FIX2INT(sd), sec) < 0) return Qnil; return Qtrue; } /* Ask the pilot who it is. */ static VALUE rdlp_ReadUserInfo(VALUE obj, VALUE sd, VALUE ary) { return Qnil; } /* Tell the pilot who it is. */ static VALUE rdlp_WriteUserInfo(VALUE obj, VALUE sd, VALUE ary) { return Qnil; } /****************************************************************/ /******************** open, close DB ****************************/ /****************************************************************/ /* Open a database on the Pilot, return db handler or nil. name is the ASCII name of the DB. access mode is always Read/Write for now. Mode: Read = 0x80, Write = 0x40, Exclusive = 0x20, ShowSecret = 0x10 */ static VALUE rdlp_OpenDB(VALUE obj, VALUE sd, VALUE name) { int db; Check_Type(name, T_STRING); /* xxx: cardno is always zero for now. */ if (dlp_OpenDB(FIX2INT(sd), 0, 0x80|0x40, StringValuePtr(name), &db) < 0) return Qnil; return INT2FIX(db); } /* close DB, return nil or breakup */ static VALUE rdlp_CloseDB(VALUE obj, VALUE sd, VALUE db) { dlp_CloseDB(FIX2INT(sd), FIX2INT(db)); return Qnil; } /****************************************************************/ /******************** Application Info ********************/ /****************************************************************/ static VALUE rdlp_ReadAppBlock(VALUE obj, VALUE sd, VALUE db) { int result; pi_buffer_t *buffer; VALUE ret; buffer = pi_buffer_new(0xffff); if (!buffer) return Qnil; result = dlp_ReadAppBlock(FIX2INT(sd), FIX2INT(db), 0, 0xffff, buffer); if (result <= 0) ret = Qnil; else ret = str_new(buffer->data, buffer->used); pi_buffer_free (buffer); return ret; } /****************************************************************/ /******************** DB Record Manipulation ********************/ /****************************************************************/ /* Read all Record in DB, even if marked as deleted or archived. return array of [id, attr, category, data] or nil. id, attr, category : integer. data : String which contains DB specific data, it would be transformed by pack_* or unpack_* functions. */ static VALUE rdlp_ReadRecordByIndex(VALUE obj, VALUE sd, VALUE db, VALUE i) { VALUE ary; int attr, category, len; recordid_t id; pi_buffer_t *buffer; buffer = pi_buffer_new(0xffff); if (!buffer) return Qnil; ary = ary_new(); len = dlp_ReadRecordByIndex(FIX2INT(sd), FIX2INT(db), FIX2INT(i), buffer, &id, &attr, &category); if (len <= 0) { pi_buffer_free (buffer); return Qnil; } dprintf(("id:%d atr:%d cat:%d bp:%d len:%d\n",id,attr,category,buffer,len)); dprintf(("readrecordbyindex 0\n")); ar_set1(ary, "i", id); dprintf(("readrecordbyindex 1\n")); ar_set1(ary, "i", attr); dprintf(("readrecordbyindex 2\n")); ar_set1(ary, "i", category); dprintf(("readrecordbyindex 3\n")); ary_push(ary, str_new(buffer->data, len)); dprintf(("readrecordbyindex 4\n")); pi_buffer_free (buffer); return ary; } static VALUE rdlp_ReadRecordById(VALUE obj, VALUE sd, VALUE db, VALUE vid) { VALUE ary; int attr, category, len; int index; pi_buffer_t *buffer; recordid_t id = FIX2INT(vid); buffer = pi_buffer_new(0xffff); if (!buffer) return Qnil; ary = ary_new(); len = dlp_ReadRecordById(FIX2INT(sd), FIX2INT(db), id, buffer, &index, &attr, &category); if (len <= 0) { pi_buffer_free (buffer); return Qnil; } dprintf(("id:%d atr:%d cat:%d bp:%d len:%d\n",id,attr,category,buffer,len)); ar_set1(ary, "i", id); ar_set1(ary, "i", attr); ar_set1(ary, "i", category); ary_push(ary, str_new(buffer->data, len)); pi_buffer_free (buffer); return ary; } /* Write a record to an open database, return a new record id or nil. ary is a array of [id, attr, category, data] data : String which contains DB specific data, it would be transformed by pack_* or unpack_* functions. */ static VALUE rdlp_WriteRecord(VALUE obj, VALUE sd, VALUE db, VALUE ary) { recordid_t id, new_id; int attr, category, ret, len; char *ptr; struct Appointment app; int i; VALUE a = ary_new(); pi_buffer_t *buffer; ary_copy(a, ary); ar_get1(a, "i", id); ar_get1(a, "i", attr); ar_get1(a, "i", category); ar_get1(a, "s", ptr); len = STRING_LENGTH; buffer = pi_buffer_new(len); if (!buffer) return Qnil; if(!pi_buffer_append(buffer, ptr, len)) { pi_buffer_free(buffer); return Qnil; } dprintf(("buf: %s\n", buffer->data)); unpack_Appointment(&app, buffer, datebook_v1); dprintf(("event: %d\n", app.event)); dprintf(("beg_year %d\n", app.begin.tm_year)); dprintf(("Subject: %s\n", app.description)); dprintf(("id: %d attr: %d cat: %d buf_len: %d\n", id, attr, category, len)); ret = dlp_WriteRecord(FIX2INT(sd), FIX2INT(db), attr, id, category, buffer->data, len, &new_id); pi_buffer_free(buffer); if (ret < 0){ dprintf(("%s\n", dlp_strerror(ret))); return Qnil; } dprintf(("new_id::::::: %d\n", new_id)); return INT2FIX(new_id); } /* delete a record specified by the record id. */ VALUE rdlp_DeleteRecord(VALUE obj, VALUE sd, VALUE db, VALUE all, VALUE id) { int all_cval; switch (all){ case Qfalse: all_cval = 0; break; case Qtrue: all_cval = 1; break; default: rb_raise(rb_eTypeError, "`all' must be true or false"); } if (dlp_DeleteRecord(FIX2INT(sd), FIX2INT(db), all_cval, FIX2INT(id)) < 0) return Qnil; return Qtrue; } /* Deletes all records in the opened database which are marked as archived or deleted. */ static VALUE rdlp_CleanUpDatabase(VALUE obj, VALUE sd, VALUE db) { if (dlp_CleanUpDatabase(FIX2INT(sd), FIX2INT(db)) < 0) return Qnil; return Qtrue; } /* For record databases, reset all dirty flags. For both record and resource databases, set the last sync time to now. */ static VALUE rdlp_ResetSyncFlags(VALUE obj, VALUE sd, VALUE db) { if (dlp_ResetSyncFlags(FIX2INT(sd), FIX2INT(db)) < 0) return Qnil; return Qtrue; } /****************************************************************/ /******************* For Datebook Record ************************/ /****************************************************************/ static VALUE rpack_Appointment(VALUE x, VALUE ary1) { struct Appointment app; int len, i = 0; VALUE ary = ary_new(); VALUE ret; ary_copy(ary, ary1); pi_buffer_t * buffer; buffer = pi_buffer_new(0xffff); if (!buffer) return Qnil; ar_get1(ary, "b", app.event); ar_get1(ary, "t", app.begin); ar_get1(ary, "t", app.end); ar_get1(ary, "b", app.alarm); ar_get1(ary, "i", app.advance); ar_get1(ary, "i", app.advanceUnits); ar_get1(ary, "i", app.repeatType); ar_get1(ary, "b", app.repeatForever); ar_get1(ary, "t", app.repeatEnd); ar_get1(ary, "i", app.repeatFrequency); ar_get1(ary, "i", app.repeatDay); ar_get2(ary, "b", app.repeatDays, 7); ar_get1(ary, "i", app.repeatWeekstart); ar_get1(ary, "i", app.exceptions); app.exception = (struct tm*)malloc(app.exceptions * sizeof(struct tm)); ar_get2(ary, "t", app.exception, app.exceptions); ar_get1(ary, "s", app.description); ar_get1(ary, "s", app.note); len = pack_Appointment(&app, buffer, datebook_v1); dprintf(("pack_Appointment: length: %d\n", len)); free(app.exception); ret = str_new(buffer->data, buffer->used); pi_buffer_free(buffer); return ret; } static VALUE runpack_Appointment(VALUE x, VALUE raw_str) { struct Appointment app; VALUE ary = ary_new(); pi_buffer_t *buffer; buffer = pi_buffer_new(0xffff); if (!buffer) return Qnil; Check_Type(raw_str, T_STRING); if (!pi_buffer_append(buffer, RSTRING_PTR(raw_str), RSTRING_LEN(raw_str))) { pi_buffer_free(buffer); return Qnil; } unpack_Appointment(&app, buffer, datebook_v1); ar_set1(ary, "b", app.event); dprintf(("runpack_Appointment: 0\n")); ar_set1(ary, "t", app.begin); dprintf(("runpack_Appointment: 1\n")); ar_set1(ary, "t", app.end); dprintf(("runpack_Appointment: 2\n")); ar_set1(ary, "b", app.alarm); ar_set1(ary, "i", app.advance); ar_set1(ary, "i", app.advanceUnits); ar_set1(ary, "i", app.repeatType); ar_set1(ary, "b", app.repeatForever); ar_set1(ary, "t", app.repeatEnd); dprintf(("runpack_Appointment: 3\n")); ar_set1(ary, "i", app.repeatFrequency); ar_set1(ary, "i", app.repeatDay); ar_set2(ary, "b", app.repeatDays, 7); ar_set1(ary, "i", app.repeatWeekstart); ar_set1(ary, "i", app.exceptions); ar_set2(ary, "t", app.exception, app.exceptions); dprintf(("runpack_Appointment: 4\n")); ar_set1(ary, "s", app.description); ar_set1(ary, "s", app.note); dprintf(("Subject: %s\n", app.description)); free_Appointment(&app); pi_buffer_free (buffer); return ary; } /****************************************************************/ /********* For Address Records **********************************/ /****************************************************************/ static VALUE rpack_Address(VALUE x, VALUE ary1) { struct Address add; VALUE ret; pi_buffer_t *buffer; buffer = pi_buffer_new(0xffff); if (!buffer) return Qnil; VALUE ary = ary_new(); ary_copy(ary, ary1); ar_get2(ary, "i", add.phoneLabel, 5); ar_get1(ary, "i", add.showPhone); ar_get2(ary, "s", add.entry, 19); if (pack_Address(&add, buffer, address_v1) < 0) ret = Qnil; else ret = str_new(buffer->data, buffer->used); pi_buffer_free (buffer); return ret; } static VALUE runpack_Address(VALUE x, VALUE raw_str) { struct Address add; VALUE ary = ary_new(); pi_buffer_t *buffer; buffer = pi_buffer_new(0xffff); if (!buffer) return Qnil; Check_Type(raw_str, T_STRING); if (!pi_buffer_append(buffer, RSTRING_PTR(raw_str), RSTRING_LEN(raw_str))) { pi_buffer_free(buffer); return Qnil; } unpack_Address(&add, buffer, address_v1); ar_set2(ary, "i", add.phoneLabel, 5); ar_set1(ary, "i", add.showPhone); ar_set2(ary, "s", add.entry, 19); free_Address(&add); pi_buffer_free(buffer); return ary; } static VALUE rpack_AddressAppInfo(VALUE o, VALUE ary1) { struct AddressAppInfo ai; unsigned char buf[0xffff]; int len; VALUE ary = ary_new(); ary_copy(ary, ary1); ar_get2(ary, "b", ai.category.renamed, 16); ar_get2(ary, "c", ai.category.ID, 16); ar_get1(ary, "c", ai.category.lastUniqueID); ar_get2(ary, "s16", ai.labels, 22); ar_get2(ary, "s16", ai.phoneLabels, 8); ar_get1(ary, "i", ai.country); ar_get1(ary, "b", ai.sortByCompany); len = pack_AddressAppInfo(&ai, buf, sizeof(buf)); return str_new(buf, len); } static VALUE runpack_AddressAppInfo(VALUE o, VALUE raw_str) { struct AddressAppInfo ai; VALUE ary = ary_new(); Check_Type(raw_str, T_STRING); unpack_AddressAppInfo(&ai, RSTRING_PTR(raw_str), RSTRING_LEN(raw_str)); ar_set2(ary, "b", ai.category.renamed, 16); ar_set2(ary, "s16", ai.category.name, 16); ar_set2(ary, "c", ai.category.ID, 16); ar_set1(ary, "c", ai.category.lastUniqueID); ar_set2(ary, "s16", ai.labels, 22); ar_set2(ary, "b", ai.labelRenamed, 22); ar_set2(ary, "s16", ai.phoneLabels, 8); ar_set1(ary, "i", ai.country); ar_set1(ary, "b", ai.sortByCompany); return ary; } /****************************************************************/ /********************* dump DB file *****************************/ /****************************************************************/ static VALUE cPilotFile; /* singleton method */ static VALUE rpi_file_open(int argc, VALUE *argv, VALUE klass) { struct pi_file *pf; VALUE name, obj, rec_klass; rb_scan_args(argc, argv, "11", &name, &rec_klass); Check_Type(name, T_STRING); if ((pf = pi_file_open(RSTRING_PTR(name))) == NULL){ Fail("pi_file_open"); } obj = Data_Wrap_Struct(cPilotFile, 0, (void *)pi_file_close, pf); rb_obj_call_init(obj, argc, argv); return obj; } static VALUE rpi_file_get_app_info(VALUE obj) { struct pi_file *pf; size_t len; char *ptr; Data_Get_Struct(obj, struct pi_file, pf); pi_file_get_app_info(pf, (void *) &ptr, &len); return str_new(ptr, len); } static VALUE rpi_file_read_record(VALUE obj, VALUE i) { struct pi_file *pf; size_t len; int attr, category; recordid_t id; void *ptr; VALUE ary = ary_new(); Data_Get_Struct(obj, struct pi_file, pf); if (pi_file_read_record(pf, FIX2INT(i), &ptr, &len, &attr, &category, &id) < 0){ return Qnil; } dprintf(("id:%d atr:%d cat:%d bp:%d len:%d\n",id,attr,category,ptr,len)); ar_set1(ary, "i", id); ar_set1(ary, "i", attr); ar_set1(ary, "i", category); ary_push(ary, str_new((char*)ptr, len)); return ary; } static VALUE rpi_file_close(VALUE obj) { struct pi_file *pf; Data_Get_Struct(obj, struct pi_file, pf); pi_file_close(pf); return Qnil; } /****************************************************************/ /************************* Init *********************************/ /****************************************************************/ void Init_mhc_pilib() { mPiLib = rb_define_module("PiLib"); #define mfunc rb_define_module_function /* connection management */ mfunc(mPiLib, "openSock", rpi_sock_open, 1); mfunc(mPiLib, "listenSock", rpi_sock_listen, 1); mfunc(mPiLib, "closeSock", rpi_sock_close, 1); mfunc(mPiLib, "dlp_AddSyncLogEntry", rdlp_AddSyncLogEntry, 2); mfunc(mPiLib, "dlp_ResetLastSyncPC", rdlp_ResetLastSyncPC, 1); /* system information */ mfunc(mPiLib, "dlp_GetSysDateTime", rdlp_GetSysDateTime, 1); mfunc(mPiLib, "dlp_SetSysDateTime", rdlp_SetSysDateTime, 2); mfunc(mPiLib, "dlp_ReadUserInfo", rdlp_ReadUserInfo, 2); mfunc(mPiLib, "dlp_WriteUserInfo", rdlp_WriteUserInfo, 2); /* open, close DB */ mfunc(mPiLib, "dlp_OpenDB", rdlp_OpenDB, 2); mfunc(mPiLib, "dlp_CloseDB", rdlp_CloseDB, 2); /* App info */ mfunc(mPiLib, "dlp_ReadAppBlock", rdlp_ReadAppBlock, 2); /* record manipulation */ mfunc(mPiLib, "dlp_ReadRecordByIndex", rdlp_ReadRecordByIndex, 3); mfunc(mPiLib, "dlp_ReadRecordById", rdlp_ReadRecordById, 3); mfunc(mPiLib, "dlp_WriteRecord", rdlp_WriteRecord, 3); mfunc(mPiLib, "dlp_DeleteRecord", rdlp_DeleteRecord, 4); mfunc(mPiLib, "dlp_CleanUpDatabase", rdlp_CleanUpDatabase, 2); mfunc(mPiLib, "dlp_ResetSyncFlags", rdlp_ResetSyncFlags, 2); /* for datebook */ mfunc(mPiLib, "pack_Appointment", rpack_Appointment, 1); mfunc(mPiLib, "unpack_Appointment", runpack_Appointment, 1); /* for address */ mfunc(mPiLib, "pack_Address", rpack_Address, 1); mfunc(mPiLib, "unpack_Address", runpack_Address, 1); mfunc(mPiLib, "pack_AddressAppInfo", rpack_AddressAppInfo, 1); mfunc(mPiLib, "unpack_AddressAppInfo", runpack_AddressAppInfo, 1); /* dump db file */ cPilotFile = rb_define_class("PilotFile", cObject); rb_define_singleton_method(cPilotFile, "new", rpi_file_open, -1); rb_define_singleton_method(cPilotFile, "open", rpi_file_open, -1); rb_define_method(cPilotFile, "get_app_info", rpi_file_get_app_info, 0); rb_define_method(cPilotFile, "read_record", rpi_file_read_record, 1); rb_define_method(cPilotFile, "close", rpi_file_close, 1); } /* *** Copyright Notice: ** ** Copyright (C) 1999, 2000 Yoshinari Nomura. All rights reserved. ** Copyright (C) 2000 MHC developing team. All rights reserved. ** ** Redistribution and use in source and binary forms, with or without ** modification, are permitted provided that the following conditions ** are met: ** ** 1. Redistributions of source code must retain the above copyright ** notice, this list of conditions and the following disclaimer. ** 2. Redistributions in binary form must reproduce the above copyright ** notice, this list of conditions and the following disclaimer in the ** documentation and/or other materials provided with the distribution. ** 3. Neither the name of the team nor the names of its contributors ** may be used to endorse or promote products derived from this software ** without specific prior written permission. ** ** THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' ** AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ** LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ** FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ** THE TEAM OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ** INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ** (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ** SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ** HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, ** STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ** ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED ** OF THE POSSIBILITY OF SUCH DAMAGE. ** *** mhc_pilib.c ends here */ yoshinari-nomura-mhc-815a36a/samples/000077500000000000000000000000001222073515200175605ustar00rootroot00000000000000yoshinari-nomura-mhc-815a36a/samples/DOT.schedule.sample.jp000066400000000000000000000066151222073515200236240ustar00rootroot00000000000000## ## Sample of ~/.schedule -- Japanese Holidays. ## ## Created: 1999/09/01 ## Revised: $Date: 2007/11/27 01:12:06 $ ## X-SC-Subject: 元日 X-SC-Category: Holiday X-SC-Cond: 1 Jan X-SC-Subject: 成人の日 X-SC-Category: Holiday X-SC-Cond: 15 Jan X-SC-Duration: -19990115 X-SC-Subject: 成人の日 X-SC-Category: Holiday X-SC-Cond: 2nd Mon Jan X-SC-Duration: 20000110- X-SC-Subject: 建国記念の日 X-SC-Category: Holiday X-SC-Cond: 11 Feb X-SC-Subject: みどりの日 X-SC-Category: Holiday X-SC-Cond: 29 Apr X-SC-Duration: -20060429 X-SC-Subject: 昭和の日 X-SC-Category: Holiday X-SC-Cond: 29 Apr X-SC-Duration: 20070429- X-SC-Subject: 憲法記念日 X-SC-Category: Holiday X-SC-Cond: 3 May X-SC-Subject: 国民の休日 X-SC-Category: Holiday X-SC-Cond: 4 May X-SC-Duration: -20060504 X-SC-Subject: みどりの日 X-SC-Category: Holiday X-SC-Cond: 4 May X-SC-Duration: 20070504- X-SC-Subject: こどもの日 X-SC-Category: Holiday X-SC-Cond: 5 May X-SC-Subject: 海の日 X-SC-Category: Holiday X-SC-Cond: 20 Jul X-SC-Duration: -20020720 X-SC-Subject: 海の日 X-SC-Category: Holiday X-SC-Cond: 3rd Mon Jul X-SC-Duration: 20030701- X-SC-Subject: 敬老の日 X-SC-Category: Holiday X-SC-Cond: 15 Sep X-SC-Duration: -20020915 X-SC-Subject: 敬老の日 X-SC-Category: Holiday X-SC-Cond: 3rd Mon Sep X-SC-Duration: 20030901- X-SC-Subject: 体育の日 X-SC-Category: Holiday X-SC-Cond: 10 Oct X-SC-Duration: -19991010 X-SC-Subject: 体育の日 X-SC-Category: Holiday X-SC-Cond: 2nd Mon Oct X-SC-Duration: 20001009- X-SC-Subject: 文化の日 X-SC-Category: Holiday X-SC-Cond: 3 Nov X-SC-Subject: 勤労感謝の日 X-SC-Category: Holiday X-SC-Cond: 23 Nov X-SC-Subject: 天皇誕生日 X-SC-Category: Holiday X-SC-Cond: 23 Dec ## 毎年変わる祝日と振替休日 X-SC-Subject: 春分の日 X-SC-Day: 19960320 19970320 19980321 19990321 20000320 20010320 20020321 20030321 20040320 20050320 20060321 20070321 20080320 20090320 20100321 20110321 20120320 20130320 20140321 20150321 20160320 20170320 20180321 20190321 20200320 20210320 20220321 20230321 20240320 20250320 20260320 20270321 20280320 20290320 20300320 20310321 X-SC-Category: Holiday X-SC-Subject: 秋分の日 X-SC-Day: 19960923 19970923 19980923 19990923 20000923 20010923 20020923 20030923 20040923 20050923 20060923 20070923 20080923 20090923 20100923 20110923 20120922 20130923 20140923 20150923 20160922 20170923 20180923 20190923 20200922 20210923 20220923 20230923 20240922 20250923 20260923 20270923 20280922 20290923 20300923 20310923 X-SC-Category: Holiday X-SC-Subject: 休日 X-SC-Day: 19900212 19900430 19900924 19901224 19910506 19910916 19911104 19931011 19950102 19950116 19960212 19960506 19960916 19961104 19970721 19971124 19990322 19991011 20010212 20010430 20010924 20011224 20020506 20020916 20021104 20031124 20050321 20060102 20070212 20070430 20070924 20071224 20080506 20081124 20090506 20090922 20100322 20120102 20120430 20121224 20130506 20131104 20140506 20141124 20150506 20160321 20170102 20180212 20180430 20180924 20181224 20190506 20191104 20200506 20230102 20240212 20240506 20240923 20241104 20250506 20251124 20260506 20270322 20290212 20290430 20290924 20291224 20300506 20301104 20310506 20311124 X-SC-Category: Holiday #### 最後に改行を入れる #### yoshinari-nomura-mhc-815a36a/today.in000066400000000000000000000641071222073515200175740ustar00rootroot00000000000000#!@@MHC_RUBY_PATH@@ # -*- ruby -*- ## today ## ## Author: Yoshinari Nomura ## ## Created: 1999/11/11 ## Revised: $Date: 2005/12/04 15:48:20 $ ## ## today was originally written in perl. ## This is a ruby version of it. Original authors were ## ## Yoshinari Nomura ## OHARA Shigeki ## $DEBUG2 = false MailServer = 'localhost' ## for --mail option MyHostName = 'localhost' ## for --mail option require 'mhc-schedule' require 'mhc-kconv' require 'net/smtp' class String # digest a string upto max size. # when the bound is unsafe for muti-bytes, replace the character with '$' def digest (max, tail_adjust = '$', fill_up = nil) euc = (Kconv .toeuc self)[0..max-1] if fill_up and euc .size < max return euc + fill_up * (max - euc .size) end is2byte = false euc .each_byte do |char| is2byte = ! is2byte if char & 0x80 == 0x80 end if is2byte euc[max-1] = tail_adjust end return euc end end def usage(do_exit = true) STDERR .print "usage: today [options] Show your today's schedules. --help show this message. --format=FORMAT change output format to one of: ps, html, howm --category=CATEGORY pick only in CATEGORY. '!' and space separated multiple values are allowed. --date=strig[+n] set a period of date. string is one of these: today, tomorrow, sun ... sat, yyyymmdd, yyyymm yyyymm lists all days in the month. list n+1 days of schedules if +n is given. default value is 'today+0' --mail=ADDRESS send a e-mail to ADDRESS instead of listing to stdout.\n" exit if do_exit end def string_to_date(string, range) date_from = nil date_to = nil case (string .downcase) when 'today' date_from = MhcDate .new when 'tomorrow' date_from = MhcDate .new .succ when /^(sun|mon|tue|wed|thu|fri|sat)/ date_from = MhcDate .new .w_this(string .downcase) when /^\d{8}$/ date_from = MhcDate .new(string) when /^\d{6}$/ date_from = MhcDate .new(string + '01') if range date_to = date_from .succ(range .to_i) else date_to = MhcDate .new(string + format("%02d", date_from .m_days)) end else return nil end date_to = date_from .succ((range || '0') .to_i) if !date_to return [date_from, date_to] end def get_schedule(db, from, to, category, formatter, hook = nil) ret = '' db .search(from, to, category) .each{|date, items| ret += formatter .call(date, items) } if hook return hook .call(db, from, to, category, ret) else return ret end end ################################################################ ## formatter formatter_normal = Proc .new{|date, items| ret = '' heading = format("%02d/%02d %s ", date .m, date .d, date .w_s) first = true items .each{|sch| heading = heading .gsub(/./, ' ') if !first ret += heading + format("%-11s %s%s\n", sch .time_as_string, MhcKconv::todisp(sch .subject), if sch .location and sch .location != '' ' [' + MhcKconv::todisp(sch .location) + ']' else '' end) first = false } ret } formatter_ps = Proc .new{|date, items| ret = '' heading = format("%d", date .d) items .each{|sch| if sch .in_category?('Holiday') ret += '__HOLIDAY__' end ret += heading + format(" (%-5s %s)__XXX__", sch .time_b .to_s, sch .subject .digest(15) .gsub(/([()])/, '\\\\\1')) } MhcKconv::tops(ret) } formatter_html = Proc .new{|date, items| buffer_max, buffer = 30, '' week = ['Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat'][date .w] items2 = [] items .each do |schedule| time = schedule .time_b time &&= "#{time} " items2 .push Kconv .toeuc("#{time}#{schedule .subject}") end if (string = items2 .join(", ")) .size > buffer_max string = items2 .collect {|item| item[0,10]} .join(", ") end buffer += format("%02d/%02d(%s)", date .m, date .d, week) + " " buffer += string .digest(buffer_max) + "
\n" MhcKconv::tohtml(buffer) } formatter_howm = Proc .new{|date, items| ret = '' items .each{|sch| sw = "@" ret += "[" ret += format("%04d-%02d-%02d", date .y, date .m, date .d) if (sch .time_b) ret += " " + sch .time_b .to_s else ret += " " end ret += "]" sw=" " case sch .category_as_string .downcase when /done/ sw="." when /todo/ sw="+" else sw="@" end ret += sw + " " + MhcKconv::todisp(sch .subject) + "\n" if sch .description ret += sch .description .gsub(/^/, " ") end } MhcKconv::todisp(ret) } ################################################################ ## hook hook_ps = Proc .new {|db, from, to, category, ret| ps_contents = open(__FILE__) .gets(nil) .split("__END__\n")[1] landscape = true # xxx holiday = '' schedule = '' ret .split('__XXX__') .each{|item| if item =~ /^__HOLIDAY__(.*)/ holiday += $1 else schedule += item end } trans_table = { '@MONTH@' => from .m .to_s, '@YEAR@' => from .y .to_s, '@TFONT@' => 'Times-Bold', '@DFONT@' => 'Helvetica-Bold', '@EFONT@' => 'Times-Roman', '@JFONT@' => 'Ryumin-Light-EUC-H', '@HOLIDAYS@' => holiday, '@SCHEDULES@' => schedule, '@BANNER@' => '', '@LFOOT@' => '', '@RFOOT@' => '', '@CFOOT@' => '', '@SCALE@' => landscape ? '1.0 1.0' : '0.75 0.75', '@ROTATE@' => landscape ? '90' : '0', '@TRANSLATE@' => landscape ? '50 -120' : '50 900' } trans_table .each{|key,val| ps_contents .gsub!(key, val) } ps_contents } ################################################################ ## main date_from = date_to = MhcDate .new formatter = formatter_normal hook_proc = nil while option = ARGV .shift case (option) when /^--category=(.+)/ category = $1 when /^--format=(.+)/ case $1 when 'html' formatter = formatter_html when 'ps' formatter = formatter_ps hook_proc = hook_ps date_from = date_from .m_first_day date_to = date_from .m_last_day when 'howm' formatter = formatter_howm else formatter = formatter_normal end when /^--date=([^+]+)(\+(-?[\d]+))?/ date_from, date_to = string_to_date($1, $3) || usage() when /^--mail=(.+)/ mail_address = $1 else usage() end end user_name = ENV['USERNAME'] || ENV['USER'] || ENV['LOGNAME'] || mail_address print "date_from: #{date_from .to_s}\n" if $DEBUG2 print "date_to: #{date_to .to_s}\n" if $DEBUG2 print "e-mail: #{mail_address}\n" if $DEBUG2 db = MhcScheduleDB .new if mail_address header = "To: #{mail_address}\n" header += "From: secretary-of-#{mail_address}\n" header += "Subject: Today's schedule (#{date_from .to_s})\n" header += "\n" header += "#{user_name}'s schedule: \n\n" contents = get_schedule(db, date_from, date_to, category, formatter, hook_proc) if formatter == formatter_howm contents = format("= mhc %s--%s\n", date_from .to_s, date_to .to_s) + contents end if contents && contents != '' message = MhcKconv::tomail(header + contents) message .force_encoding("ASCII-8BIT") if RUBY_VERSION .to_f >= 1.9 Net::SMTPSession .start(MailServer, 25, MyHostName) {|server| server .sendmail(message, mail_address, [mail_address]) } end else print format("= mhc %s--%s\n", date_from .to_s, date_to .to_s) if formatter == formatter_howm print get_schedule(db, date_from, date_to, category, formatter, hook_proc) end ################################################################ # postscript code from pscalj.sh ################################################################ __END__ %! % PostScript program to draw calendar % Copyright (C) 1987 by Pipeline Associates, Inc. % Permission is granted to modify and distribute this free of charge. % The number after /month should be set to a number from 1 to 12. % The number after /year should be set to the year you want. % You can change the title and date fonts, if you want. % We figure out the rest. % This program won't produce valid calendars before 1800 due to the switch % from Julian to Gregorian calendars in September of 1752 wherever English % was spoken. %% For Japanese. Added by ichimal, 2000/2/6. %% Original code is generated by k2ps. /copyfont { % font-dic extra-entry-count copyfont font-dic 1 index maxlength add dict begin { 1 index /FID ne 2 index /UniqueID ne and {def}{pop pop} ifelse } forall currentdict end } bind def %% For Japanese. Added by ichimal, 2000/2/6. %% Original code is generated by k2ps. /narrowfont { % ASCIIFontName EUCFontName compositefont font' findfont dup /FontType get 0 eq { 12 dict begin % % 7+8 bit EUC font % 12 dict begin /EUCFont exch def /FontInfo (7+8 bit EUC font) readonly def /PaintType 0 def /FontType 0 def /FontMatrix matrix def % /FontName /Encoding [ 16#00 1 16#20 { pop 0 } for 16#21 1 16#28 { 16#20 sub } for 16#29 1 16#2F { pop 0 } for 16#30 1 16#74 { 16#27 sub } for 16#75 1 16#FF { pop 0 } for ] def /FMapType 2 def EUCFont /WMode known { EUCFont /WMode get /WMode exch def } { /WMode 0 def } ifelse /FDepVector [ EUCFont /FDepVector get 0 get [ 16#21 1 16#28 {} for 16#30 1 16#74 {} for ] { 13 dict begin /EUCFont EUCFont def /UpperByte exch 16#80 add def % /FontName /FontInfo (EUC lower byte font) readonly def /PaintType 0 def /FontType 3 def /FontMatrix matrix def /FontBBox {0 0 0 0} def /Encoding [ 16#00 1 16#A0 { pop /.notdef } for 16#A1 1 16#FE { 16#80 sub 16 2 string cvrs (cXX) dup 1 4 -1 roll putinterval cvn } for /.notdef ] def % /UniqueID % /WMode /BuildChar { gsave exch dup /EUCFont get setfont /UpperByte get 2 string dup 0 4 -1 roll put dup 1 4 -1 roll put dup stringwidth setcharwidth 0 0 moveto show grestore } bind def currentdict end /lowerbytefont exch definefont } forall ] def currentdict end /eucfont exch definefont exch findfont 1 copyfont dup begin /FontMatrix FontMatrix [.83 0 0 1 0 0.05] matrix concatmatrix def end /asciifont exch definefont exch /FDepVector [ 4 2 roll ] def /FontType 0 def /WMode 0 def /FMapType 4 def /FontMatrix matrix def /Encoding [0 1] def /FontBBox {0 0 0 0} def currentdict end }{ pop findfont 0 copyfont } ifelse } def /month @MONTH@ def /year @YEAR@ def /titlefont /@TFONT@ def /dayfont /@DFONT@ def %% For Japanese. Changed by ichimal, 2000/2/6. %% Original code is generated by k2ps. % /eventfont /@EFONT@ def /Courier-Ryumin /Courier /@JFONT@ narrowfont definefont pop /eventfont /Courier-Ryumin def /holidays [ @HOLIDAYS@ ] def /schedules [ @SCHEDULES@ ] def /Bannerstring (@BANNER@) def /Lfootstring (@LFOOT@) def /Rfootstring (@RFOOT@) def /Cfootstring (@CFOOT@) def % calendar names - change these if you don't speak english % "August", "April" and "February" could stand to be kerned even if you do /month_names [ (January) (February) (March) (April) (May) (June) (July) (August) (September) (October) (November) (December) ] def /day_names [ (Sunday) (Monday) (Tuesday) (Wednesday) (Thursday) (Friday) (Saturday) ] def % layout parameters - you can change these, but things may not look nice /daywidth 100 def /dayheight 95 def /titlefontsize 48 def /weekdayfontsize 10 def /datefontsize 30 def /footfontsize 20 def /topgridmarg 35 def /leftmarg 35 def /daytopmarg 10 def /dayleftmarg 5 def % layout constants - don't change these, things probably won't work /rows 5 def /subrows 6 def % calendar constants - change these if you want a French revolutionary calendar /days_week 7 def /days_month [ 31 28 31 30 31 30 31 31 30 31 30 31 ] def /isleap { % is this a leap year? year 4 mod 0 eq % multiple of 4 year 100 mod 0 ne % not century year 1000 mod 0 eq or and % unless it's a millenia } def /ndays { % number of days in this month days_month month 1 sub get month 2 eq % February isleap and { 1 add } if } def /weekday { % weekday (range 0-6) for integer date days_week mod } def /startday { % starting day-of-week for this month /off year 2032 sub def % offset from start of "epoch" off off 4 idiv add % number of leap years off 100 idiv sub % number of centuries off 1000 idiv add % number of millenia 4 add weekday days_week add % offset from Jan 1 2032 /off exch def 1 1 month 1 sub { /idx exch def days_month idx 1 sub get idx 2 eq isleap and { 1 add } if /off exch off add def } for off weekday % 0--Sunday, 1--monday, etc. } def /prtevent { % event-string day prtevent % print out an event /start startday def /day 2 1 roll def day start add 1 sub 7 mod daywidth mul day start add 1 sub 7 div truncate dayheight neg mul -5 numevents day start add get -10 mul add numevents day start add numevents day start add get 1 add put add moveto show } def /drawevents { % read in a file full of events; print % the events for this month /numevents [0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0] def eventfont findfont 9 scalefont setfont 0 2 holidays length 2 sub { % for the "Holidays" dup 1 add holidays 2 1 roll get 2 1 roll holidays 2 1 roll get prtevent } for 0 2 schedules length 2 sub { % for the "Schedules" dup 1 add schedules 2 1 roll get 2 1 roll schedules 2 1 roll get prtevent } for } def % ------------------------------------------------------------------------ /prtnum { 3 string cvs show } def /center { % center string in given width /width exch def /str exch def width str stringwidth pop sub 2 div 0 rmoveto str show } def /centernum { exch 3 string cvs exch center } def /drawgrid { % draw calendar boxes titlefont findfont weekdayfontsize scalefont setfont currentpoint /y0 exch def /x0 exch def 0 1 days_week 1 sub { submonth 0 eq { x0 y0 moveto dup dup daywidth mul 40 rmoveto day_names exch get daywidth center } if x0 y0 moveto daywidth mul topgridmarg rmoveto 1.0 setlinewidth submonth 0 eq { /rowsused rows 1 sub def } { /rowsused rows def } ifelse 0 1 rowsused { gsave daywidth 0 rlineto 0 dayheight neg rlineto daywidth neg 0 rlineto closepath stroke grestore 0 dayheight neg rmoveto } for } for } def /drawnums { % place day numbers on calendar dayfont findfont datefontsize submonth 0 ne { 2.5 mul } if scalefont setfont /start startday def /days ndays def start daywidth mul dayleftmarg add daytopmarg rmoveto submonth 0 ne { dayleftmarg neg dayheight -2 div rmoveto } if 1 1 days { /day exch def gsave day start add weekday 0 eq { submonth 0 eq { .7 setgray } if } if day start add weekday 1 eq { submonth 0 eq { .7 setgray } if } if %% Added by ichimal, 2000.2 submonth 0 eq { 0 2 holidays length 2 sub { holidays 2 1 roll get day eq { .7 setgray exit } if } for } if submonth 0 eq { isdouble { day prtdouble } { day prtnum } ifelse } { day daywidth centernum } ifelse grestore day start add weekday 0 eq { currentpoint exch pop dayheight sub 0 exch moveto submonth 0 eq { dayleftmarg 0 rmoveto } if } { daywidth 0 rmoveto } ifelse } for } def /isdouble { % overlay today with next/last week? days start add rows days_week mul gt { day start add rows days_week mul gt { true true } { day start add rows 1 sub days_week mul gt day days_week add days le and { false true } { false } ifelse } ifelse } { false } ifelse } def /prtdouble { gsave dayfont findfont datefontsize 2 mul 3 div scalefont setfont exch { (23/) stringwidth pop dayheight rmoveto prtnum } { 0 datefontsize 5 div rmoveto prtnum 0 datefontsize -5 div rmoveto gsave dayfont findfont datefontsize scalefont setfont (/) show grestore } ifelse grestore } def /drawfill { % place fill squares on calendar /start startday def /days ndays def currentpoint /y0 exch def /x0 exch def submonth 0 eq { usefirst { /fillstart 2 def } { /fillstart 0 def } ifelse } { /fillstart 0 def } ifelse fillstart daywidth mul topgridmarg rmoveto 1.0 setlinewidth fillstart 1 start 1 sub { gsave .9 setgray daywidth 0 rlineto 0 dayheight neg rlineto daywidth neg 0 rlineto closepath fill grestore daywidth 0 rmoveto } for x0 y0 moveto submonth 0 ne { /lastday rows 1 add days_week mul def days_week 1 sub daywidth mul -440 rmoveto } { /lastday rows days_week mul 2 sub fillstart add def days_week 3 sub fillstart add daywidth mul -440 dayheight add rmoveto } ifelse lastday -1 ndays start 1 add add { /day exch def gsave .9 setgray daywidth 0 rlineto 0 dayheight neg rlineto daywidth neg 0 rlineto closepath fill grestore day weekday 1 eq { x0 y0 moveto days_week 1 sub daywidth mul -440 dayheight add rmoveto } { daywidth neg 0 rmoveto } ifelse } for } def /usefirst { % are last two boxes used by days? start ndays add rows days_week mul 3 sub gt start 2 ge and } def /calendar { titlefont findfont titlefontsize scalefont setfont 0 60 moveto /month_name month_names month 1 sub get def month_name show /yearstring year 10 string cvs def daywidth days_week mul yearstring stringwidth pop sub 60 moveto yearstring show eventflag { % Show a centered Banner if any at the Top daywidth days_week mul 2 div Bannerstring stringwidth pop 2 div sub 60 moveto Bannerstring show % Show footnotes left-center-right eventfont findfont footfontsize scalefont setfont /bottomrow { dayheight rows mul 5 sub neg } def 0 bottomrow moveto Lfootstring show daywidth days_week mul Rfootstring stringwidth pop sub bottomrow moveto Rfootstring show daywidth days_week mul Cfootstring stringwidth pop sub 2 div bottomrow moveto Cfootstring show } if 0 -5 moveto drawnums 0 -5 moveto drawfill eventflag { 0 0 moveto drawevents } if 0 -5 moveto drawgrid } def /eventflag true def @SCALE@ scale @ROTATE@ rotate @TRANSLATE@ translate /submonth 0 def calendar /eventflag false def month 1 sub 0 eq { /lmonth 12 def /lyear year 1 sub def } { /lmonth month 1 sub def /lyear year def } ifelse month 1 add 13 eq { /nmonth 1 def /nyear year 1 add def } { /nmonth month 1 add def /nyear year def } ifelse usefirst { 0 30 translate } { days_week 2 sub daywidth mul -350 translate } ifelse /submonth 1 def /year lyear def /month lmonth def gsave .138 .138 scale 12 -120 translate calendar grestore /submonth 1 def /year nyear def /month nmonth def daywidth 0 translate gsave .138 .138 scale 12 -120 translate calendar grestore showpage __END__ ### Copyright Notice: ## Copyright (C) 1999, 2000 Yoshinari Nomura. All rights reserved. ## Copyright (C) 2000 MHC developing team. All rights reserved. ## Redistribution and use in source and binary forms, with or without ## modification, are permitted provided that the following conditions ## are met: ## ## 1. Redistributions of source code must retain the above copyright ## notice, this list of conditions and the following disclaimer. ## 2. Redistributions in binary form must reproduce the above copyright ## notice, this list of conditions and the following disclaimer in the ## documentation and/or other materials provided with the distribution. ## 3. Neither the name of the team nor the names of its contributors ## may be used to endorse or promote products derived from this software ## without specific prior written permission. ## ## THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' ## AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ## LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS ## FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ## THE TEAM OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, ## INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES ## (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ## SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ## HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, ## STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ## ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED ## OF THE POSSIBILITY OF SUCH DAMAGE. ### today ends here yoshinari-nomura-mhc-815a36a/xpm/000077500000000000000000000000001222073515200167205ustar00rootroot00000000000000yoshinari-nomura-mhc-815a36a/xpm/close.xpm000066400000000000000000000006461222073515200205610ustar00rootroot00000000000000/* XPM */ static char *magick[] = { /* columns rows colors chars-per-pixel */ "25 10 2 1", "* c Purple", " c None", /* pixels */ "**** ** ***** **** ****", "**** ** ***** **** ****", "** ** ** ** ** ** ", "** ** ** ** ** ** ", "** ** ** ** **** ****", "** ** ** ** **** ****", "** ** ** ** ** ** ", "** ** ** ** ** ** ", "**** **** ***** **** ****", "**** **** ***** **** ****" }; yoshinari-nomura-mhc-815a36a/xpm/delete.xpm000066400000000000000000000005631222073515200207140ustar00rootroot00000000000000/* XPM */ static char *delete[] = { /* width height num_colors chars_per_pixel */ " 16 10 2 1", /* colors */ ". c None", "# c Red", /* pixels */ "###....####.##..", "####...####.##..", "#####..##...##..", "##.###.##...##..", "##..##.####.##..", "##..##.####.##..", "##.###.##...##..", "#####..##...##..", "####...####.####", "###....####.####" }; yoshinari-nomura-mhc-815a36a/xpm/exit.xpm000066400000000000000000000005641222073515200204240ustar00rootroot00000000000000/* XPM */ static char *magick[] = { /* columns rows colors chars-per-pixel */ "20 10 2 1", "* c Purple", " c None", /* pixels */ "**** ** ** ** ****", "**** ** ** ** ****", "** ** ** ** ** ", "** ** ** ** ** ", "**** *** ** ** ", "**** *** ** ** ", "** ** ** ** ** ", "** ** ** ** ** ", "**** ** ** ** ** ", "**** ** ** ** ** " }; yoshinari-nomura-mhc-815a36a/xpm/month.xpm000066400000000000000000000005371222073515200206000ustar00rootroot00000000000000/* XPM */ static char *magick[] = { /* columns rows colors chars-per-pixel */ "18 10 2 1", "* c Brown", " c None", /* pixels */ "******************", "* *", "* ** ** ** ** *", "* ** ** ** ** *", "* *", "* ** ** ** ** *", "* ** ** ** ** *", "* *", "* ** ** ** ** *", "******************" }; yoshinari-nomura-mhc-815a36a/xpm/next.xpm000066400000000000000000000005401222073515200204230ustar00rootroot00000000000000/* XPM */ static char *magick[] = { /* columns rows colors chars-per-pixel */ "18 10 2 1", "* c Brown", " c None", /* pixels */ " ********* ", " *********** ", " ************* ", " ***************", " ************* ", " *********** ", " ********* ", " ", " ", " ", }; yoshinari-nomura-mhc-815a36a/xpm/next2.xpm000066400000000000000000000005361222073515200205120ustar00rootroot00000000000000/* XPM */ static char *magick[] = { /* columns rows colors chars-per-pixel */ "18 10 2 1", "* c Blue", " c None", /* pixels */ " ********* ", " *********** ", "** ************* ", "** ***************", "** ************* ", "** *********** ", "** ********* ", "** ", "******** ", "****** " }; yoshinari-nomura-mhc-815a36a/xpm/next_year.xpm000066400000000000000000000005671222073515200214540ustar00rootroot00000000000000/* XPM */ static char * next_year_xpm[] = { /* columns rows colors chars-per-pixel */ "18 10 2 1", /*US*/ " c None", ". c Brown", /* pixels */ " ... ... ", " ..... ... ", " ....... ... ", " ......... ...", " ....... ... ", " ..... ... ", " ... ... ", " ", " ", " "}; yoshinari-nomura-mhc-815a36a/xpm/open.xpm000066400000000000000000000005471222073515200204150ustar00rootroot00000000000000/* XPM */ static char *open[] = { /* width height num_colors chars_per_pixel */ " 15 10 2 1", /* colors */ ". c None", "* c Red", /* pixels */ " * *****", " ***** *****", " ******* *****", "** * ** *****", "** * ** *****", "** ***** *****", "** ** * *", "** ** ** **", " ******* *** ", " ***** * " }; yoshinari-nomura-mhc-815a36a/xpm/prev.xpm000066400000000000000000000005371222073515200204270ustar00rootroot00000000000000/* XPM */ static char *magick[] = { /* columns rows colors chars-per-pixel */ "18 10 2 1", "* c Brown", " c None", /* pixels */ " ********* ", " *********** ", " ************* ", "*************** ", " ************* ", " *********** ", " ********* ", " ", " ", " " }; yoshinari-nomura-mhc-815a36a/xpm/prev2.xpm000066400000000000000000000005361222073515200205100ustar00rootroot00000000000000/* XPM */ static char *magick[] = { /* columns rows colors chars-per-pixel */ "18 10 2 1", "* c Blue", " c None", /* pixels */ " ********* ", " *********** ", " ************* **", "*************** **", " ************* **", " *********** **", " ********* **", " **", " ********", " ******" }; yoshinari-nomura-mhc-815a36a/xpm/prev_year.xpm000066400000000000000000000005671222073515200214520ustar00rootroot00000000000000/* XPM */ static char * prev_year_xpm[] = { /* columns rows colors chars-per-pixel */ "18 10 2 1", /*US*/ " c None", ". c Brown", /* pixels */ " ... ... ", " ... ..... ", " ... ....... ", "... ......... ", " ... ....... ", " ... ..... ", " ... ... ", " ", " ", " "}; yoshinari-nomura-mhc-815a36a/xpm/save.xpm000066400000000000000000000006711222073515200204100ustar00rootroot00000000000000/* XPM */ static char *save[] = { /* width height num_colors chars_per_pixel */ " 23 10 2 1", /* colors */ "* c Black", " c None", /* pixels */ "**** ****** ** ** ****", "**** ****** ** ** ****", "** ** ** ** ** ** ", "** ** ** ** ** ** ", "**** ****** ** ** ****", "**** ****** ** ** ****", " ** ****** ** ** ** ", " ** ** ** ****** ** ", "**** ** ** **** ****", "**** ** ** ** ****" }; yoshinari-nomura-mhc-815a36a/xpm/today.xpm000066400000000000000000000005631222073515200205720ustar00rootroot00000000000000/* XPM */ static char *magick[] = { /* columns rows colors chars-per-pixel */ "20 10 2 1", " c None", "* c Black", /* pixels */ " *************** ", " *****************", " *****************", " ***** ****", "*********** ****", " ********* ****", " ******* ****", " ***** *********", " *** *********", " * *********" };