cwiki-common.el

   1 ;; -*- coding: utf-8-mcs-er -*-
   2 (require 'char-db-util)
   3 (require 'chiset-common)
   4 ;; (require 'concord-images)
   5
   6 (setq file-name-coding-system 'utf-8-mcs-er)
   7
   8 (concord-assign-genre 'code-point "/usr/local/var/chise-ipld/db")
   9 (concord-assign-genre 'coded-character "/usr/local/var/chise-ipld/db")
  10 (concord-assign-genre 'glyph "/usr/local/var/chise-ipld/db")
  11
  12 (concord-assign-genre 'image-resource "/usr/local/var/photo/db")
  13 (concord-assign-genre 'glyph-image "/usr/local/var/photo/db")
  14
  15 (concord-assign-genre 'creator@ruimoku "/usr/local/var/ruimoku/db")
  16 (concord-assign-genre 'person-name@ruimoku "/usr/local/var/ruimoku/db")
  17
  18 (concord-assign-genre 'journal-volume@ruimoku "/usr/local/var/ruimoku/db")
  19 (concord-assign-genre 'article@ruimoku "/usr/local/var/ruimoku/db")
  20 (concord-assign-genre 'book@ruimoku "/usr/local/var/ruimoku/db")
  21
  22 (concord-assign-genre 'classification@ruimoku "/usr/local/var/ruimoku/db")
  23 (concord-assign-genre 'region@ruimoku "/usr/local/var/ruimoku/db")
  24 (concord-assign-genre 'era@ruimoku "/usr/local/var/ruimoku/db")
  25 (concord-assign-genre 'period@ruimoku "/usr/local/var/ruimoku/db")
  26 (concord-assign-genre 'journal@ruimoku "/usr/local/var/ruimoku/db")
  27 (concord-assign-genre 'journal-name@ruimoku "/usr/local/var/ruimoku/db")
  28 (concord-assign-genre 'publisher@ruimoku "/usr/local/var/ruimoku/db")
  29 (concord-assign-genre 'publisher-name@ruimoku "/usr/local/var/ruimoku/db")
  30
  31 (mount-char-attribute-table '*instance@ruimoku/bibliography/title)
  32 ;; (mount-char-attribute-table '*instance@ruimoku/bibliography/content*note)
  33
  34 (concord-assign-genre 'entry@zh-classical "/usr/local/var/kanbun/db")
  35 ;; (concord-assign-genre 'morpheme-entry@zh-classical "/usr/local/var/kanbun/db")
  36 (concord-assign-genre 'word-class@zh-classical "/usr/local/var/kanbun/db")
  37 (concord-assign-genre 'morpheme@zh-classical "/usr/local/var/kanbun/db")
  38 (concord-assign-genre 'sentence@zh-classical "/usr/local/var/kanbun/db")
  39 ;; (concord-assign-genre 'sentence-entry@zh-classical "/usr/local/var/kanbun/db")
  40
  41 (mount-char-attribute-table '*instance@morpheme-entry/zh-classical)
  42
  43 (concord-assign-genre 'ud@zh-classical "/usr/local/var/kanbun/db")
  44
  45
  46 (concord-assign-genre 'hng-card "/usr/local/var/hng-card/db")
  47
  48 (mount-char-attribute-table '->HNG)
  49 (mount-char-attribute-table '<-HNG)
  50 (mount-char-attribute-table '->HNG@CN/manuscript)
  51 (mount-char-attribute-table '<-HNG@CN/manuscript)
  52 (mount-char-attribute-table '->HNG@CN/printed)
  53 (mount-char-attribute-table '<-HNG@CN/printed)
  54 (mount-char-attribute-table '->HNG@JP/manuscript)
  55 (mount-char-attribute-table '<-HNG@JP/manuscript)
  56 (mount-char-attribute-table '->HNG@JP/printed)
  57 (mount-char-attribute-table '<-HNG@JP/printed)
  58 (mount-char-attribute-table '->HNG@KR)
  59 (mount-char-attribute-table '<-HNG@KR)
  60 (mount-char-attribute-table '->HNG@MISC)
  61 (mount-char-attribute-table '<-HNG@MISC)
  62
  63 (mount-char-attribute-table 'abstract-glyph@iwds-1)
  64 (mount-char-attribute-table 'abstract-glyph@iwds-1/confluented)
  65
  66
  67 (defvar est-hide-cgi-mode nil)
  68 (defvar est-view-url-prefix "..")
  69 (defvar chise-wiki-view-url "view.cgi")
  70 (defvar chise-wiki-edit-url "edit.cgi")
  71
  72 (defvar chise-wiki-bitmap-glyphs-url
  73   "http://www.chise.org/glyphs")
  74
  75 (defvar chise-wiki-hng-bitmap-glyphs-url
  76   "http://hng.chise.org/glyphs/HNG")
  77
  78 (defvar chise-wiki-daijiten-bitmap-glyphs-url
  79   "http://hng.chise.org/glyphs/daijiten")
  80
  81 (defvar chise-wiki-glyph-cgi-url
  82   "http://www.chise.org/chisewiki/glyph.cgi")
  83
  84 (defvar chise-wiki-displayed-features nil)
  85
  86 (defvar est-coded-charset-priority-list
  87   '(; =ucs
  88     =cns11643-1 =cns11643-2 =cns11643-3
  89     =cns11643-4 =cns11643-5 =cns11643-6 =cns11643-7
  90     =gb2312 =gb12345
  91     =jis-x0208 =jis-x0208@1990
  92     =jis-x0213-2
  93     =jis-x0212
  94     =adobe-japan1
  95     =cbeta =jef-china3
  96     =jis-x0213-1@2000 =jis-x0213-1@2004
  97     =jis-x0208@1983 =jis-x0208@1978
  98     =zinbun-oracle =>zinbun-oracle
  99     =daikanwa
 100     =gt =gt-k
 101     =>>>adobe-japan1
 102     =>>>jis-x0208 =>>>jis-x0213-1 =>>>jis-x0213-2
 103     =>>jis-x0208 =>>jis-x0213-1 =>>jis-x0213-2
 104     =>>adobe-japan1
 105     =+>jis-x0208 =+>jis-x0213-1 =+>jis-x0213-2
 106     =+>jis-x0208@1978
 107     =+>adobe-japan1
 108     =>jis-x0208 =>jis-x0213-1
 109     =>>gt
 110     =>ucs@iso =>ucs@unicode
 111     =>ucs@jis =>ucs@cns =>ucs@ks
 112     =+>ucs@iso =+>ucs@unicode
 113     =>>ucs@iso =>>ucs@unicode
 114     =>>ucs@jis =>>ucs@cns =>>ucs@ks
 115     =>>>ucs@iso =>>>ucs@unicode
 116     =>>>ucs@jis =>>>ucs@cns =>>>ucs@ks
 117     ===ucs@iso
 118     =ruimoku-v6
 119     =big5
 120     =big5-cdp
 121     =>cbeta
 122     =mj
 123     ==mj
 124     ===mj
 125     =ucs-itaiji-001
 126     =ucs-itaiji-002
 127     =ucs-itaiji-003
 128     =ucs-itaiji-004
 129     =ucs-itaiji-005
 130     =ucs-itaiji-006
 131     =ucs-itaiji-007
 132     =ucs-itaiji-008
 133     =ucs-itaiji-009
 134     =ucs-itaiji-010
 135     =ucs-itaiji-011
 136     =ucs-itaiji-084
 137     =ucs-var-001
 138     =ucs-var-002
 139     =ucs-var-003
 140     =ucs-var-004
 141     =ucs@unicode
 142     ==ucs@unicode
 143     ===ucs@unicode
 144     ==>daijiten
 145     ==>ucs@bucs
 146     ===daikanwa/+p
 147     ===gt
 148     =>ucs@iwds-1
 149     =>ucs@component
 150     =>ucs-itaiji-001
 151     =>ucs-itaiji-002
 152     =>ucs-itaiji-003
 153     =>ucs-itaiji-004
 154     =>ucs-itaiji-005
 155     =>ucs-itaiji-006
 156     =>ucs-itaiji-007
 157     ===adobe-japan1
 158     ===cns11643-1 ===cns11643-2 ===cns11643-3
 159     ===cns11643-4 ===cns11643-5 ===cns11643-6 ===cns11643-7
 160     ))
 161
 162 (defun decode-uri-string (string &optional coding-system)
 163   (if (> (length string) 0)
 164       (let ((i 0)
 165             dest)
 166         (setq string
 167               (mapconcat (lambda (char)
 168                            (if (eq char ?+)
 169                                " "
 170                              (char-to-string char)))
 171                          string ""))
 172         (while (string-match "%\\([0-9A-F][0-9A-F]\\)" string i)
 173           (setq dest (concat dest
 174                              (substring string i (match-beginning 0))
 175                              (char-to-string
 176                               (int-char
 177                                (string-to-int (match-string 1 string) 16))))
 178                 i (match-end 0)))
 179         (decode-coding-string
 180          (concat dest (substring string i))
 181          coding-system))))
 182
 183 (defun www-feature-type (feature-name)
 184   (or (char-feature-property feature-name 'type)
 185       (let ((str (symbol-name feature-name)))
 186         (cond
 187          ((string-match "\\*note\\(@[^*]+\\)?$" str)
 188           'stext)
 189          ((string-match "\\*sources\\(@[^*]+\\)?$" str)
 190           'domain-list)
 191          ((string-match "\\*" str)
 192           nil)
 193          ((string-match "^\\(->\\|<-\\)" str)
 194           'relation)
 195          ((string-match "^ideographic-structure\\(@\\|$\\)" str)
 196           'structure)
 197          ))))
 198
 199 (defun www-feature-format (feature-name)
 200   (or (char-feature-property feature-name 'presentation-format)
 201       (char-feature-property feature-name 'format)
 202       (let (fn parent ret)
 203         (setq fn feature-name)
 204         (while (and (setq parent (char-feature-name-parent fn))
 205                     (null (setq ret
 206                                 (char-feature-property
 207                                  parent 'format))))
 208           (setq fn parent))
 209         ret)
 210       '((name) " : " (value))))
 211
 212 (defun www-feature-value-format (feature-name)
 213   (or (char-feature-property feature-name 'value-presentation-format)
 214       (char-feature-property feature-name 'value-format)
 215       (let (fn parent ret)
 216         (setq fn feature-name)
 217         (while (and (setq parent (char-feature-name-parent fn))
 218                     (null (setq ret
 219                                 (or (char-feature-property
 220                                      parent 'value-presentation-format)
 221                                     (char-feature-property
 222                                      parent 'value-format)))))
 223           (setq fn parent))
 224         ret)
 225       (let ((type (www-feature-type feature-name)))
 226         (cond ((eq type 'relation)
 227                'space-separated)
 228               ((eq type 'structure)
 229                'space-separated-ids)
 230               ((eq type 'stext)
 231                'wiki-text)
 232               ))
 233       (if (find-charset feature-name)
 234           (if (and (= (charset-dimension feature-name) 2)
 235                    (= (charset-chars feature-name) 94))
 236               '("0x" (HEX)
 237                 " (" (decimal) ") <" (ku-ten) "> " (prev-char) (next-char))
 238             '("0x" (HEX) " (" (decimal) ") " (prev-char) (next-char))))
 239       'space-separated))
 240
 241 (defun char-feature-name-at-domain (feature-name domain)
 242   (if domain
 243       (let ((name (symbol-name feature-name)))
 244         (cond
 245          ((string-match "@[^*]+$" name)
 246           (intern (format "%s/%s" name domain))
 247           )
 248          (t
 249           (intern (format "%s@%s" name domain))
 250           )))
 251     feature-name))
 252
 253 (defun char-feature-name-parent (feature-name)
 254   (let ((name (symbol-name feature-name)))
 255     (if (string-match "@[^@/*]+\\(/[^@/*]+\\)*$" name)
 256         (intern (substring name 0 (car (last (match-data) 2)))))))
 257
 258 (defun char-feature-name-domain (feature-name)
 259   (let ((name (symbol-name feature-name)))
 260     (if (string-match "@[^@/*]+\\(/[^@/*]+\\)*$" name)
 261         (intern (substring name (1+ (match-beginning 0)))))))
 262
 263 (defun char-feature-name-sans-versions (feature)
 264   (let ((feature-name (symbol-name feature)))
 265     (if (string-match "[@/]\\$rev=latest$" feature-name)
 266         (intern (substring feature-name 0 (match-beginning 0)))
 267       feature)))
 268
 269 (defun est-object-genre (object)
 270   (if (characterp object)
 271       'character
 272     (concord-object-genre object)))
 273
 274 (defun www-get-feature-value (object feature)
 275   (let ((latest-feature (char-feature-name-at-domain feature '$rev=latest)))
 276     (cond
 277      ((characterp object)
 278       (mount-char-attribute-table latest-feature)
 279       (or (char-feature object latest-feature)
 280           (char-feature object feature))
 281       )
 282      (t
 283       (or (condition-case nil
 284               (concord-object-get object latest-feature)
 285             (error nil))
 286           (condition-case nil
 287               (concord-object-get object feature)
 288             (error nil)))
 289       ))))
 290
 291 (defun get-previous-code-point (ccs code)
 292   (let ((chars (charset-chars ccs))
 293         (dim (charset-dimension ccs))
 294         (i 0)
 295         mask byte-min byte-max
 296         bytes dest)
 297     (cond
 298      ((= chars 94)
 299       (setq mask #x7F
 300             byte-min 33
 301             byte-max 126)
 302       )
 303      ((= chars 96)
 304       (setq mask #x7F
 305             byte-min 32
 306             byte-max 127)
 307       )
 308      ((= chars 128)
 309       (setq mask #x7F
 310             byte-min 0
 311             byte-max #xFF)
 312       )
 313      (t ; (= chars 256)
 314       (setq mask #xFF
 315             byte-min 0
 316             byte-max #xFF)
 317       ))
 318     (setq bytes (make-vector dim 0))
 319     (while (< i dim)
 320       (aset bytes i (logand (lsh code (* i -8)) mask))
 321       (setq i (1+ i)))
 322     (setq i 0)
 323     (while (and (< i dim)
 324                 (progn
 325                   (aset bytes i (1- (aref bytes i)))
 326                   (< (aref bytes i) byte-min)))
 327       (aset bytes i byte-max)
 328       (setq i (1+ i)))
 329     (when (< i dim)
 330       (setq dest (aref bytes 0)
 331             i 1)
 332       (while (< i dim)
 333         (setq dest (logior dest (lsh (aref bytes i) (* i 8)))
 334               i (1+ i)))
 335       dest)))
 336
 337 (defun get-next-code-point (ccs code)
 338   (let ((chars (charset-chars ccs))
 339         (dim (charset-dimension ccs))
 340         (i 0)
 341         mask byte-min byte-max
 342         bytes dest)
 343     (cond
 344      ((= chars 94)
 345       (setq mask #x7F
 346             byte-min 33
 347             byte-max 126)
 348       )
 349      ((= chars 96)
 350       (setq mask #x7F
 351             byte-min 32
 352             byte-max 127)
 353       )
 354      ((= chars 128)
 355       (setq mask #x7F
 356             byte-min 0
 357             byte-max #xFF)
 358       )
 359      (t ; (= chars 256)
 360       (setq mask #xFF
 361             byte-min 0
 362             byte-max #xFF)
 363       ))
 364     (setq bytes (make-vector dim 0))
 365     (while (< i dim)
 366       (aset bytes i (logand (lsh code (* i -8)) mask))
 367       (setq i (1+ i)))
 368     (setq i 0)
 369     (while (and (< i dim)
 370                 (progn
 371                   (aset bytes i (1+ (aref bytes i)))
 372                   (> (aref bytes i) byte-max)))
 373       (aset bytes i byte-min)
 374       (setq i (1+ i)))
 375     (when (< i dim)
 376       (setq dest (aref bytes 0)
 377             i 1)
 378       (while (< i dim)
 379         (setq dest (logior dest (lsh (aref bytes i) (* i 8)))
 380               i (1+ i)))
 381       dest)))
 382
 383 (defun find-previous-defined-code-point (ccs code)
 384   (let ((i (get-previous-code-point ccs code))
 385         char)
 386     (cond
 387      ((eq ccs '=jis-x0208)
 388       (setq ccs '=jis-x0208@1990))
 389      ((eq ccs '=jis-x0213-1)
 390       (setq ccs '=jis-x0213-1@2004)))
 391     (while (and i
 392                 (>= i 0)
 393                 (null (setq char (decode-char ccs i
 394                                               (unless (eq ccs '=ucs)
 395                                                 'defined-only)))))
 396       (setq i (get-previous-code-point ccs i)))
 397     char))
 398
 399 (defun find-next-defined-code-point (ccs code)
 400   (let ((i (get-next-code-point ccs code))
 401         max char)
 402     (setq max (+ code 1000))
 403     (cond
 404      ((eq ccs '=jis-x0208)
 405       (setq ccs '=jis-x0208@1990))
 406      ((eq ccs '=jis-x0213-1)
 407       (setq ccs '=jis-x0213-1@2004)))
 408     (while (and i
 409                 (<= i max)
 410                 (null (setq char (decode-char ccs i
 411                                               (unless (eq ccs '=ucs)
 412                                                 'defined-only)))))
 413       (setq i (get-next-code-point ccs i)))
 414     char))
 415
 416
 417 ;;; @ URI representation
 418 ;;;
 419
 420 ;; (defun est-uri-decode-feature-name-body (uri-feature)
 421 ;;   (let ((len (length uri-feature))
 422 ;;         (i 0)
 423 ;;         ch dest)
 424 ;;     (while (< i len)
 425 ;;       (setq dest
 426 ;;             (concat
 427 ;;              dest
 428 ;;              (if (eq (aref uri-feature i) ?\.)
 429 ;;                  (if (and (< (+ i 2) len)
 430 ;;                           (eq (aref uri-feature (+ i 2)) ?\.))
 431 ;;                      (prog1
 432 ;;                          (cond
 433 ;;                           ((eq (setq ch (aref uri-feature (1+ i))) ?\.)
 434 ;;                            "/")
 435 ;;                           ((eq ch ?-)
 436 ;;                            "*")
 437 ;;                           ((eq ch ?_)
 438 ;;                            "+")
 439 ;;                           (t
 440 ;;                            (substring uri-feature i (+ i 3))
 441 ;;                            ))
 442 ;;                        (setq i (+ i 3)))
 443 ;;                    (setq i (1+ i))
 444 ;;                    ".")
 445 ;;                (prog1
 446 ;;                    (char-to-string (aref uri-feature i))
 447 ;;                  (setq i (1+ i)))))))
 448 ;;     dest))
 449
 450 ;; (defun est-uri-encode-feature-name-body (feature)
 451 ;;   (mapconcat (lambda (c)
 452 ;;                (cond ((eq c ?*)
 453 ;;                       ".-.")
 454 ;;                      ((eq c ?/)
 455 ;;                       "...")
 456 ;;                      ((eq c ?+)
 457 ;;                       "._.")
 458 ;;                      (t (char-to-string c))))
 459 ;;              feature ""))
 460
 461 (defun www-uri-decode-feature-name (uri-feature)
 462   (let (feature)
 463     (setq uri-feature (decode-uri-string uri-feature 'utf-8-mcs-er))
 464     (cond
 465      ((string-match "^from\\." uri-feature)
 466       (intern (format "<-%s"
 467                       (est-uri-decode-feature-name-body
 468                        (substring uri-feature (match-end 0)))))
 469       )
 470      ((string-match "^to\\." uri-feature)
 471       (intern (format "->%s"
 472                       (est-uri-decode-feature-name-body
 473                        (substring uri-feature (match-end 0)))))
 474       )
 475      ((string-match "^rep\\." uri-feature)
 476       (intern (format "=%s"
 477                       (est-uri-decode-feature-name-body
 478                        (substring uri-feature (match-end 0)))))
 479       )
 480      ((string-match "^rep[2i]\\." uri-feature)
 481       (intern (format "===%s"
 482                       (est-uri-decode-feature-name-body
 483                        (substring uri-feature (match-end 0)))))
 484       )
 485      ((string-match "^g\\." uri-feature)
 486       (intern (format "=>>%s"
 487                       (est-uri-decode-feature-name-body
 488                        (substring uri-feature (match-end 0)))))
 489       )
 490      ((string-match "^g[i2]\\." uri-feature)
 491       (intern (format "==%s"
 492                       (est-uri-decode-feature-name-body
 493                        (substring uri-feature (match-end 0)))))
 494       )
 495      ((string-match "^gi\\([0-9]+\\)\\." uri-feature)
 496       (intern (format "=>>%s%s"
 497                       (make-string (string-to-int
 498                                     (match-string 1 uri-feature))
 499                                    ?>)
 500                       (est-uri-decode-feature-name-body
 501                        (substring uri-feature (match-end 0)))))
 502       )
 503      ((string-match "^o\\." uri-feature)
 504       (intern (format "=+>%s"
 505                       (est-uri-decode-feature-name-body
 506                        (substring uri-feature (match-end 0)))))
 507       )
 508      ((string-match "^a\\." uri-feature)
 509       (intern (format "=>%s"
 510                       (est-uri-decode-feature-name-body
 511                        (substring uri-feature (match-end 0)))))
 512       )
 513      ((string-match "^a\\([0-9]+\\)\\." uri-feature)
 514       (intern (format "%s>%s"
 515                       (make-string (string-to-int
 516                                     (match-string 1 uri-feature))
 517                                    ?=)
 518                       (est-uri-decode-feature-name-body
 519                        (substring uri-feature (match-end 0)))))
 520       )
 521      ((and (setq uri-feature (est-uri-decode-feature-name-body uri-feature))
 522            (setq feature (intern (format "=>%s" uri-feature)))
 523            (find-charset feature))
 524       feature)
 525      ((and (setq feature (intern (format "=>>%s" uri-feature)))
 526            (find-charset feature))
 527       feature)
 528      ((and (setq feature (intern (format "=>>>%s" uri-feature)))
 529            (find-charset feature))
 530       feature)
 531      ((and (setq feature (intern (format "=%s" uri-feature)))
 532            (find-charset feature))
 533       feature)
 534      (t (intern uri-feature)))))
 535
 536 (defun www-uri-encode-feature-name (feature-name)
 537   (setq feature-name (symbol-name feature-name))
 538   (cond
 539    ((string-match "^=\\+>\\([^=>]+\\)" feature-name)
 540     (concat "o."
 541             (est-uri-encode-feature-name-body
 542              (substring feature-name (match-beginning 1))))
 543     )
 544    ((string-match "^=\\([^=>]+\\)" feature-name)
 545     (concat "rep."
 546             (est-uri-encode-feature-name-body
 547              (substring feature-name (match-beginning 1))))
 548     )
 549    ((string-match "^==\\([^=>]+\\)" feature-name)
 550     (concat "g2."
 551             (est-uri-encode-feature-name-body
 552              (substring feature-name (match-beginning 1))))
 553     )
 554    ((string-match "^===\\([^=>]+\\)" feature-name)
 555     (concat "repi."
 556             (est-uri-encode-feature-name-body
 557              (substring feature-name (match-beginning 1))))
 558     )
 559    ((string-match "^=>>\\([^=>]+\\)" feature-name)
 560     (concat "g."
 561             (est-uri-encode-feature-name-body
 562              (substring feature-name (match-beginning 1))))
 563     )
 564    ((string-match "^=>>>\\([^=>]+\\)" feature-name)
 565     (concat "gi."
 566             (est-uri-encode-feature-name-body
 567              (substring feature-name (match-beginning 1))))
 568     )
 569    ((string-match "^=>>\\(>+\\)" feature-name)
 570     (format "gi%d.%s"
 571             (length (match-string 1 feature-name))
 572             (est-uri-encode-feature-name-body
 573              (substring feature-name (match-end 1))))
 574     )
 575    ((string-match "^=>\\([^=>]+\\)" feature-name)
 576     (concat "a."
 577             (est-uri-encode-feature-name-body
 578              (substring feature-name (match-beginning 1))))
 579     )
 580    ((string-match "^\\(=+\\)>" feature-name)
 581     (format "a%d.%s"
 582             (length (match-string 1 feature-name))
 583             (est-uri-encode-feature-name-body
 584              (substring feature-name (match-end 0))))
 585     )
 586    ((string-match "^->" feature-name)
 587     (concat "to."
 588             (est-uri-encode-feature-name-body
 589              (substring feature-name (match-end 0))))
 590     )
 591    ((string-match "^<-" feature-name)
 592     (concat "from."
 593             (est-uri-encode-feature-name-body
 594              (substring feature-name (match-end 0))))
 595     )
 596    (t (est-uri-encode-feature-name-body feature-name))))
 597
 598 (defun www-uri-make-feature-name-url (uri-genre uri-feature-name uri-object)
 599   (if est-hide-cgi-mode
 600       (format "../feature/%s&%s/%s"
 601               uri-feature-name uri-genre uri-object)
 602     (format "%s?feature=%s&%s=%s"
 603             chise-wiki-view-url uri-feature-name uri-genre uri-object)))
 604
 605 (defun www-uri-decode-object (genre char-rep)
 606   (let (ccs cpos)
 607     (cond
 608      ((string-match (if est-hide-cgi-mode
 609                         "\\(%3D\\|=\\|%3A\\|:\\)"
 610                       "\\(%3A\\|:\\)") char-rep)
 611       (setq ccs (substring char-rep 0 (match-beginning 0))
 612             cpos (substring char-rep (match-end 0)))
 613       (setq ccs (www-uri-decode-feature-name ccs))
 614       (setq cpos (est-uri-decode-feature-name-body cpos))
 615       (cond
 616        ((string-match "^0x" cpos)
 617         (setq cpos
 618               (string-to-number (substring cpos (match-end 0)) 16))
 619         )
 620        (t
 621         (setq cpos (car (read-from-string
 622                          (decode-uri-string
 623                           cpos file-name-coding-system))))
 624         ))
 625       (if (and (eq genre 'character)
 626                (numberp cpos))
 627           (decode-char ccs cpos)
 628         (concord-decode-object ccs cpos genre))
 629       )
 630      (t
 631       (setq char-rep (decode-uri-string char-rep 'utf-8-mcs-er))
 632       (cond
 633        ((eq genre 'character)
 634         (when (= (length char-rep) 1)
 635           (aref char-rep 0))
 636         )
 637        ((eq genre 'feature)
 638         (concord-decode-object
 639          '=id (www-uri-decode-feature-name char-rep) 'feature)
 640         )
 641        (t
 642         (concord-decode-object
 643          '=id (car (read-from-string char-rep)) genre)
 644         ))))))
 645
 646 (defun www-uri-encode-object (object)
 647   (if (characterp object)
 648       (if (encode-char object '=ucs)
 649           (mapconcat
 650            (lambda (byte)
 651              (format "%%%02X" byte))
 652            (encode-coding-string (char-to-string object) 'utf-8-mcs-er)
 653            "")
 654         (let ((ccs-list est-coded-charset-priority-list)
 655               ccs ret)
 656           (while (and ccs-list
 657                       (setq ccs (pop ccs-list))
 658                       (not (setq ret (encode-char object ccs 'defined-only)))))
 659           (cond (ret
 660                  (format (if est-hide-cgi-mode
 661                              "%s=0x%X"
 662                            "%s:0x%X")
 663                          (www-uri-encode-feature-name ccs)
 664                          ret))
 665                 ((and (setq ccs (car (split-char object)))
 666                       (setq ret (encode-char object ccs)))
 667                  (format (if est-hide-cgi-mode
 668                              "%s=0x%X"
 669                            "%s:0x%X")
 670                          (www-uri-encode-feature-name ccs)
 671                          ret))
 672                 (t
 673                  (format (if est-hide-cgi-mode
 674                              "system-char-id=0x%X"
 675                            "system-char-id:0x%X")
 676                          (encode-char object 'system-char-id))
 677                  ))))
 678     (format (if est-hide-cgi-mode
 679                 "rep.id=%s"
 680               "rep.id:%s")
 681             (est-uri-encode-feature-name-body
 682              (format "%s" (concord-object-id object))))))
 683
 684 (defun est-format-object (object &optional readable)
 685   (if (characterp object)
 686       (char-to-string object)
 687     (let ((ret (or (if readable
 688                        (or (concord-object-get object 'name)
 689                            (concord-object-get object '=name)
 690                            (concord-object-get object 'title)))
 691                    (concord-object-id object))))
 692       (format "%s" ret))))
 693
 694 (defun www-uri-make-object-url (object &optional uri-object)
 695   (if est-hide-cgi-mode
 696       (format "%s/%s/%s"
 697               est-view-url-prefix
 698               (est-object-genre object)
 699               (or uri-object
 700                   (www-uri-encode-object object)))
 701     (format "%s?%s=%s"
 702             chise-wiki-view-url
 703             (est-object-genre object)
 704             (or uri-object
 705                 (www-uri-encode-object object)))))
 706
 707
 708 ;;; @ Feature name presentation
 709 ;;;
 710
 711 (defun www-format-feature-name-default (feature-name)
 712   (mapconcat
 713    #'capitalize
 714    (split-string
 715     (symbol-name feature-name)
 716     "-")
 717    " "))
 718
 719 (defun www-format-feature-name-as-metadata (feature-name &optional lang)
 720   (let ((str (symbol-name feature-name))
 721         base meta)
 722     (cond
 723      ((string-match "\\*[^*]+$" str)
 724       (setq base (substring str 0 (match-beginning 0))
 725             meta (substring str (match-beginning 0)))
 726       (concat (www-format-feature-name* (intern base) lang)
 727               meta))
 728      (t
 729       (www-format-feature-name-default feature-name)
 730       ))))
 731
 732 (defun www-format-feature-name-as-rel-to (feature-name)
 733   (concat "\u2192" (substring (symbol-name feature-name) 2)))
 734
 735 (defun www-format-feature-name-as-rel-from (feature-name)
 736   (concat "\u2190" (substring (symbol-name feature-name) 2)))
 737
 738 (defun www-format-feature-name-as-CCS (feature-name)
 739   (let* ((rest
 740           (split-string
 741            (symbol-name feature-name)
 742            "-"))
 743          (dest (upcase (pop rest))))
 744     (when (string-match "^=+>*" dest)
 745       (setq dest (concat (substring dest 0 (match-end 0))
 746                          " "
 747                          (substring dest (match-end 0)))))
 748     (cond
 749      (rest
 750       (while (cdr rest)
 751         (setq dest (concat dest " " (upcase (pop rest)))))
 752       (if (string-match "^[0-9]+$" (car rest))
 753           (concat dest "-" (car rest))
 754         (concat dest " " (upcase (car rest))))
 755       )
 756      (t dest))))
 757
 758 (defun www-format-feature-name* (feature-name &optional lang)
 759   (let (name fn parent ret)
 760     (cond
 761      ((or (and lang
 762                (char-feature-property
 763                 feature-name
 764                 (intern (format "name@%s" lang))))
 765           (char-feature-property
 766            feature-name 'name)))
 767      ((and (setq name (symbol-name feature-name))
 768            (string-match "\\*" name))
 769       (www-format-feature-name-as-metadata feature-name lang))
 770      (t
 771       (setq fn feature-name)
 772       (while (and (setq parent (char-feature-name-parent fn))
 773                   (null (setq ret
 774                               (or (and lang
 775                                        (char-feature-property
 776                                         parent
 777                                         (intern (format "name@%s" lang))))
 778                                   (char-feature-property
 779                                    parent 'name)))))
 780         (setq fn parent))
 781       (cond
 782        (ret
 783         (concat ret (substring (symbol-name feature-name)
 784                                (length (symbol-name parent)))))
 785        ((find-charset feature-name)
 786         (www-format-feature-name-as-CCS feature-name))
 787        ((string-match "^\\(->\\)" name)
 788         (www-format-feature-name-as-rel-to feature-name))
 789        ((string-match "^\\(<-\\)" name)
 790         (www-format-feature-name-as-rel-from feature-name))
 791        (t
 792         (www-format-feature-name-default feature-name)
 793         ))
 794       ))))
 795
 796 (defun www-format-feature-name (feature-name &optional lang)
 797   (www-format-encode-string
 798    (www-format-feature-name* feature-name lang)))
 799
 800
 801 ;;; @ HTML generator
 802 ;;;
 803
 804 (defvar www-format-char-img-style "vertical-align:bottom;")
 805
 806 (defun www-format-encode-string (string &optional without-tags as-body)
 807   (with-temp-buffer
 808     (insert string)
 809     (let (plane code subcode start end char variants ret rret)
 810       (when as-body
 811         (goto-char (point-min))
 812         (while (search-forward "&" nil t)
 813           (replace-match "&amp;" nil t)))
 814       (goto-char (point-min))
 815       (while (search-forward "<" nil t)
 816         (replace-match "&lt;" nil t))
 817       (goto-char (point-min))
 818       (while (search-forward ">" nil t)
 819         (replace-match "&gt;" nil t))
 820       (if without-tags
 821           (encode-coding-region (point-min)(point-max) 'utf-8-mcs-er)
 822         (let ((coded-charset-entity-reference-alist
 823                (list*
 824                 '(=gt                   "GT-" 5 d)
 825                 '(=mj                    "MJ" 6 d)
 826                 '(=hanyo-denshi/ja   "HD-JA-" 4 X)
 827                 '(=hanyo-denshi/jb   "HD-JB-" 4 X)
 828                 '(=hanyo-denshi/jc   "HD-JC-" 4 X)
 829                 '(=hanyo-denshi/jd   "HD-JD-" 4 X)
 830                 '(=hanyo-denshi/ft   "HD-FT-" 4 X)
 831                 '(=hanyo-denshi/ia   "HD-IA-" 4 X)
 832                 '(=hanyo-denshi/ib   "HD-IB-" 4 X)
 833                 '(=hanyo-denshi/hg   "HD-HG-" 4 X)
 834                 '(=hanyo-denshi/ip   "HD-IP-" 4 X)
 835                 '(=hanyo-denshi/jt   "HD-JT-" 4 X)
 836                 '(=hanyo-denshi/ks   "HD-KS-" 6 d)
 837                 '(=>>hanyo-denshi/ja "G-HD-JA-" 4 X)
 838                 '(=>>hanyo-denshi/jb "G-HD-JB-" 4 X)
 839                 '(=>>hanyo-denshi/jc "G-HD-JC-" 4 X)
 840                 '(=>>hanyo-denshi/jd "G-HD-JD-" 4 X)
 841                 '(=>>hanyo-denshi/ft "G-HD-FT-" 4 X)
 842                 '(=>>hanyo-denshi/ia "G-HD-IA-" 4 X)
 843                 '(=>>hanyo-denshi/ib "G-HD-IB-" 4 X)
 844                 '(=>>hanyo-denshi/hg "G-HD-HG-" 4 X)
 845                 '(=>>hanyo-denshi/ip "G-HD-IP-" 4 X)
 846                 '(=>>hanyo-denshi/jt "G-HD-JT-" 4 X)
 847                 '(=>>hanyo-denshi/ks "G-HD-KS-" 6 d)
 848                 '(==mj                  "g2-MJ" 6 d)
 849                 '(==hanyo-denshi/ja "g2-HD-JA-" 4 X)
 850                 '(==hanyo-denshi/jb "g2-HD-JB-" 4 X)
 851                 '(==hanyo-denshi/jc "g2-HD-JC-" 4 X)
 852                 '(==hanyo-denshi/jd "g2-HD-JD-" 4 X)
 853                 '(==hanyo-denshi/ft "g2-HD-FT-" 4 X)
 854                 '(==hanyo-denshi/ia "g2-HD-IA-" 4 X)
 855                 '(==hanyo-denshi/ib "g2-HD-IB-" 4 X)
 856                 '(==hanyo-denshi/hg "g2-HD-HG-" 4 X)
 857                 '(==hanyo-denshi/ip "g2-HD-IP-" 4 X)
 858                 '(==hanyo-denshi/jt "g2-HD-JT-" 4 X)
 859                 '(==hanyo-denshi/ks "g2-HD-KS-" 6 d)
 860                 '(==daijiten          "g2-DJT-" 5 d)
 861                 '(=cns11643-1           "C1-" 4 X)
 862                 '(=cns11643-2           "C2-" 4 X)
 863                 '(=cns11643-3           "C3-" 4 X)
 864                 '(=cns11643-4           "C4-" 4 X)
 865                 '(=cns11643-5           "C5-" 4 X)
 866                 '(=cns11643-6           "C6-" 4 X)
 867                 '(=cns11643-7           "C7-" 4 X)
 868                 '(=adobe-japan1-6       "AJ1-" 5 d)
 869                 '(=big5-cdp             "CDP-" 4 X)
 870                 '(=>big5-cdp          "A-CDP-" 4 X)
 871                 '(=gb2312               "G0-" 4 X)
 872                 '(=gb12345              "G1-" 4 X)
 873                 '(=jis-x0208@1990       "J90-" 4 X)
 874                 '(=jis-x0212            "JSP-" 4 X)
 875                 '(=cbeta                "CB" 5 d)
 876                 '(=jis-x0208@1997       "J97-" 4 X)
 877                 '(=jis-x0208@1978       "J78-" 4 X)
 878                 '(=jis-x0208@1983       "J83-" 4 X)
 879                 '(=ruimoku-v6           "RUI6-" 4 X)
 880                 '(=zinbun-oracle        "ZOB-" 4 d)
 881                 '(=daijiten             "DJT-" 5 d)
 882                 '(=jef-china3           "JC3-" 4 X)
 883                 '(=ucs@unicode          "UU+" 4 X)
 884                 '(=ucs@JP/hanazono  "hanaJU+" 4 X)
 885                 '(==cns11643-1        "R-C1-" 4 X)
 886                 '(==cns11643-2        "R-C2-" 4 X)
 887                 '(==cns11643-3        "R-C3-" 4 X)
 888                 '(==cns11643-4        "R-C4-" 4 X)
 889                 '(==cns11643-5        "R-C5-" 4 X)
 890                 '(==cns11643-6        "R-C6-" 4 X)
 891                 '(==cns11643-7        "R-C7-" 4 X)
 892                 '(=hanziku-1         "HZK01-" 4 X)
 893                 '(=hanziku-2         "HZK02-" 4 X)
 894                 '(=hanziku-3         "HZK03-" 4 X)
 895                 '(=hanziku-4         "HZK04-" 4 X)
 896                 '(=hanziku-5         "HZK05-" 4 X)
 897                 '(=hanziku-6         "HZK06-" 4 X)
 898                 '(=hanziku-7         "HZK07-" 4 X)
 899                 '(=hanziku-8         "HZK08-" 4 X)
 900                 '(=hanziku-9         "HZK09-" 4 X)
 901                 '(=hanziku-10        "HZK10-" 4 X)
 902                 '(=hanziku-11        "HZK11-" 4 X)
 903                 '(=hanziku-12        "HZK12-" 4 X)
 904                 '(==>daijiten       "A2-DJT-" 5 d)
 905                 '(==cbeta               "CB" 5 d)
 906                 '(=big5                  "B-" 4 X)
 907                 '(=daikanwa              "M-" 5 d)
 908                 coded-charset-entity-reference-alist)))
 909           (encode-coding-region (point-min)(point-max) 'utf-8-mcs-er)
 910
 911           (goto-char (point-min))
 912           (while (re-search-forward "&\\(A-\\|G-\\|g2-\\|R-\\)?CB\\([0-9]+\\);" nil t)
 913             (setq code (string-to-int (match-string 2)))
 914             (replace-match
 915              (format "<img alt=\"CB%05d\" src=\"%s/cb-gaiji/%02d/CB%05d.gif\"
 916 style=\"%s\">"
 917                      code
 918                      chise-wiki-bitmap-glyphs-url
 919                      (/ code 1000) code
 920                      www-format-char-img-style)
 921              t 'literal))
 922
 923           (goto-char (point-min))
 924           (while (re-search-forward "&\\(o-\\|G-\\|g2-\\|R-\\)?J\\(78\\|83\\|90\\|97\\|SP\\)-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
 925             (setq plane (match-string 2)
 926                   code (string-to-int (match-string 3) 16))
 927             (replace-match
 928              (format "<img alt=\"J%s-%04X\" src=\"%s/JIS-%s/%02d-%02d.gif\"
 929 style=\"%s\">"
 930                      plane code
 931                      chise-wiki-bitmap-glyphs-url
 932                      plane
 933                      (- (lsh code -8) 32)
 934                      (- (logand code 255) 32)
 935                      www-format-char-img-style)
 936              t 'literal))
 937
 938           (goto-char (point-min))
 939           (while (re-search-forward "&\\(o-\\|G-\\|g2-\\|R-\\)?J0-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
 940             (setq code (string-to-int (match-string 2) 16))
 941             (replace-match
 942              (format "<img alt=\"J0-%04X\" src=\"%s/JIS-90/%02d-%02d.gif\"
 943 style=\"%s\">"
 944                      code
 945                      chise-wiki-bitmap-glyphs-url
 946                      (- (lsh code -8) 32)
 947                      (- (logand code 255) 32)
 948                      www-format-char-img-style)
 949              t 'literal))
 950
 951           (goto-char (point-min))
 952           (while (re-search-forward "&\\(o-\\|G-\\|g2-\\|R-\\)?HD-\\(JA\\|JB\\|JC\\|JD\\|FT\\|IA\\|IB\\|HG\\)-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
 953             (setq plane (match-string 2)
 954                   code (string-to-int (match-string 3) 16))
 955             (replace-match
 956              (format "<img alt=\"HD-%s-%04X\" src=\"%s/IVD/HanyoDenshi/%s%02d%02d.png\"
 957 style=\"%s\">"
 958                      plane code
 959                      chise-wiki-bitmap-glyphs-url
 960                      plane
 961                      (- (lsh code -8) 32)
 962                      (- (logand code 255) 32)
 963                      www-format-char-img-style)
 964              t 'literal))
 965
 966           (goto-char (point-min))
 967           (while (re-search-forward "&\\(o-\\|G-\\|g2-\\|R-\\)?HD-\\(IP\\|JT\\)-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
 968             (setq plane (match-string 2)
 969                   code (string-to-int (match-string 3) 16))
 970             (replace-match
 971              (format "<img alt=\"HD-%s-%04X\" src=\"%s/IVD/HanyoDenshi/%s%04X.png\"
 972 style=\"%s\">"
 973                      plane code
 974                      chise-wiki-bitmap-glyphs-url
 975                      plane code
 976                      www-format-char-img-style)
 977              t 'literal))
 978
 979           (goto-char (point-min))
 980           (while (re-search-forward "&\\(o-\\|G-\\|g2-\\|R-\\)?HD-KS-\\([0-9]+\\);" nil t)
 981             (setq code (string-to-int (match-string 2)))
 982             (replace-match
 983              (format "<img alt=\"HD-KS%06d\" src=\"%s/IVD/HanyoDenshi/KS%06d.png\"
 984 style=\"vertical-align:middle\">"
 985                      code
 986                      chise-wiki-bitmap-glyphs-url
 987                      code
 988                      www-format-char-img-style)
 989              t 'literal))
 990
 991           (goto-char (point-min))
 992           (while (re-search-forward "&G\\([01]\\)-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
 993             (setq plane (string-to-int (match-string 1))
 994                   code (string-to-int (match-string 2) 16))
 995             (replace-match
 996              (format "<img alt=\"GB%d-%04X\" src=\"%s/GB%d/%02d-%02d.gif\"
 997 style=\"%s\">"
 998                      plane code
 999                      chise-wiki-bitmap-glyphs-url
1000                      plane
1001                      (- (lsh code -8) 32)
1002                      (- (logand code 255) 32)
1003                      www-format-char-img-style)
1004              t 'literal))
1005
1006           (goto-char (point-min))
1007           (while (re-search-forward "&\\(R-\\)?C\\([1-7]\\)-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
1008             (setq plane (string-to-int (match-string 2))
1009                   code (string-to-int (match-string 3) 16))
1010             (replace-match
1011              (format "<img alt=\"CNS%d-%04X\" src=\"%s/CNS%d/%04X.gif\"
1012 style=\"%s\">"
1013                      plane code
1014                      chise-wiki-bitmap-glyphs-url
1015                      plane code
1016                      www-format-char-img-style)
1017              t 'literal))
1018
1019           (goto-char (point-min))
1020           (while (re-search-forward "&\\(R-\\)?JC3-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
1021             (setq code (string-to-int (match-string 2) 16))
1022             (replace-match
1023              (format "<img alt=\"JC3-%04X\" src=\"http://kanji.zinbun.kyoto-u.ac.jp/db/CHINA3/Gaiji/%04x.gif\">"
1024                      code code)
1025              t 'literal))
1026
1027           (goto-char (point-min))
1028           (while (re-search-forward "&\\(A-\\)?ZOB-\\([0-9]+\\);" nil t)
1029             (setq code (string-to-int (match-string 2)))
1030             (replace-match
1031              (format "<img alt=\"ZOB-%04d\" src=\"%s/ZOB-1968/%04d.png\"
1032 style=\"vertical-align:middle\">"
1033                      code
1034                      chise-wiki-bitmap-glyphs-url
1035                      code
1036                      www-format-char-img-style)
1037              t 'literal))
1038
1039           (goto-char (point-min))
1040           (while (re-search-forward "&\\(A2-\\|g2-\\|R-\\)?DJT-\\([0-9]+\\);" nil t)
1041             (setq code (string-to-int (match-string 2)))
1042             (replace-match
1043              (format "<img alt=\"DJT-%05d\" src=\"%s/%05d.png\"
1044 style=\"vertical-align:middle; width: auto; max-height: 60px\">"
1045                      code
1046                      chise-wiki-daijiten-bitmap-glyphs-url
1047                      code
1048                      www-format-char-img-style)
1049              t 'literal))
1050
1051           (goto-char (point-min))
1052           (while (re-search-forward "&SW-JIGUGE\\([45]?\\)-\\([0-9]+\\);" nil t)
1053             (setq subcode (match-string 1)
1054                   code (string-to-int (match-string 2)))
1055             (setq plane
1056                   (if (string= subcode "")
1057                       "5"
1058                     subcode))
1059             (replace-match
1060              (format "<div class=\"tooltip\"><img alt=\"SW-JIGUGE%s-%05d\" src=\"%s/ShuoWen/Jiguge%s/%05d.png\"
1061 style=\"vertical-align:middle; width: auto; max-height: 80px\"><span
1062 class=\"tooltiptext\">%s</span></div>"
1063                      plane code
1064                      chise-wiki-bitmap-glyphs-url
1065                      plane code
1066                      (charset-description
1067                       (if (string= subcode "")
1068                           '=shuowen-jiguge
1069                         (intern (format "===shuowen-jiguge%s" subcode)))))
1070              t 'literal))
1071
1072           (goto-char (point-min))
1073           (while (re-search-forward "&HNG\\([0-9]+\\)-\\([0-9][0-9][0-9][0-9]\\)\\([0-9]\\);" nil t)
1074             (setq plane (match-string 1)
1075                   code (string-to-int (match-string 2))
1076                   subcode (string-to-int (match-string 3)))
1077             (setq subcode
1078                   (if (eq subcode 0)
1079                       ""
1080                     (char-to-string (decode-char 'ascii (+ 96 subcode)))))
1081             (replace-match
1082              (format
1083               "<div class=\"tooltip\"><img alt=\"HNG%s-%04d%s\" src=\"%s/%s/%04d%s.png\" style=\"
1084 vertical-align:middle; width: auto; max-height: 60px\"><span
1085 class=\"tooltiptext\">%s</span></div>"
1086               plane code subcode
1087               chise-wiki-hng-bitmap-glyphs-url
1088               plane code subcode
1089               (charset-description
1090                (car (find (format "HNG%s-" plane)
1091                           coded-charset-entity-reference-alist
1092                           :test (lambda (key cell)
1093                                   (string= key (nth 1 cell))))))
1094               )
1095              t 'literal))
1096
1097           (goto-char (point-min))
1098           (while (re-search-forward "&\\(o-\\|G-\\|g2-\\|R-\\)?AJ1-\\([0-9]+\\);" nil t)
1099             (setq code (string-to-int (match-string 2)))
1100             (replace-match
1101              (format "<img alt=\"AJ1-%05d\" src=\"%s/IVD/AdobeJapan1/CID+%d.png\"
1102 style=\"vertical-align:middle\">"
1103                      code
1104                      chise-wiki-bitmap-glyphs-url
1105                      code
1106                      www-format-char-img-style)
1107              t 'literal))
1108
1109           (goto-char (point-min))
1110           (while (re-search-forward "&\\(A-\\|o-\\|G-\\|g2-\\|R-\\)?MJ\\([0-9]+\\);" nil t)
1111             (setq code (string-to-int (match-string 2)))
1112             (replace-match
1113              (format "<img alt=\"MJ%06d\" src=\"http://mojikiban.ipa.go.jp/MJ%06d.png\"
1114 style=\"vertical-align:middle; width: 48px; height: 48px\">"
1115                      code
1116                      code
1117                      www-format-char-img-style)
1118              t 'literal))
1119
1120           (goto-char (point-min))
1121           (while (re-search-forward "&\\(o-\\|G-\\|g2-\\)?IU[+-]\\([0-9A-F]+\\);" nil t)
1122             (setq code (string-to-int (match-string 2) 16))
1123             (replace-match
1124              (format "<img alt=\"u%04x\" src=\"http://glyphwiki.org/glyph/u%04x.100px.png\"
1125 style=\"vertical-align:middle; width: 48px; height: 48px\">"
1126                      code
1127                      code
1128                      www-format-char-img-style)
1129              t 'literal))
1130
1131           (goto-char (point-min))
1132           (while (re-search-forward "&A-\\(comp\\|cgn\\)U[+-]\\([0-9A-F]+\\);" nil t)
1133             (setq code (string-to-int (match-string 2) 16))
1134             (replace-match
1135              (format "<img alt=\"u%04x\" src=\"http://glyphwiki.org/glyph/u%04x.100px.png\"
1136 style=\"vertical-align:middle; width: 48px; height: 48px\">"
1137                      code
1138                      code
1139                      www-format-char-img-style)
1140              t 'literal))
1141
1142           (goto-char (point-min))
1143           (while (re-search-forward
1144                   "&\\(A-\\|g2-\\)?U-i\\([0-9]+\\)\\+\\([0-9A-F]+\\);"
1145                   nil t)
1146             (setq plane (string-to-int (match-string 2))
1147                   code (string-to-int (match-string 3) 16))
1148             (replace-match
1149              (format "<img alt=\"u%04x-itaiji-%03d\" src=\"http://glyphwiki.org/glyph/u%04x-itaiji-%03d.100px.png\"
1150 style=\"vertical-align:middle; width: 48px; height: 48px\">"
1151                      code
1152                      plane
1153                      code
1154                      plane
1155                      www-format-char-img-style)
1156              t 'literal))
1157
1158           (goto-char (point-min))
1159           (while (re-search-forward "&A-IWDSU\\+\\([0-9A-F]+\\);" nil t)
1160             (setq code (string-to-int (match-string 1) 16))
1161             (replace-match
1162              (format "<img alt=\"A-IWDSU+%04x\" src=\"http://glyphwiki.org/glyph/u%04x.100px.png\"
1163 style=\"vertical-align:middle; width: 48px; height: 48px\">"
1164                      code
1165                      code
1166                      www-format-char-img-style)
1167              t 'literal))
1168
1169           (goto-char (point-min))
1170           (while (re-search-forward
1171                   "&\\(A-\\)?CDP-i\\([0-9]+\\)-\\([0-9A-F]+\\);"
1172                   nil t)
1173             (setq plane (string-to-int (match-string 2))
1174                   code (string-to-int (match-string 3) 16))
1175             (replace-match
1176              (format "<img alt=\"cdp-%04x-itaiji-%03d\" src=\"http://glyphwiki.org/glyph/cdp-%04x-itaiji-%03d.100px.png\"
1177 style=\"vertical-align:middle; width: 48px; height: 48px\">"
1178                      code
1179                      plane
1180                      code
1181                      plane
1182                      www-format-char-img-style)
1183              t 'literal))
1184
1185           (goto-char (point-min))
1186           (while (re-search-forward "&\\(g2-\\)?U-v\\([0-9]+\\)\\+\\([0-9A-F]+\\);" nil t)
1187             (setq plane (string-to-int (match-string 2))
1188                   code (string-to-int (match-string 3) 16))
1189             (replace-match
1190              (format "<img alt=\"u%04x-var-%03d\" src=\"http://glyphwiki.org/glyph/u%04x-var-%03d.100px.png\"
1191 style=\"vertical-align:middle; width: 48px; height: 48px\">"
1192                      code
1193                      plane
1194                      code
1195                      plane
1196                      www-format-char-img-style)
1197              t 'literal))
1198
1199           (goto-char (point-min))
1200           (while (re-search-forward "&\\(A-\\|G-\\|R-\\|g2-\\)?GT-\\([0-9]+\\);" nil t)
1201             (setq code (string-to-int (match-string 2)))
1202             (replace-match
1203              (format "<img alt=\"GT-%05d\" src=\"%s?char=GT-%05d\"
1204 style=\"%s\">"
1205                      code
1206                      chise-wiki-glyph-cgi-url
1207                      code
1208                      www-format-char-img-style)
1209              t 'literal))
1210
1211           (goto-char (point-min))
1212           (while (re-search-forward "&\\(A-\\|G-\\|g2-\\)?GT-K\\([0-9]+\\);" nil t)
1213             (setq code (string-to-int (match-string 2)))
1214             (replace-match
1215              (format "<img alt=\"GT-K%05d\" src=\"%s?char=GT-K%05d\"
1216 style=\"%s\">"
1217                      code
1218                      chise-wiki-glyph-cgi-url
1219                      code
1220                      www-format-char-img-style)
1221              t 'literal))
1222
1223           (goto-char (point-min))
1224           (while (re-search-forward "&B-\\([0-9A-F]+\\);" nil t)
1225             (setq code (string-to-int (match-string 1) 16))
1226             (replace-match
1227              (format "<img alt=\"B-%04X\" src=\"%s?char=B-%04X\"
1228 style=\"%s\">"
1229                      code
1230                      chise-wiki-glyph-cgi-url
1231                      code
1232                      www-format-char-img-style)
1233              t 'literal))
1234
1235           (goto-char (point-min))
1236           (while (re-search-forward
1237                   "&\\(A-\\|G-\\|g2-\\|R-\\)?CDP-\\([0-9A-F]+\\);" nil t)
1238             (setq code (string-to-int (match-string 2) 16))
1239             (replace-match
1240              (format "<img alt=\"CDP-%04X\" src=\"%s?char=CDP-%04X\"
1241 style=\"%s\">"
1242                      code
1243                      chise-wiki-glyph-cgi-url
1244                      code
1245                      www-format-char-img-style)
1246              t 'literal))
1247
1248           (goto-char (point-min))
1249           (while (re-search-forward
1250                   "&\\(I-\\)?HZK\\(0[1-9]\\|1[0-2]\\)-\\([0-9A-F]+\\);" nil t)
1251             (setq plane (match-string 2)
1252                   code (string-to-int (match-string 3) 16))
1253             (replace-match
1254              (format "<img alt=\"HZK%s-%04X\" src=\"%s?char=HZK%s-%04X\"
1255 style=\"%s\">"
1256                      plane
1257                      code
1258                      chise-wiki-glyph-cgi-url
1259                      plane
1260                      code
1261                      www-format-char-img-style)
1262              t 'literal))
1263
1264           (goto-char (point-min))
1265           (while (re-search-forward "&\\(A-\\|G-\\|g2-\\|R-\\)?RUI6-\\([0-9A-F]+\\);" nil t)
1266             (setq code (string-to-int (match-string 2) 16))
1267             (replace-match
1268              (format "<img alt=\"RUI6-%04X\" src=\"%s?char=RUI6-%04X\"
1269 style=\"vertical-align:middle\">"
1270                      code
1271                      chise-wiki-glyph-cgi-url
1272                      code
1273                      www-format-char-img-style)
1274              t 'literal))
1275
1276           (goto-char (point-min))
1277           (while (re-search-forward "&hanaJU\\+\\([0-9A-F]+\\);" nil t)
1278             (setq code (string-to-int (match-string 1) 16))
1279             (replace-match
1280              (format "<img alt=\"hanaJU+%04X\" src=\"%s?char=hana-JU+%04X\"
1281 style=\"vertical-align:middle\">"
1282                      code
1283                      chise-wiki-glyph-cgi-url
1284                      code
1285                      www-format-char-img-style)
1286              t 'literal))
1287
1288           (goto-char (point-min))
1289           (while (re-search-forward "&\\(A-\\|G-\\|g2-\\|R-\\)?\\(UU\\+\\|U-\\)\\([0-9A-F]+\\);" nil t)
1290             (setq code (string-to-int (match-string 3) 16))
1291             (replace-match
1292              (format "<img alt=\"UU+%04X\" src=\"http://www.unicode.org/cgi-bin/refglyph?24-%04X\"
1293 style=\"vertical-align:middle\">"
1294                      code
1295                      code
1296                      www-format-char-img-style)
1297              t 'literal))
1298
1299           (goto-char (point-min))
1300           (while (re-search-forward "&MCS-\\([0-9A-F]+\\);" nil t)
1301             (setq code (string-to-int (match-string 1) 16))
1302             (setq start (match-beginning 0)
1303                   end (match-end 0))
1304             (setq char (decode-char 'system-char-id code))
1305             (cond
1306              ((and (setq variants
1307                          (or (www-get-feature-value char '->subsumptive)
1308                              (www-get-feature-value char '->denotational)))
1309                    (progn
1310                      (if (characterp variants)
1311                          (setq variants (list variants)))
1312                      (while (and variants
1313                                  (setq ret (www-format-encode-string
1314                                             (char-to-string (car variants))))
1315                                  (string-match "&MCS-\\([0-9A-F]+\\);" ret))
1316                        (setq variants (cdr variants)))
1317                      ret))
1318               (unless (string-match "&MCS-\\([0-9A-F]+\\);" ret)
1319                 (goto-char start)
1320                 (delete-region start end)
1321                 (insert ret))
1322               )
1323              ((setq ret (or (www-get-feature-value char 'ideographic-combination)
1324                             (www-get-feature-value char 'ideographic-structure)))
1325               (setq ret
1326                     (mapconcat
1327                      (lambda (ch)
1328                        (if (listp ch)
1329                            (if (characterp (setq rret (find-char ch)))
1330                                (setq ch rret)))
1331                        (if (characterp ch)
1332                            (www-format-encode-string
1333                             (char-to-string ch) without-tags)
1334                          (www-format-encode-string
1335                           (format "%S" ch) without-tags)))
1336                      ret ""))
1337               (when ret
1338                 (goto-char start)
1339                 (delete-region start end)
1340                 (insert ret))
1341               )))
1342           ))
1343       ;; (goto-char (point-min))
1344       ;; (while (search-forward "&GT-" nil t)
1345       ;;   (replace-match "&amp;GT-" t 'literal))
1346       (buffer-string))))
1347
1348 (defun www-html-display-text (text)
1349   (princ
1350    (with-temp-buffer
1351      (insert text)
1352      (goto-char (point-min))
1353      (while (search-forward "<" nil t)
1354        (replace-match "&lt;" nil t))
1355      (goto-char (point-min))
1356      (while (search-forward ">" nil t)
1357        (replace-match "&gt;" nil t))
1358      (goto-char (point-min))
1359      (while (re-search-forward "\\[\\[\\([^]|[]+\\)|\\([^][]+\\)\\]\\]" nil t)
1360        (replace-match
1361         (format "<a href=\"%s\">%s</a>"
1362                 (match-string 2)
1363                 (match-string 1))
1364         nil t))
1365      (encode-coding-region (point-min)(point-max) 'utf-8-mcs-er)
1366      (goto-char (point-min))
1367      (while (search-forward "&GT-" nil t)
1368        (replace-match "&amp;GT-" nil t))
1369      (buffer-string))))
1370
1371 (defun www-html-display-paragraph (text)
1372   (princ "<p>")
1373   (www-html-display-text text)
1374   (princ "</p>\n"))
1375
1376
1377 ;;; @ for GlyphWiki
1378 ;;;
1379
1380 (defvar coded-charset-GlyphWiki-id-alist
1381   '((===adobe-japan1-0  "aj1-"  5 d nil)
1382     (===adobe-japan1-1  "aj1-"  5 d nil)
1383     (===adobe-japan1-2  "aj1-"  5 d nil)
1384     (===adobe-japan1-3  "aj1-"  5 d nil)
1385     (===adobe-japan1-4  "aj1-"  5 d nil)
1386     (===adobe-japan1-5  "aj1-"  5 d nil)
1387     (===adobe-japan1-6  "aj1-"  5 d nil)
1388     (===ucs@jis         "u"     4 x nil)
1389     (===daikanwa        "dkw-"  5 d nil)
1390     (===ucs@ks          "u"     4 x "-k")
1391     (==ucs-itaiji-005   "u"     4 x "-itaiji-005")
1392     (=ucs-var-001       "u"     4 x "-var-001")
1393     (=ucs-var-002       "u"     4 x "-var-002")
1394     (=ucs-var-003       "u"     4 x "-var-003")
1395     (=ucs-var-004       "u"     4 x "-var-004")
1396     (=ucs-itaiji-001    "u"     4 x "-itaiji-001")
1397     (=ucs-itaiji-002    "u"     4 x "-itaiji-002")
1398     (=ucs-itaiji-003    "u"     4 x "-itaiji-003")
1399     (=ucs-itaiji-084    "u"     4 x "-itaiji-084")
1400     (=>ucs-itaiji-001   "u"     4 x "-itaiji-001")
1401     (=>ucs-itaiji-006   "u"     4 x "-itaiji-006")
1402     (==adobe-japan1-0   "aj1-"  5 d nil)
1403     (==adobe-japan1-1   "aj1-"  5 d nil)
1404     (==adobe-japan1-2   "aj1-"  5 d nil)
1405     (==adobe-japan1-3   "aj1-"  5 d nil)
1406     (==adobe-japan1-4   "aj1-"  5 d nil)
1407     (==adobe-japan1-5   "aj1-"  5 d nil)
1408     (==adobe-japan1-6   "aj1-"  5 d nil)
1409     (==ucs@jis          "u"     4 x nil)
1410     (==ucs@iso          "u"     4 x nil)
1411     (==ucs@cns          "u"     4 x "-t")
1412     (==ucs@unicode      "u"     4 x "-us")
1413     (==daikanwa         "dkw-"  5 d nil)
1414     (==ucs@ks           "u"     4 x "-k")
1415     (==jis-x0208@1978   "j78-"  4 x nil)
1416     (==jis-x0208        "j90-"  4 x nil)
1417     (==jis-x0208@1990   "j90-"  4 x nil)
1418     (==jis-x0208@1983   "j83-"  4 x nil)
1419     (==cbeta           "cbeta-" 5 d nil)
1420     (=>>hanyo-denshi/ks "koseki-" 6 d nil)
1421     (=>>jis-x0208@1978  "j78-"  4 x nil)
1422     (=>>big5-cdp        "cdp-"  4 x nil)
1423     (=>>adobe-japan1-0  "aj1-"  5 d nil)
1424     (=>>adobe-japan1-1  "aj1-"  5 d nil)
1425     (=>>adobe-japan1-2  "aj1-"  5 d nil)
1426     (=>>adobe-japan1-3  "aj1-"  5 d nil)
1427     (=>>adobe-japan1-4  "aj1-"  5 d nil)
1428     (=>>adobe-japan1-5  "aj1-"  5 d nil)
1429     (=>>adobe-japan1-6  "aj1-"  5 d nil)
1430     (=>>jis-x0208       "j90-"  4 x nil)
1431     (=>>jis-x0208@1990  "j90-"  4 x nil)
1432     (=>>jis-x0208@1983  "j83-"  4 x nil)
1433     (=>>daikanwa        "dkw-"  5 d nil)
1434     (=adobe-japan1-0    "aj1-"  5 d nil)
1435     (=adobe-japan1-1    "aj1-"  5 d nil)
1436     (=adobe-japan1-2    "aj1-"  5 d nil)
1437     (=adobe-japan1-3    "aj1-"  5 d nil)
1438     (=adobe-japan1-4    "aj1-"  5 d nil)
1439     (=adobe-japan1-5    "aj1-"  5 d nil)
1440     (=adobe-japan1-6    "aj1-"  5 d nil)
1441     (=decomposition@cid)
1442     (=decomposition@hanyo-denshi)
1443     (=hanyo-denshi/ks   "koseki-" 6 d nil)
1444     (=koseki            "koseki-" 6 d nil)
1445     (=ucs@jis           "u"     4 x nil)
1446     (=ucs@cns           "u"     4 x "-t")
1447     (=ucs@ks            "u"     4 x "-k")
1448     (=ucs@JP            "u"     4 x nil)
1449     (=ucs@gb            "u"     4 x "-g")
1450     (=ucs@iso           "u"     4 x "-u")
1451     (=ucs@unicode       "u"     4 x "-us")
1452     (=big5-cdp          "cdp-"  4 x nil)
1453     (=>big5-cdp         "cdp-"  4 x nil)
1454     (=cbeta            "cbeta-" 5 d nil)
1455     (=big5-cdp-var-3    "cdp-"  4 x "-var-3")
1456     (=big5-cdp-var-5    "cdp-"  4 x "-var-5")
1457     (=big5-cdp-itaiji-001 "cdp-" 4 x "-itaiji-001")
1458     (=big5-cdp-itaiji-002 "cdp-" 4 x "-itaiji-002")
1459     (=>big5-cdp-itaiji-001 "cdp-" 4 x "-itaiji-001")
1460     (=jef-china3        "jc3-"  4 x nil)
1461     (=jis-x0212         "jsp-"  4 x nil)
1462     (=jis-x0213-1@2000  "jx1-2000-" 4 x nil)
1463     (=jis-x0213-1@2004  "jx1-2004-" 4 x nil)
1464     (=jis-x0213-2       "jx2-"  4 x nil)
1465     (=gt-k              "gt-k"  5 d nil)
1466     (=jis-x0208@1978/1pr "j78-" 4 x nil)
1467     (=jis-x0208@1978/-4pr "j78-" 4 x nil)
1468     (=jis-x0208@1978    "j78-"  4 x nil)
1469     (=+>jis-x0208@1978  "j78-"  4 x nil)
1470     (=+>jis-x0208       "j90-"  4 x nil)
1471     (=+>jis-x0208@1990  "j90-"  4 x nil)
1472     (=+>jis-x0208@1983  "j83-"  4 x nil)
1473     (=ucs               "u"     4 x nil)
1474     (=big5              "b-"    4 x nil)
1475     (=daikanwa          "dkw-"  5 d nil)
1476     (=gt                "gt-"   5 d nil)
1477     (=ruimoku-v6        "rui6-" 4 x nil)
1478     (=>ruimoku-v6       "rui6-" 4 x nil)
1479     (=ks-x1001          "k0-"   4 x nil)
1480     (=cns11643-1        "c1-"   4 x nil)
1481     (=cns11643-2        "c2-"   4 x nil)
1482     (=cns11643-3        "c3-"   4 x nil)
1483     (=cns11643-4        "c4-"   4 x nil)
1484     (=cns11643-5        "c5-"   4 x nil)
1485     (=cns11643-6        "c6-"   4 x nil)
1486     (=cns11643-7        "c7-"   4 x nil)
1487     (=jis-x0208         "j90-"  4 x nil)
1488     (=jis-x0208@1990    "j90-"  4 x nil)
1489     (=jis-x0208@1983    "j83-"  4 x nil)
1490     ))
1491
1492 (defun char-GlyphWiki-id (char)
1493   (let ((rest coded-charset-GlyphWiki-id-alist)
1494         spec ret code)
1495     (while (and rest
1496                 (setq spec (pop rest))
1497                 (null (setq ret (get-char-attribute char (car spec))))))
1498     (when ret
1499       (or
1500        (and (listp ret)
1501             (mapconcat #'char-GlyphWiki-id ret "-"))
1502        (and (memq (car spec) '(=ucs@unicode '=ucs@iso))
1503             (cond
1504              ((and (or (encode-char char '=jis-x0208@1990)
1505                        (encode-char char '=jis-x0212)
1506                        (encode-char char '=jis-x0213-1)
1507                        (encode-char char '=jis-x0213-2))
1508                    (setq code (encode-char char '=ucs@jis)))
1509               (format "u%04x" code)
1510               )
1511              ((and (or (encode-char char '=gb2312)
1512                        (encode-char char '=gb12345))
1513                    (setq code (encode-char char '=ucs@gb)))
1514               (format "u%04x-g" code)
1515               )
1516              ((and (or (encode-char char '=cns11643-1)
1517                        (encode-char char '=cns11643-2)
1518                        (encode-char char '=cns11643-3)
1519                        (encode-char char '=cns11643-4)
1520                        (encode-char char '=cns11643-5)
1521                        (encode-char char '=cns11643-6)
1522                        (encode-char char '=cns11643-7))
1523                    (setq code (encode-char char '=ucs@cns)))
1524               (format "u%04x-t" code)
1525               )
1526              ((and (encode-char char '=ks-x1001)
1527                    (setq code (encode-char char '=ucs@ks)))
1528               (format "u%04x-k" code)
1529               )))
1530        (format (format "%s%%0%d%s%s"
1531                        (nth 1 spec)
1532                        (nth 2 spec)
1533                        (nth 3 spec)
1534                        (or (nth 4 spec) ""))
1535                ret)))))
1536
1537
1538 ;;; @ End.
1539 ;;;
1540
1541 (provide 'cwiki-common)
1542
1543 ;;; cwiki-common.el ends here