Source

xwem / lisp / xwem-misc.el

Full commit
  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
;;; xwem-misc.el --- Misc stuff for XWEM.

;; Copyright (C) 2003 by Free Software Foundation, Inc.

;; Author: Zajcev Evgeny <zevlg@yandex.ru>
;; Created: 21 Mar 2003
;; Keywords: xlib, xwem
;; X-CVS: $Id$

;; This file is part of XWEM.

;; XWEM is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; XWEM is distributed in the hope that it will be useful, but WITHOUT
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public
;; License for more details.

;; You should have received a copy of the GNU General Public License
;; along with XEmacs; see the file COPYING.  If not, write to the Free
;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
;; 02111-1307, USA.

;;; Synched up with: Not in FSF

;;; Commentary:
;;
;; This file used for misc purposes.
;;
;; If you have troubles with C-g key in Emacs, try to eval:
;;
;;    (set-input-mode nil nil nil ?\xff)
;;
;; I dont know where is bug, but sometimes my XEmacs behaves very
;; strange.  Especially after M-x C-h k.

;;; Code:
;;

(require 'xlib-xwin)

(eval-and-compile
  (defvar elp-function-list nil)        ; shut up compiler
  (autoload 'elp-instrument-list "elp" nil t)
  (autoload 'elp-results "elp" nil t)
  
  (autoload 'calc-eval "calc"))

(define-error 'xwem-internal-error
  "Internal XWEM error.")

(defgroup xwem-misc nil
  "Group to customize miscellaneous options."
  :prefix "xwem-misc-"
  :group 'xwem)

(defcustom xwem-messages-buffer-name " *xwem-messages*"
  "*Buffer name for xwem messages."
  :type 'string
  :group 'xwem)

(defcustom xwem-messages-buffer-lines 1000
  "*Maximum lines in xwem messages buffer."
  :type 'number
  :group 'xwem)

(defcustom xwem-misc-functions-to-profile
  '(X-Create-message
    X-Dpy-parse-message
    string->int
    string4->int
    X-Dpy-grab-bytes
    X-Dpy-filter
    X-Dpy-parse-message-guess
    accept-process-output
    X-Text-width
    X-Text-height
    XImagePut)
  "List of functions to profile using xwem profiler."
  :type '(repeat function)
  :group 'xwem-misc)

;;; Cursors
(defgroup xwem-cursor nil
  "Group to customize cursors in XWEM."
  :prefix "xwem-cursor-"
  :group 'xwem)

;; Default cursor
(defcustom xwem-cursor-default-shape 'X-XC-left_ptr
  "*Shape of default xwem cursor."
  :type (xwem-cursor-shape-choice)
  :group 'xwem-cursor)

(defcustom xwem-cursor-default-foreground-color "#002800"
  "*Default cursor's foreground color."
  :type '(restricted-sexp :match-alternatives ('nil xwem-misc-colorspec-valid-p))
  :group 'xwem-cursor)

(defcustom xwem-cursor-default-background-color "#000000"
  "*Default cursor's background color."
  :type '(restricted-sexp :match-alternatives ('nil xwem-misc-colorspec-valid-p))
  :group 'xwem-cursor)

;; wait cursor
(defcustom xwem-cursor-wait-shape 'X-XC-icon
  "*Shape of cursor, when XWEM wait for something."
  :type (xwem-cursor-shape-choice)
  :group 'xwem-cursor)

(defcustom xwem-cursor-wait-foreground-color "#ea0000"
  "*Cursor's foreground color when XWEM wait for something."
  :type '(restricted-sexp :match-alternatives ('nil xwem-misc-colorspec-valid-p))
  :group 'xwem-cursor)

(defcustom xwem-cursor-wait-background-color nil;"#280000"
  "*Cursor's background color when XWEM waiit for something."
  :type '(restricted-sexp :match-alternatives ('nil xwem-misc-colorspec-valid-p))
  :group 'xwem-cursor)

;; move cursor
(defcustom xwem-cursor-move-shape 'X-XC-fleur
  "*Shape of cursor, when moving something."
  :type (xwem-cursor-shape-choice)
  :group 'xwem-cursor)

(defcustom xwem-cursor-move-foreground-color "#777777"
  "*Cursor's foreground color when moving something."
  :type '(restricted-sexp :match-alternatives ('nil xwem-misc-colorspec-valid-p))
  :group 'xwem-cursor)

(defcustom xwem-cursor-move-background-color nil;"#280000"
  "*Cursor's background color when moving something."
  :type '(restricted-sexp :match-alternatives ('nil xwem-misc-colorspec-valid-p))
  :group 'xwem-cursor)

;; quote cursor
(defcustom xwem-cursor-quote-shape 'X-XC-sb_down_arrow
  "*Shape of cursor, when XWEM quoting keyboard or mouse."
  :type (xwem-cursor-shape-choice)
  :group 'xwem-cursor)

(defcustom xwem-cursor-quote-foreground-color "#0000BB"
  "*Cursor's foreground color when XWEM quoting keyboard/mouse."
  :type '(restricted-sexp :match-alternatives ('nil xwem-misc-colorspec-valid-p))
  :group 'xwem-cursor)

(defcustom xwem-cursor-quote-background-color "#000099"
  "*Cursor's background color when XWEM quoting keyboard/mouse."
  :type '(restricted-sexp :match-alternatives ('nil xwem-misc-colorspec-valid-p))
  :group 'xwem-cursor)

;; help cursor
(defcustom xwem-cursor-help-shape 'X-XC-question_arrow
  "*Shape of cursor, when getting help with XWEM."
  :type (xwem-cursor-shape-choice)
  :group 'xwem-cursor)

(defcustom xwem-cursor-help-foreground-color "#00BB00"
  "*Cursor's foreground color when quering XWEM for help."
  :type '(restricted-sexp :match-alternatives ('nil xwem-misc-colorspec-valid-p))
  :group 'xwem-cursor)

(defcustom xwem-cursor-help-background-color "#009900"
  "*Cursor's background color when quering XWEM for help."
  :type '(restricted-sexp :match-alternatives ('nil xwem-misc-colorspec-valid-p))
  :group 'xwem-cursor)

;; cursor storages
;;;###autoload
(defvar xwem-cursor-fnt nil "Font for \"cursor\" series.")

;;;###autoload
(defvar xwem-cursor-default nil "Default cursor.")
;;;###autoload
(defvar xwem-cursor-left nil "Left cursor.")
;;;###autoload
(defvar xwem-cursor-right nil "Right cursor.")
;;;###autoload
(defvar xwem-cursor-wait nil "Cursor when we are wait.")
;;;###autoload
(defvar xwem-cursor-drag nil "Cursor when we drag.  Drug is a bad idea.")
;;;###autoload
(defvar xwem-cursor-move nil "Cursor when we move something.")
;;;###autoload
(defvar xwem-cursor-resize nil "Cursor when we resize.")
;;;###autoload
(defvar xwem-cursor-quote nil "Cursor when quoting key.")
;;;###autoload
(defvar xwem-cursor-help nil "Cursor when in help mode.")

;;; Functions
(defsubst xwem-misc-colorspec->rgb-vector (colspec)
  "Conver color specification COLSPEC to internal representation.
COLSPEC maybe in form: #RRGGBB or name like 'green4'."
  (vconcat (color-instance-rgb-components (make-color-instance colspec))))

(defsubst xwem-misc-colorspec->rgb-vector-safe (colspec &optional defret)
  "Validate COLSPEC to be color specification in safe manner.
Return DEFRET or [0 0 0] if there was error."
  (condition-case nil
      (xwem-misc-colorspec->rgb-vector colspec)
    (t (or defret [0 0 0]))))

(defsubst xwem-misc-colorspec-valid-p (colspec)
  "Return non-nil if COLSPEC is valid color specification.
Valid colorspecification is spec in form: #RRGGBB or name like 'green4'."
  (condition-case nil
      (xwem-misc-colorspec->rgb-vector colspec)
    (t nil)))

;;;###autoload
(defun xwem-make-cursor (type &optional fgcol bgcol)
  "Make new cursor of TYPE and store it in WHERE-STORE.
BGCOL maybe nil, that mean masking will not be done."
  (let ((fgc (xwem-misc-colorspec->rgb-vector-safe fgcol [0 0 0]))
        (bgc (xwem-misc-colorspec->rgb-vector-safe bgcol 'invalid-bgcol))
        cursor)
    (setq cursor (make-X-Cursor :dpy (xwem-dpy) :id (X-Dpy-get-id (xwem-dpy))
                                :source xwem-cursor-fnt
                                :mask xwem-cursor-fnt
                                :src-char type
                                :msk-char (+ (if (eq bgc 'invalid-bgcol) 0 1) type)
                                :fgred (aref fgc 0)
                                :fggreen (aref fgc 1)
                                :fgblue (aref fgc 2)))
    (unless (eq bgc 'invalid-bgcol)
      (setf (X-Cursor-bgred cursor) (aref bgc 0))
      (setf (X-Cursor-bggreen cursor) (aref bgc 1))
      (setf (X-Cursor-bgblue cursor) (aref bgc 2)))

    (XCreateGlyphCursor (xwem-dpy) cursor)
    cursor))

;;;###autoload
(defun xwem-init-cursors ()
  "Initialize cursors."
  ;; Make cursors
  (xwem-message 'msg "Initializing cursors ... wait")

  (setq xwem-cursor-fnt (make-X-Font :dpy (xwem-dpy) :id (X-Dpy-get-id (xwem-dpy))
                                     :name "cursor"))
  (XOpenFont (xwem-dpy) xwem-cursor-fnt)

  (setq xwem-cursor-default (xwem-make-cursor (eval xwem-cursor-default-shape)
                                              xwem-cursor-default-foreground-color
                                              xwem-cursor-default-background-color)

        xwem-cursor-left (xwem-make-cursor X-XC-left_ptr
                                           xwem-cursor-default-foreground-color
                                           xwem-cursor-default-background-color)

        xwem-cursor-right (xwem-make-cursor X-XC-right_ptr
                                            xwem-cursor-default-foreground-color
                                            xwem-cursor-default-background-color)

        xwem-cursor-wait (xwem-make-cursor (eval xwem-cursor-wait-shape)
                                           xwem-cursor-wait-foreground-color
                                           xwem-cursor-wait-background-color)

        xwem-cursor-move (xwem-make-cursor (eval xwem-cursor-move-shape)
                                           xwem-cursor-move-foreground-color
                                           xwem-cursor-move-background-color)

        xwem-cursor-quote (xwem-make-cursor (eval xwem-cursor-quote-shape)
                                            xwem-cursor-quote-foreground-color
                                            xwem-cursor-quote-background-color)

        xwem-cursor-help (xwem-make-cursor (eval xwem-cursor-help-shape)
                                           xwem-cursor-help-foreground-color
                                           xwem-cursor-help-background-color))
  ;; TODO: add other cursors
  )

;;; Misc drawing
;;;###autoload
(defun xwem-misc-draw-shadow (dpy win gc1 gc2 x y w h thick)
  "Draw shadow."
  (let ((offset 0)
        s1 s2)
    (if (or (> (* thick 2) h) (> (* thick 2) w))
        nil                             ; undrawable
      (while (not (= thick offset))
        (setq s1 (cons (cons (make-X-Point :xx (+ x offset) :yy (+ y offset))
                             (make-X-Point :xx (+ x offset) :yy (- (+ y h) offset 1)))
                       s1))
        (setq s1 (cons (cons (make-X-Point :xx (+ x offset) :yy (+ y offset))
                             (make-X-Point :xx (- (+ x w) offset 1) :yy (+ y offset)))
                       s1))

        (setq s2 (cons (cons (make-X-Point :xx (+ x offset) :yy (- (+ y h) offset 1))
                             (make-X-Point :xx (- (+ x w) offset 1) :yy (- (+ y h) offset 1)))
                       s2))
        (setq s2 (cons (cons (make-X-Point :xx (- (+ x w) offset 1) :yy (+ y offset 1))
                             (make-X-Point :xx (- (+ x w) offset 1) :yy (- (+ y h) offset 1)))
                       s2))

        (setq offset (+ offset 1)))

      (when s1
        (XDrawSegments dpy win gc1 s1))
      (when s2
        (XDrawSegments dpy win gc2 s2))
      )))

;;;###autoload
(defun xwem-misc-draw-bar (dpy win gc1 gc2 gc3 x y w h th)
  "Draw shadowed bar.
Bar filled with GC1.
Shadow thickness is TH and it is drawed with GC2 and GC3."
  (X-Dpy-log dpy "xwem-misc-draw .. x=%d y=%d w=%d h=%d\n" 'x 'y 'w 'h)

  (xwem-misc-draw-shadow dpy win gc2 gc3 x y w h th)
  (XFillRectangle dpy win gc1 (+ x th) (+ y th) (- w (* th 2)) (- h (* th 2)))
  )

;;;###autoload
(defun xwem-misc-find-frame (name)
  "Find Emacs frame by its NAME."
  (let ((fl (frame-list))
        (rf nil))

    (while fl
      (when (string= (frame-name (car fl)) xwem-minibuffer-name)
        ;; Found
        (setq rf (car fl))
        (setq fl nil))
      (setq fl (cdr fl)))
    rf))

;; Some hooks
(eval-when-compile
  (autoload 'X-Event-seq "xlib-xr"))

;;;###autoload
(defun xwem-misc-xwin-valid-p (xwin)
  "Return non-nil if XWIN is valid X window.
Do it in safe manner."
  (let (attrs)
    (X-Dpy-put-property (X-Win-dpy xwin) 'xwem-ignore-bad-win t)
    (unwind-protect
        (setq attrs (XGetWindowAttributes (X-Win-dpy xwin) xwin))
      (X-Dpy-put-property (X-Win-dpy xwin) 'xwem-ignore-bad-win nil))
    attrs))

;;;###autoload
(defun xwem-misc-xerr-hook (xdpy xev)
  "Display X errors in `xwem-minibuffer'.
Error hook must not performe any interaction with X server!
XDPY - X-Dpy.
XEV  - X-Event of error type."
  (let* ((err (X-Event-xerror-code xev))
         (badth (X-Event-xerror-resourceid xev))
         (seq (X-Event-seq xev))
         (maj (X-Event-xerror-maj-op xev))
         (min (X-Event-xerror-min-op xev))
         (bstr (cond ((= err 1) "Request")
                     ((= err 2) "Value")
                     ((= err 3) "Window")
                     ((= err 4) "Pixmap")
                     ((= err 5) "Atom")
                     ((= err 6) "Cursor")
                     ((= err 7) "Font")
                     ((= err 8) "Match")
                     ((= err 9) "Drawable")
                     ((= err 10) "Access")
                     ((= err 11) "Alloc")
                     ((= err 12) "Color")
                     ((= err 13) "GC")
                     ((= err 14) "IDChoice")
                     ((= err 15) "Name")
                     ((= err 16) "Length")
                     ((= err 17) "Implementation")
                     ((= err 128) "FirstExtension")
                     ((= err 255) "LastExtension")
                     (t "Unknown"))))
    (unless (and (X-Dpy-get-property xdpy 'xwem-ignore-bad-win)
                 (eq err 3))
      (xwem-message 'err "X error - Bad %s %f seq=%f:%d ops=%d:%d"
                    bstr badth seq (X-Dpy-rseq-id (xwem-dpy)) maj min)
    )))

;;;###autoload
(defun xwem-init-misc ()
  "Some misc initializetions."
  (pushnew 'xwem-misc-xerr-hook (X-Dpy-error-hooks (xwem-dpy)))
  )

;;; Stuff for debugging
(defun xwem-misc-str2hexstr (str)
  "Convert STR to hexidecimal string representation."
  (substring (mapconcat (lambda (el) (format "%x " el)) str "") 0 -1))

;;; Messaging

;;;###autoload
(defun xwem-str-with-faces (str face-list)
  "Return STR with applied FACE-LIST."
  (let ((ext (make-extent 0 (length str) str)))

    (set-extent-property ext 'duplicable t)
    (set-extent-property ext 'unique t)
    (set-extent-property ext 'start-open t)
    (set-extent-property ext 'end-open t)
    (set-extent-property ext 'face face-list))
  str)

(defun xwem-format-faces (fmt def-face &rest args)
  "Accepts format FMT and ARGS in form `((arg . face) ...)'.
DEF-FACE is default face. Returns string with faces."
  (let ((flst (string-to-list fmt))
        (chr nil)
        (rstr ""))
    (while flst
      (setq chr (car flst))
      (cond ((= chr ?%)
             (setq flst (cdr flst))
             (setq chr (car flst))
             (let ((arg (if (consp (car args)) (caar args) (car args)))
                   (fcs (if (consp (car args)) (cdr (car args)) nil)))
               (cond ((= chr ?s)
                      (setq rstr (concat
                                  rstr
                                  (xwem-str-with-faces
                                   arg
                                   (if fcs (list fcs def-face) (list def-face)))))
                    (setq args (cdr args)))

                   ((= chr ?d)
                    (setq rstr (concat
                                rstr
                                (xwem-str-with-faces
                                 (int-to-string arg)
                                 (if fcs (list fcs def-face) (list def-face)))))
                    (setq args (cdr args)))
                    (t nil))))
            (t
             (setq rstr (concat
                         rstr
                         (xwem-str-with-faces (char-to-string chr) (list def-face))))))
      (setq flst (cdr flst)))

    rstr))

(defun xwem-message-insert (message)
  "Insert MESSAGE in `xwem-messages-buffer-name' buffer."
  (with-current-buffer (get-buffer-create xwem-messages-buffer-name)
    (let ((inhibit-read-only t))
      ;; Remove all messages from buffer if it exided maximum value
      (when (> (count-lines-buffer) xwem-messages-buffer-lines)
        (delete-region (point-min) (point-max)))

      (goto-char (point-max))
      (insert (format-time-string "%D %T: "))
      (insert message)
      (insert "\n"))))

;;;###autoload
(defun xwem-message (type fmt &rest args)
  "Display xwem message of TYPE using FMT format.
Type is:
'note -- For some xwem notes.
'warn -- For xwem warnings (beeps).
'warn-nobeep -- For xwem warnings (does not beeps).
'err  -- For xwem warnings (beeps).
'err-nobeep  -- For xwem warnings (does not beeps).
'todo -- Things that xwem should have.
'msg  -- Informatical message.
'prompt -- XWEM's input prompt.
'asis -- Such type is not passed through `format', ARGS should be nil,
         used to message colorized text.

ARGS are passed to `format' with FMT to generate final message."
  (if (eq type 'asis)
      (display-message 'message fmt)
    (let ((str
           (cond ((eq type 'note) "-Note:")
                 ((eq type 'warn)
                  (concat "-" (xwem-str-with-faces "Warning:" (list 'red))))
                 ((eq type 'warn-nobeep)
                  (concat "-" (xwem-str-with-faces "Warning:" (list 'red))))
                 ((eq type 'err)
                  (concat "-" (xwem-str-with-faces "Error:" (list 'red 'bold))))
                 ((eq type 'err-nobeep)
                  (concat "-" (xwem-str-with-faces "Error:" (list 'red 'bold))))
                 ((eq type 'todo) (concat "-" (xwem-str-with-faces "TODO:" (list 'bold))))
                 ((eq type 'msg) "")
                 ((eq type 'prompt) "")
                 ((eq type 'progress) "")
                 ((eq type 'nolog) "")
                 (t "")))
          (msg (apply 'format fmt args)))

      (unless (member type '(prompt progress nolog))
        (xwem-message-insert msg))

      ;; Beep if needed
      (cond ((eq type 'warn) (xwem-play-sound 'msg-warn))
            ((eq type 'err) (xwem-play-sound 'msg-err)))

      (display-message 'message (concat "XWEM" str " " msg)))))

;;;###autoload
(defun xwem-clear-message ()
  "Just as `clear-message'."
  (clear-message))

;;;###autoload(autoload 'xwem-show-message-log "xwem-misc")
(define-xwem-command xwem-show-message-log (arg)
  "Show `xwem-messages-buffer-name'.
If prefix ARG is given, than behaviour is undefined."
  (xwem-interactive "P")

  (let ((mbuf (get-buffer-create xwem-messages-buffer-name)))
    (xwem-special-popup-frame mbuf)
    (with-current-buffer mbuf
      (setq mode-name "XWEM-log")
      (local-set-key (kbd "q") 'delete-frame)
      (message "Press `q' to eliminate buffer.")
      )))

;;;###autoload
(defun xwem-list-to-string (list len)
  "Convert LIST of characterters to string with length LEN."
  (let ((rstr ""))
    (while (and list (> len 0))
      (setq rstr (concat rstr (string (car list))))
      (setq list (cdr list))
      (setq len (1- len)))
    rstr))

;;;; Misc commands.
;;;###autoload(autoload 'xwem-ignore-command "xwem-misc")
(define-xwem-command xwem-ignore-command ()
  "Generic ignore command."
  (xwem-interactive))
  
(defvar xwem-read-expression-history nil
  "*History of expressions evaled using `xwem-eval-expression'.")

;;;###autoload(autoload 'xwem-eval-expression "xwem-misc")
(define-xwem-command xwem-eval-expression (expr &optional arg)
  "Eval Lisp expression interactively.
When used with prefix ARG, then insert the result into selected client."
  (xwem-interactive (list
                     (xwem-read-from-minibuffer (if xwem-prefix-arg
                                                    "XWEM (insert) Eval: "
                                                  "XWEM Eval: ")
                                                nil read-expression-map
                                                t 'xwem-read-expression-history)
                     xwem-prefix-arg))

  (setq values (cons (eval expr) values))
  (if arg
      (xwem-key-send-ekeys (prin1-to-string (car values)))
    
    (xwem-message 'info "%S => %S" expr (car values))))

;;;###autoload(autoload 'xwem-execute-extended-command "xwem-misc")
(define-xwem-command xwem-execute-extended-command (arg)
  "Execute Emacs command.
If prefix ARG is given insert result to current client."
  (xwem-interactive "P")

  (flet ((read-from-minibuffer (&rest args) nil))
    (fset 'read-from-minibuffer (symbol-function 'xwem-read-from-minibuffer))
    (let ((retval (execute-extended-command arg)))
      (when arg
        (xwem-key-send-ekeys (pp retval))))))

;;;###autoload(autoload 'xwem-shell-command "xwem-misc")
(define-xwem-command xwem-shell-command (command arg)
  "Execute shell command, just as `shell-command' do.
If prefix ARG is given insert result to current client.
If output of COMMAND fits to one string it is displayed in
`xwem-minibuffer', if not Emacs special frame will be poped up with
contents of COMMAND output.
If double prefix ARG \(i.e. \\<xwem-global-map>\\[xwem-universal-argument] \\<xwem-global-map>\\[xwem-universal-argument]\) supplied, then last
'\\n' character will be cuted in output to current client."
  (xwem-interactive (list (xwem-read-shell-command "XWEM Shell command: ")
                          xwem-prefix-arg))

  ;; Create temporary
  (let ((tbuf (get-buffer-create (generate-new-buffer-name " *temp-buf*")))
        dontkill)
    (unwind-protect
        (with-current-buffer tbuf
          (call-process shell-file-name nil tbuf nil
                        shell-command-switch command)

          (if arg
              (xwem-key-send-ekeys (buffer-substring (point-min)
                 (- (point-max) (if (> (prefix-numeric-value arg) 4) 1 0))))

            (if (= 1 (count-lines (point-min) (point-max)))
                (xwem-message 'info (buffer-substring (point-min) (point-max)))

              (xwem-special-popup-frame tbuf)
              (setq dontkill t))))
      (unless dontkill
        (kill-buffer tbuf)))))
    
;;;###autoload(autoload 'xwem-mini-calc "xwem-misc")
(define-xwem-command xwem-mini-calc (expr &optional arg)
  "Calculate expression EXPR.
If prefix ARG is given, insert the result to current client."
  (xwem-interactive
   (list (xwem-read-from-minibuffer (if xwem-prefix-arg
                                        "XWEM (insert) Calc: "
                                      "XWEM Calc: "))
         xwem-prefix-arg))

  (let ((result (calc-eval expr)))
    (if arg
        (xwem-key-send-ekeys result)
      (xwem-message 'info "%s = %s" expr result))))

;;;###autoload(autoload 'xwem-beginning-of-cl "xwem-misc")
(define-xwem-command xwem-beginning-of-cl ()
  "Send Home key to selected client."
  (xwem-interactive "*_")

  (xwem-kbd-force-mods-release)
  (xwem-key-send-ekeys (vector 'home)))

;;;###autoload(autoload 'xwem-end-of-cl "xwem-misc")
(define-xwem-command xwem-end-of-cl ()
  "Send End key to current client."
  (xwem-interactive "*_")

  (xwem-kbd-force-mods-release)
  (xwem-key-send-ekeys (vector 'end)))

;;;###autoload(autoload 'xwem-misc-make-screenshot "xwem-misc")
(define-xwem-command xwem-misc-make-screenshot (file-name)
  "Make screen screenshot and save it to file with NAME."
  (xwem-interactive "FImport screen to file: ")

   (flet ((message (fmt &rest args) nil))
     ;; shut up messaging
     (xwem-message 'msg
                   (format "Importing screenshot to %s." file-name))
     (xwem-execute-program (format "import -window root %s" (expand-file-name file-name)))))

;;;###autoload(autoload 'xwem-misc-pause "xwem-misc")
(define-xwem-command xwem-misc-pause (arg)
  "Pause for ARG decaseconds(0.1 sec).
This command is usefull, when recording keyboard macro, and there need
to wait for something, f.e. window mapping."
  (xwem-interactive "p")

  (while (> arg 0)
    (sleep-for 0.1)
    ;; Try to accept some data, so incoming events would be processed
    (accept-process-output (X-Dpy-proc (xwem-dpy)) 0.01)
    (setq arg (1- arg))))

;;; Some useful operations on lists
(defun xwem-insert-after (list aft-el el)
  "In LIST after AFT-EL insert EL."
  (push el (cdr (member aft-el list)))
  list)

(defun xwem-insert-before (list bef-el el)
  "In LIST before BEF-EL insert EL."
  (nreverse (xwem-insert-after (nreverse list) bef-el el)))

(defun xwem-list-set-element (list old-el new-el)
  "In LIST set OLD-EL to NEW-EL."
  (setcar (member old-el list) new-el)
  list)

;;;###autoload
(defun xwem-list-exchange-els (list el1 el2)
  "In LIST exchange places of EL1 and EL2."
  (when (or (null (member el1 list))
            (null (member el2 list)))
    (error "El1 or el2 is not in list"))

  (xwem-list-set-element list el1 'this-fake-name1-should-not-be-in-list)
  (xwem-list-set-element list el2 el1)
  (xwem-list-set-element list 'this-fake-name1-should-not-be-in-list el2))

;;; Profiling support
;;;###autoload
(defun xwem-misc-start-profiling ()
  "Start profiling critical xlib/xwem functions."
  (interactive)

  (setq elp-function-list xwem-misc-functions-to-profile)
  (elp-instrument-list))

;;;###autoload
(defun xwem-misc-profiling-results ()
  "Show xlib/xwem profiling results."
  (interactive)
  (elp-results))

;;;###autoload
(defun xwem-recursive-edit ()
  "Enter recursive edit."
  (recursive-edit))

;;;###autoload
(defun xwem-exit-recursive-edit ()
  "Exit from recursive edit."
  (if (> (recursion-depth) 0)
      (throw 'exit nil))
  (xwem-message 'warn "No recursive edit is in progress"))


;;; Text Specifications operations

;; TextSpec is list of vectors:
;; - vectors elements is cons cells in form (face . "text")
;; - each vector specifies line
;; - empty vector specifies newline

;;;###autoload
(defun xwem-misc-line->linesp (default-face)
  "Convert current line in selected buffer to element of text spec - line spec.
DEFAULT-FACE is the default face."
  (let (tsp cpnt npnt face str)
    (save-excursion
      (narrow-to-region (point-at-bol) (point-at-eol))
      (goto-char (point-at-bol))
      (while (not (eolp))
        (setq cpnt (point)
              npnt (or (next-single-property-change cpnt 'face) (point-at-eol))
              face (or (get-char-property cpnt 'face) default-face)
              str (buffer-substring cpnt npnt))
        (when (consp face)
          (setq face (car face)))       ; XXX need face merging
        
        ;; XXX Untabify
        (setq str (replace-in-string str "\t" (make-string tab-width ?\x20)))

        (setq tsp (cons (cons face str) tsp))
        (goto-char npnt))
      (widen))
    (vconcat (nreverse (or tsp (list (cons default-face "")))))))

;;;###autoload
(defun xwem-misc-buffer->textsp (default-face &optional buffer start end)
  "Convert BUFFER to text specification.
DEFAULT-FACE is the default face.
If BUFFER is omitted, selected buffer assumed."
  (let (rlst)
    (save-excursion
      (when buffer
        (set-buffer buffer))

      (goto-char (or start (point-min)))
      (while (and (not (eobp))
                  (< (point) (or end (point-max))))
        (setq rlst (cons (xwem-misc-line->linesp default-face) rlst))
        (forward-line 1))
      )
    (nreverse rlst)))

;;;###autoload
(defun xwem-misc-linesp-width (linesp)
  "Return width of line spec LINESP."
  (apply '+ (mapcar (lambda (el)
                      (X-Text-width (xwem-dpy) (X-Gc-font (xwem-face-get-gc (car el)))
                                    (cdr el)))
                    linesp)))

;;;###autoload
(defun xwem-misc-linesp-height (linesp)
  "Return height of line spec LINESP."
  (apply 'max (mapcar (lambda (el)
                        (X-Text-height (xwem-dpy) (X-Gc-font (xwem-face-get-gc (car el)))
                                       (cdr el)))
                      linesp)))

;;;###autoload
(defun xwem-misc-linesp-show (xwin x y linesp &optional type default-background)
  "In x window XWIN at X and Y coordinates show line spec LINESP.
TYPE is one of XImageString or XDrawString, default is XImageString."
  (let ((cxoff 0))
    (mapc (lambda (el)
            (funcall (cond ((and (eq type 'XDrawString)
                                 (stringp default-background)
                                 (not (string= default-background (face-background-name (car el)))))
                            'XImageString)
                           ((not (null type)) type)
                           (t 'XImageString))
                     (X-Win-dpy xwin) xwin
                     (xwem-face-get-gc (car el))
                     (+ x cxoff) y (cdr el))
            (setq cxoff (+ cxoff (X-Text-width (X-Win-dpy xwin)
                                               (X-Gc-font (xwem-face-get-gc (car el))) (cdr el)))))
          linesp)))

;;;###autoload
(defun xwem-misc-textsp-show (xwin x y textsp &optional type default-background)
  "In x window XWIN at X and Y coordinates show text spec TEXTSP.
TYPE is one of XImageString or XDrawString, default is XImageString.
If TYPE is XDrawString and DEFAULT-BACKGROUND is specifed, characters
that have different than DEFAULT-BACKGROUND baground color are drawed
using XImageString."
  (let ((yoff 0))
    (X-Dpy-send-excursion (X-Win-dpy xwin)
      (mapc (lambda (el)
              (xwem-misc-linesp-show xwin x (+ y yoff) el type default-background)
              (setq yoff (+ yoff (xwem-misc-linesp-height el))))
            textsp)
      )))

;;; Outlining
(defface xwem-misc-outline-face1
  `((t (:foreground "white" :background "black" :function X-GXXor :subwindow-mode X-IncludeInferiors :line-width 4)))
  "Face used to outline something."
  :group 'xwem-faces)

(defface xwem-misc-outline-face2
  `((t (:foreground "white" :background "black" :function X-GXXor :subwindow-mode X-IncludeInferiors :line-width 2)))
  "Face used to outline something."
  :group 'xwem-faces)

;;;###autoload
(defun xwem-misc-outline (xrect how)
  "Outline XRECT using HOW method.
Valid HOW is 'normal, ..."
  (let ((x (X-Rect-x xrect))
        (y (X-Rect-y xrect))
        (w (X-Rect-width xrect))
        (h (X-Rect-height xrect)))
    (cond ((eq how 'normal)
           (XDrawRectangles (xwem-dpy) (xwem-rootwin) (xwem-face-get-gc 'xwem-misc-outline-face1) (list xrect)))

          ((eq how 'contiguous)
           (xwem-misc-outline xrect 'normal)
           (XDrawSegments (xwem-dpy) (xwem-rootwin) (xwem-face-get-gc 'xwem-misc-outline-face2)
                          (list (cons (cons x 0)
                                      (cons x (X-Geom-height (xwem-rootgeom))))
                                (cons (cons (+ x w) 0)
                                      (cons (+ x w) (X-Geom-height (xwem-rootgeom))))
                                (cons (cons 0 y)
                                      (cons (X-Geom-width (xwem-rootgeom)) y))
                                (cons (cons 0 (+ y h))
                                      (cons (X-Geom-width (xwem-rootgeom)) (+ y h)))
                                )))

          ((eq how 'corners)
           (let* ((cornw (/ w 8))
                  (cornh (/ h 8))
                  (crw (/ (+ cornh cornw) 2)))
             (XDrawSegments (xwem-dpy) (xwem-rootwin) (xwem-face-get-gc 'xwem-misc-outline-face1)
                            (list 
                             ;; Top left
                             (cons (cons x y) (cons (+ x cornw) y))
                             (cons (cons x y) (cons x (+ y cornh)))

                             ;; Top right
                             (cons (cons (+ x w) y) (cons (+ x w (- cornw)) y))
                             (cons (cons (+ x w) y) (cons (+ x w) (+ y cornh)))

                             ;; Bottom left
                             (cons (cons x (+ y h)) (cons (+ x cornw) (+ y h)))
                             (cons (cons x (+ y h)) (cons x (+ y h (- cornh))))
                                
                             ;; Bottom right
                             (cons (cons (+ x w) (+ y h)) (cons (+ x w (- cornw)) (+ y h)))
                             (cons (cons (+ x w) (+ y h)) (cons (+ x w) (+ y h (- cornh))))

                             ;; Crosshair
                             (cons (cons (+ x (/ (- w crw) 2)) (+ y (/ h 2))) (cons (+ x (/ (+ w crw) 2)) (+ y (/ h 2))))
                             (cons (cons (+ x (/ w 2)) (+ y (/ (- h crw) 2))) (cons (+ x (/ w 2)) (+ y (/ (+ h crw) 2))))
                             ))))

          ((eq how 'grid)
           (xwem-misc-outline xrect 'normal)
           (XDrawSegments (xwem-dpy) (xwem-rootwin) (xwem-face-get-gc 'xwem-misc-outline-face2)
                          (nconc (funcall (lambda ()
                                            (let ((off 0) rl)
                                              (while (< off (+ x w))
                                                (when (> off x)
                                                  (setq rl (cons (cons (cons off y) (cons off (+ y h))) rl)))
                                                (setq off (+ off 64)))
                                              rl)))
                                 (funcall (lambda ()
                                            (let ((off 0)
                                                  rl)
                                              (while (< off (+ y h))
                                                (when (> off y)
                                                  (setq rl (cons (cons (cons x off) (cons (+ x w) off)) rl)))
                                                (setq off (+ off 64)))
                                              rl)))))
           )

          ;; TODO: add others
          )))


(provide 'xwem-misc)

;;; xwem-misc.el ends here