36cf086d |
1 | ;; Common Lisp bindings for GTK+ v2.x |
2 | ;; Copyright 1999-2005 Espen S. Johnsen <espen@users.sf.net> |
3 | ;; |
4 | ;; Permission is hereby granted, free of charge, to any person obtaining |
5 | ;; a copy of this software and associated documentation files (the |
6 | ;; "Software"), to deal in the Software without restriction, including |
7 | ;; without limitation the rights to use, copy, modify, merge, publish, |
8 | ;; distribute, sublicense, and/or sell copies of the Software, and to |
9 | ;; permit persons to whom the Software is furnished to do so, subject to |
10 | ;; the following conditions: |
11 | ;; |
12 | ;; The above copyright notice and this permission notice shall be |
13 | ;; included in all copies or substantial portions of the Software. |
14 | ;; |
15 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, |
16 | ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF |
17 | ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. |
18 | ;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY |
19 | ;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, |
20 | ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE |
21 | ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. |
22 | |
23 | ;; $Id: utils.lisp,v 1.1 2006-03-29 09:51:55 espen Exp $ |
24 | |
25 | (defpackage #:clg-utils |
26 | (:use #:common-lisp) |
27 | (:export #:read-lines #:mklist #:namep #:funcallable #:return-if #:when-bind |
28 | #:visible-char-p #:whitespace-p #:split-string-if #:split-string |
29 | #:concatenate-strings #:string-prefix-p #:get-all)) |
30 | |
31 | (in-package #:clg-utils) |
32 | |
33 | (defun read-lines (&optional (stream *standard-input*)) |
34 | "Read lines from STREAM until end of file." |
35 | (loop |
36 | as line = (read-line stream nil) |
37 | while line |
38 | collect line)) |
39 | |
40 | (defun mklist (obj) |
41 | (if (and obj (atom obj)) (list obj) obj)) |
42 | |
43 | (defun namep (obj) |
44 | (and (symbolp obj) (not (member obj '(t nil))))) |
45 | |
46 | (defun funcallable (object) |
47 | (if (consp object) |
48 | (fdefinition object) |
49 | object)) |
50 | |
51 | (defmacro return-if (form) |
52 | (let ((result (make-symbol "RESULT"))) |
53 | `(let ((,result ,form)) |
54 | (when ,result |
55 | (return ,result))))) |
56 | |
57 | (defmacro when-bind ((var expr) &body body) |
58 | `(let ((,var ,expr)) |
59 | (when ,var |
60 | ,@body))) |
61 | |
62 | (defun visible-char-p (char) |
63 | (and (graphic-char-p char) (char/= char #\space))) |
64 | |
65 | (defun whitespace-p (char) |
66 | (not (visible-char-p char))) |
67 | |
68 | (defun split-string-if (string predicate) |
69 | (declare (simple-string string)) |
70 | (let ((pos (position-if predicate string :start 1))) |
71 | (if (not pos) |
72 | (list string) |
73 | (cons |
74 | (subseq string 0 pos) |
75 | (split-string-if (subseq string pos) predicate))))) |
76 | |
77 | (defun split-string (string &optional (delimiter #'whitespace-p) |
78 | &key (start 0) (end (length string))) |
79 | (let* ((predicate (if (functionp delimiter) |
80 | delimiter |
81 | #'(lambda (char) |
82 | (find char (mklist delimiter) :test #'char=)))) |
83 | (from (position-if-not predicate string :start start))) |
84 | (when from |
85 | (let ((to (position-if predicate string :start from :end end))) |
86 | (cons |
87 | (subseq string from (or to end)) |
88 | (when to |
89 | (split-string string predicate :start to :end end))))))) |
90 | |
91 | (defun concatenate-strings (strings &optional delimiter) |
92 | (if (not (rest strings)) |
93 | (first strings) |
94 | (concatenate |
95 | 'string |
96 | (first strings) |
97 | (if delimiter (string delimiter) "") |
98 | (concatenate-strings (rest strings) delimiter)))) |
99 | |
100 | (defun string-prefix-p (prefix string) |
101 | (and |
102 | (>= (length string) (length prefix)) |
103 | (string= prefix string :end2 (length prefix)))) |
104 | |
105 | (defun get-all (plist property) |
106 | (multiple-value-bind (property value tail) |
107 | (get-properties plist (list property)) |
108 | (when tail |
109 | (cons value (get-all (cddr tail) property))))) |