kh-xyzzyfunc.l

(defun expand-file-name 
  (file &optional (dir (default-directory)))
  (merge-pathnames file dir))

001: (require "kh-base")

002: (defun Start (arg &rest z)
003:   "引数で指定するファイルを開く"
004:   (interactive)
005:   ; @begin{Cmnted out at 20180919 10:02}--------------------
006:   ; (if (string= arg "")
007:   ;     (return-from Start))
008:   ; @end{Cmnted out at 20180919 10:02}----------------------
009:   ; 
010:   ; @begin{Inserted at 20180919 10:02}----------------------
011:   (if (string= arg "")
012:       (setq arg "."))
013:   ; @end{Inserted at 20180919 10:02}------------------------
014: 
015:   (if (not (file-directory-p "C:/dirlink"))
016:       (progn
017:         (message-box 
018:          (concat "C:/dirlink が存在しません。¥n¥n"
019:                  "C:/dirlink を作成して、ディレクトリへの¥n"
020:                  "ショートカットを置いてください。¥n"
021:                  ))
022:         (call-process (concat (si:system-root) "xyzzycli.exe"))
023:         (return-from Start)))
024:   
025:   (let (fname buffer wl fcname extension binlist 
026:               compname basename)
027:     (setq fname arg)
028:     (if (not
029:          (string=
030:           (concat (directory-namestring fname)
031:                   (file-namestring fname))
032:           fname))
033:         (if (string= (pathname-type fname) "lnk")
034:             (progn
035:               (setq fname (concat "C:/dirlink/" fname))
036:               
037:               (if (not (file-exist-p fname))
038:                   (progn
039:                     (message-box 
040:                      (concat fname " は存在しません。")
041:                      "File"
042:                      )
043:                     (call-process 
044:                      (concat (si:system-root) "xyzzycli.exe"))
045:                     (return-from Start)))
046:               
047:               ; マシンの名前のリンクがないかチェックしたい
048:               (setq compname (si::getenv "COMPUTERNAME"))
049:               (setq fcname 
050:                     (concat "C:/dirlink/" basename
051:                             ".For" compname ".lnk"))
052:               (if (file-exist-p fcname)
053:                   (setq fname fcname))
054:               
055:               (setq fname (resolve-shortcut fname))
056:               )
057:           )
058:       )
059:     (if (and z (string= (pathname-type arg) "lnk"))
060:       (setq fname
061:               (merge-pathnames 
062:                (apply #'concat z) fname)))
063:     (setq fname (standard-filename-expression fname))
064:     ; 拡張子が .lnk かどうか検査し、拡張子が .lnk なら、ショ
065:     ; ートカットが指す先のファイルを fname にセットし直しま
066:     ; す。
067:     ;
068:     ; resolve-shortcut は xyzzy の内部関数です。
069:     ; 
070:     (setq extension (pathname-type fname))
071:     (if (string= extension "lnk")
072:       (progn
073:         (setq fname (resolve-shortcut fname))
074:         (setq extension (pathname-type fname))))
075:     ; 拡張子が binlist に登録しているのもののどれかなら、
076:     ; 直接起動します。
077:     (setq binlist 
078:           '("ai" "doc" "docx" "eps" "html" "jpg" "te1"
079:             "pdf" "png" "xls" "xlsx" "gif"))
080:     (if (member extension binlist :test #'equal)
081:         (progn
082:           (shell-execute fname)
083:           (return-from Start)))
084:     
085:     ; 2013-08-07
086:     ; つぎの行は何してる?
087:     (ed::kill-new fname)
088:     ;
089:     ; ファイルが無ければここで止めたらいいのかも。
090:     (if (not (file-exist-p fname))
091:         (progn
092:           (message-box 
093:            (concat fname " は存在しません。")
094:            "File"
095:            )
096:           (call-process 
097:                      (concat (si:system-root) "xyzzycli.exe"))
098:           (return-from Start)))
099:     
100:     ; fcname は現在のバッファに対応するファイル名
101:     (setq fcname (get-buffer-file-name (selected-buffer)))
102:     ; (message-box (concat "You are going to open " fname))
103:     (if (string= fname fcname)
104:         (progn
105:           ; (message-box "You are going to open the same file")
106:           (return-from Start)
107:           ))
108:     ;
109:     ; つぎの行は、nil を返すかも知れません。
110:     (setq buffer (get-file-buffer fname))
111:     ;
112:     ; list-buffer-window は、引数で指定したバッファを持つ窓
113:     ; のリストを返します。そういう窓が無ければ nil を返しま
114:     ; す。
115:     ; 引数が nil なら nil を返します。cbar の自作です。
116:     ; (sfind "list-buffer-window" *my-sitelisp* "kh-base.l")
117:     (setq wl (list-buffer-window buffer))
118:     (if wl
119:       (progn
120:           (set-window (car wl))
121:           (refresh-screen)
122:           (return-from Start)
123:           )
124:       (progn
125:         (if (file-directory-p fname)
126:           (run-explorer fname)
127:           (call-process
128:            (concat "xyzzycli.exe " (concat "¥"" (map-slash-to-backslash fname) "¥"")) :wait t)
129:           ))
130:       )
131:     )
132:   )

133: (defvar ViewProgram nil "View program path")
134: 
135: (defun View (arg &rest z)
136:   (interactive)
137:   (let (fname)
138:     (setq fname arg)
139:     (if z
140:         (setq fname (concat fname (apply #'concat z))))
141:     (setq fname 
142:           (map-slash-to-backslash 
143:            (standard-filename-expression fname)))
144:     (if ViewProgram
145:         (call-process (concat ViewProgram " " fname))
146:       (shell-execute fname t))
147:     )
148:   )

159: (defun reopen-file ()
160:   (interactive)
161:   (setq *lastpos* (point))
162:   (let (fname)
163:     (setq fname (get-buffer-file-name))
164:     (if fname
165:         (progn
166:           (if (buffer-modified-p (selected-buffer))
167:               (progn
168:                 (write-file (get-buffer-file-name))
169:                 (set-buffer-modified-p nil))
170:             )
171:           (kill-buffer (selected-buffer))
172:           (File fname)
173:           (goto-char *lastpos*)
174:           (set-buffer-modified-p t)
175:           (save-buffer)
176:           )
177:       (message-box 
178:        (concat "このバッファはファイルに対応していない¥n"
179:                "ので何もしません。")
180:        "reopen-file"
181:        '(:information))
182:       ))
183:     )

184: (defun files-dir ()
185:   (concat (get-buffer-file-name) ".files/"))

186: (defun sl ()
187:   (interactive)
188:   (let (fname)
189:     (setq fname 
190:        (read-file-name "filename: "
191:                        :default *my-sitelisp*))
192:     ; (leave-howm-frame)
193:     (find-file fname)))

194: (defun google-url ()
195:   (interactive)
196:   (let (url beg end)
197:     (beginning-of-line)
198:     (re-search-forward "¥¥(https¥¥|ftp¥¥|http¥¥):" nil)
199:     (setq beg (match-beginning 0))
200:     (re-search-forward "[ ¥t¥n¥">]" nil)
201:     ; (backward-char)
202:     (setq end (point))
203:     (goto-char beg)
204:     (setq url (buffer-substring beg end))
205:     (shell-execute url t)
206:     )
207:   )

208: (defun search-google (&optional str)
209:   (interactive)
210:   (unless str
211:     (setq str (read-string "Google: ")))
212:   (long-operation
213:     (let ((url (concat
214:                                  "http://www.google.co.jp/search?hl=ja&lr=lang_ja&num=50&ie=shift_jis&oe=euc-jp&q="
215:                       (si:www-url-encode str))))
216:       ;─────────────────────
217:       ; 標準ブラウザを使う場合
218:       (shell-execute url t)
219:       ; 2. browser.dll & browserex.l を使う場合
220:       ; (bx::navigate url)
221:       ; 3. www-mode を使う場合
222:       ; (www-open-url url)
223:       ; 4. 指定したブラウザを使う場合
224:       ; (call-process (concat "mychrome.exe " url))
225:       ;─────────────────────
226:       )))

227: (defun Explorer (arg &rest z)
228:   (interactive)
229:   (open-filer)
230:   (let (dir)
231:     (setq dir arg)
232:     (if z
233:         (setq dir (concat dir (apply #'concat z))))
234:     (shell-execute (expand-file-name dir)))
235: )

236: (defun Folder (arg &rest z)
237:   (interactive)
238:   
239:   (if (not (file-directory-p "c:/dirlink"))
240:       (progn
241:         (message-box 
242:          (concat "C:/dirlink が存在しません。¥n¥n"
243:                  "C:/dirlink を作成して、ディレクトリへの¥n"
244:                  "ショートカットを置いてください。¥n"
245:                  ))
246:         (call-process (concat (si:system-root) "xyzzycli.exe"))
247:         (return-from Folder)))
248:   
249:   (open-filer)
250:   (let (dir extension basename fcname)
251:     (setq dir arg)
252:     (if (not
253:          (string=
254:           (concat (directory-namestring dir)
255:                   (file-namestring dir))
256:           dir))
257:         (if (string= (pathname-type dir) "lnk")
258:             (progn
259:               (setq dir (concat "C:/dirlink/" dir))
260:               (setq basename (pathname-name dir))
261:               (if (not (file-exist-p dir))
262:                   (progn
263:                     (message-box 
264:                      (concat dir " は存在しません。")
265:                      "Folder"
266:                      )
267:                     (call-process 
268:                      (concat (si:system-root) "xyzzycli.exe"))
269:                     (return-from Folder)))
270:               
271:               ; マシンの名前のリンクがないかチェックしたい
272:               (setq compname (si::getenv "COMPUTERNAME"))
273:               (setq fcname 
274:                     (concat "C:/dirlink/" basename
275:                             ".For" compname ".lnk"))
276:               (if (file-exist-p fcname)
277:                   (setq dir fcname))
278:               
279:               (setq dir (resolve-shortcut dir))
280:               )
281:           )
282:       )
283:     
284:     (if z
285:         (setq dir
286:               (merge-pathnames 
287:                (apply #'concat z) dir)))
288: 
289:     (setq dir (expand-file-name dir))
290:     (setq extension (pathname-type dir))
291:     (if (string= extension "lnk")
292:         (progn
293:           (setq dir (resolve-shortcut dir))
294:           (setq extension (pathname-type dir))))
295:     
296:     (if (file-directory-p dir)
297:         (filer-chdir dir)
298:       (progn 
299:         (message-box (concat dir " is not a directory."))
300:         (call-process 
301:          (concat (si:system-root) "xyzzycli.exe"))
302:         ))
303:     )
304:   )

(File "sitelisp.lnk" "kh-local.l") 

305: (defun Console (&optional arg &rest z)
306:   (interactive)
307:   (let (wdir dir)
308:     (setq dir (default-directory))
309:     (if arg
310:         (progn
311:           (setq wdir arg)
312:           (if z
313:               (setq wdir (concat wdir (apply #'concat z))))
314:          (set-default-directory wdir)))
315:     (run-console)
316:     (set-default-directory dir)
317:     )
318:   )

485: (defun Xv (arg &rest z)
486:   "引数で指定するファイルを開く"
487:   (interactive)
488:   (if (string= arg "")
489:       (return-from Xv))
490:   
491:   (let (fname extension fcname buffer)
492:     (setq fname arg)
493:     (setq fname (standard-filename-expression fname))
494:     ; フルパス名の形に変更します。
495:     
496:     (setq extension (pathname-type fname))
497:     ; ファイルが無ければここで止めます。
498:     (if (not (file-exist-p fname))
499:         (progn
500:           (message-box 
501:            (concat fname " は存在しません。")
502:            "Xv"
503:            )
504:           (return-from Xv)))
505:     ; ファイルは画像ファイルのはずなんですが。
506:     ; 
507:     ; 拡張子が binlist に登録しているのもののどれかなら、
508:     ; 直接起動します。
509:     (setq binlist 
510:           '("ai" "doc" "docx" "eps" "gif" "jpg" "te1"
511:             "pdf" "png" "xls" "xlsx"))
512:     (if (member 
513:          (string-downcase extension)
514:          binlist :test #'equal)
515:         (progn
516:           (shell-execute fname)
517:           (return-from Xv)))
518:     
519:     ; 2013-08-07
520:     ; つぎの行は何してる?
521:     (ed::kill-new fname)
522:     
523:     ; fcname は現在のバッファに対応するファイル名
524:     (setq fcname (get-buffer-file-name (selected-buffer)))
525:     ; (message-box (concat "You are going to open " fname))
526:     (if (string= fname fcname)
527:         (progn
528:           ; (message-box "You are going to open the same file")
529:           (return-from Xv)
530:           ))
531:     ;
532:     ; つぎの行は、nil を返すかも知れません。
533:     (setq buffer (get-file-buffer fname))
534:     ;
535:     ; list-buffer-window は、引数で指定したバッファを持つ窓
536:     ; のリストを返します。そういう窓が無ければ nil を返しま
537:     ; す。
538:     ; 引数が nil なら nil を返します。cbar の自作です。
539:     ; (sfind "list-buffer-window" *my-sitelisp* "kh-base.l")
540:     (setq wl (list-buffer-window buffer))
541:     (if wl
542:       (progn
543:           (set-window (car wl))
544:           (refresh-screen)
545:           (return-from Xv)
546:           )
547:       (progn
548:         ; (other-window)
549:         (call-process
550:          (concat "notepad.exe " (concat "¥"" (map-slash-to-backslash fname) "¥"")) :wait t))
551:       )
552:     )
553:   )

554: (defun Start-current-file ()
555:   (interactive)
556:   (shell-execute (get-buffer-file-name (selected-buffer)))
557:   )

558: (defun vfile (fname)
559:   (interactive "fFile: ")
560:   ;(find-file fname)
561:   (File fname)
562:   (toggle-read-only)
563:    ; 既に、ファイル fname を読み込んでいて、それが read-only に
564:    ; なっている場合、これで、read-only でなくなっているので、
565:    ; read-only にします。
566:    (if (not buffer-read-only)
567:        (toggle-read-only))
568:    )

569: (defun vFile (arg &rest z)
570:   (let (fname)
571:     (setq fname arg)
572:     (if (not
573:          (string=
574:           (concat (directory-namestring fname)
575:                   (file-namestring fname))
576:           fname))
577:         (if (string= (pathname-type fname) "lnk")
578:             (progn
579:               (setq fname (concat "C:/dirlink/" fname))
580:               (if (not (file-exist-p fname))
581:                   (progn
582:                     (message-box 
583:                      (concat fname " は存在しません。")
584:                      "vFile"
585:                      )
586:                     (call-process 
587:                      (concat (si:system-root) "xyzzycli.exe"))
588:                     (return-from vFile)))
589:               (setq fname (resolve-shortcut fname))
590:               )
591:           )
592:       )
593:     (if z
594:         (setq fname
595:               (merge-pathnames 
596:                (apply #'concat z) fname)))
597:     (setq fname (standard-filename-expression fname))
598:     (message-box 
599:      (concat fname "¥n¥nをread-only-modeで表示します。"
600:              "¥n¥n編集するには、C-x C-q をタイプしてください。"
601:              )
602:      )
603:     (call-process 
604:                      (concat (si:system-root) "xyzzycli.exe"))
605:     (vfile fname)))

606: (defun lnk-dir (arg)
607:   (let (dir extension)
608:     (setq dir (expand-file-name arg))
609:     (setq extension (pathname-type dir))
610:     (if (string= extension "lnk")
611:         (setq dir (concat (resolve-shortcut dir) "/"))
612:       (progn
613:         (message-box (concat arg " is not a shortcut."))
614:         (return-from lnk-dir "")))
615:     dir))

770: (defun search-google-selection ()
771:   (interactive)
772:   (let (start end)
773:     (if (not (get-selection-type))
774:         (exchange-region-and-selection))
775:     (setq start (selection-mark))
776:     (setq end (selection-point))
777:     (search-google (buffer-substring start end))))

778: (defun google-search (from to)
779:   (interactive "r")
780:   (let (searchword url)
781:     (setq searchword (buffer-substring from to))
782:     (setq 
783:      url 
784:      (concat 
785:       "http://www.google.com/search?q=" 
786:       "¥"" searchword "¥""))
787:     (shell-execute url t)
788:     )
789:   )

803: ;; 引数 url をブラウザで開きます。
804: ;;
805: ;; (open-url "http://_
806: ;;            rfri.org")
807: (defun open-url (url)
808:   (interactive)
809:   (shell-execute url t)
810:   )

  (lf "sitelisp.lnk" "kh-xyzzyfunc.l")

  (lf "foo.lnk" "foobarstring")

811: (defun lf (arg &rest z)
812:   "リンクファイルも使用してファイルのフルパスを指定"
813:   (interactive)
814:   
815:   (if (not (file-directory-p "c:/dirlink"))
816:       (progn
817:         (message-box 
818:          (concat "C:/dirlink が存在しません。¥n¥n"
819:                  "C:/dirlink を作成して、ディレクトリへの¥n"
820:                  "ショートカットを置いてください。¥n"
821:                  ))
822:         (call-process (concat (si:system-root) "xyzzycli.exe"))
823:         (return-from lf)))
824:   
825:   (if (string= arg "")
826:       (return-from lf))
827:   (let (fname buffer wl fcname extension binlist compname basename)
828:     (setq fname arg)
829:     (if (not
830:          (string=
831:           (concat (directory-namestring fname)
832:                   (file-namestring fname))
833:           fname))
834:         (if (string= (pathname-type fname) "lnk")
835:             (progn
836:               (setq fname (concat "C:/dirlink/" fname))
837:               
838:               (setq basename (pathname-name fname))
839:               (if (not (file-exist-p fname))
840:                   (progn
841:                     (my-message-box 
842:                      (concat fname " は存在しません。")
843:                      "lf"
844:                      )
845:                     (return-from lf)))
846:               
847:               ; マシンの名前のリンクがないかチェックしたい
848:               (setq compname (si::getenv "COMPUTERNAME"))
849:               (setq fcname 
850:                     (concat "C:/dirlink/" basename
851:                             ".For" compname ".lnk"))
852:               (if (file-exist-p fcname)
853:                   (setq fname fcname))
854:               
855:               (setq fname (resolve-shortcut fname))
856:               )
857:           )
858:       )
859:     (if z
860:         (setq fname
861:               (merge-pathnames 
862:                (apply #'concat z) fname)))
863:     (setq fname (standard-filename-expression fname))
864:     (setq extension (pathname-type fname))
865:     (if (string= extension "lnk")
866:         (progn
867:           (setq fname (resolve-shortcut fname))
868:           (setq extension (pathname-type fname))))
869:     fname))

  (bfl "KifuW.lnk")

  (call-process (bfl "KifuW.lnk"))

  (bfl "KifuW")

870: (defun bfl (basename)
871:   "リンクファイルも使用してファイルのフルパスを指定"
872:   (interactive)
873:   
874:   (if (not (file-directory-p "c:/binfilelink"))
875:       (progn
876:         (message-box 
877:          (concat 
878:           "C:/binfilelink が存在しません。¥n¥n"
879:           "C:/binfilelink を作成して、バイナリファイルへの¥n"
880:           "ショートカットを置いてください。¥n"
881:           ))
882:         (call-process (concat (si:system-root) "xyzzycli.exe"))
883:         (return-from bfl)))
884:   
885:   (if (string= basename "")
886:       (return-from bfl))
887:   (let (fname fcname compname)
888:     (if (string= (pathname-type basename) "lnk")
889:         (setq basename (pathname-name basename)))
890:     (setq fname (concat basename ".lnk"))
891:     (setq fname (concat "C:/binfilelink/" fname))
892:     (if (not (file-exist-p fname))
893:         (progn
894:           (my-message-box 
895:            (concat fname " は存在しません。")
896:            )
897:           (return-from bfl)))
898:               
899:     ; マシンの名前のリンクがないかチェックしたい
900:     (setq compname (si::getenv "COMPUTERNAME"))
901:     (setq fcname 
902:           (concat "C:/binfilelink/" basename
903:                   ".For" compname ".lnk"))
904:     (if (file-exist-p fcname)
905:         (setq fname fcname))
906:     
907:     (setq fname (resolve-shortcut fname))
908:     (setq fname (standard-filename-expression fname))
909:     fname))

910: (defun scrf (basename extention)
911:   "マシン用のスクリプトファイルを返す"
912:   (if (not (file-directory-p "c:/scriptfile"))
913:       (progn
914:         (message-box 
915:          (concat 
916:           "C:/scriptfile が存在しません。¥n¥n"
917:           "C:/scriptfile を作成して、スクリプトファイルを¥n"
918:           "置いてください。¥n"
919:           ))
920:         (call-process (concat (si:system-root) "xyzzycli.exe"))
921:         (return-from scrf)))
922:   
923:   (if (string= basename "")
924:       (return-from scrf))
925:   (let (fname compname)
926:     (setq compname (si::getenv "COMPUTERNAME"))
927:     (setq fname 
928:           (concat "C:/scriptfile/" 
929:                   basename
930:                   ".For"
931:                   compname
932:                   extention))
933:     (if (not (file-exist-p fname))
934:         (progn
935:           (setq fname 
936:                 (concat "C:/scriptfile/" basename extention))
937:           (setq basename (pathname-name basename))
938:           (if (not (file-exist-p fname))
939:             (progn
940:               (my-message-box 
941:                (concat fname " は存在しません。")
942:                )
943:               (return-from scrf)))))
944:     fname))

945: (defun pl ()
946:   (interactive)
947:   (let (dir flnk extname)
948:     (if (not (file-directory-p "c:/dirlink"))
949:         (progn
950:           (message-box 
951:            (concat "C:/dirlink が存在しません。¥n¥n"
952:                    "C:/dirlink を作成して、ディレクトリへの¥n"
953:                    "ショートカットを置いてください。¥n"
954:                    ))
955:           (call-process (concat (si:system-root) "xyzzycli.exe"))
956:           (return-from pl)))
957:     (setq flnk
958:        (read-file-name 
959:         "dirlink file: "
960:         :default "c:/dirlink/"))
961:     (setq extname (pathname-type flnk))
962:     (if (file-exist-p flnk)
963:         (progn
964:           (if (string= extname "lnk")
965:               (progn
966:                 (setq extname flnk)
967:                 (open-filer)
968:                 (setq dir (resolve-shortcut flnk))
969:                 (filer-activate-toplevel)
970:                 (filer-chdir dir)
971:                 (open-filer))
972:             (message 
973:              (concat flnk " is not a shortcut file."))))
974:       (message (concat flnk " does not exist.")))
975:     )
976:   )

977: (provide "kh-xyzzyfunc")