cwiki-common.el

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