Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

typed warnings and more lax has-slot?

 * has-slot? will now return slots that are equalper (string match)
   if it cannot find one that is eql
 * This means access works on objects in a way more similar to the way
   it operates on hashtables / alists / plists
  • Loading branch information...
commit 8b86edf769f3c15b12f1267ad393c3ba984a8dae 1 parent 6a31d06
@bobbysmith007 bobbysmith007 authored
Showing with 78 additions and 14 deletions.
  1. +48 −14 access.lisp
  2. +30 −0 test/access.lisp
View
62 access.lisp
@@ -3,6 +3,7 @@
(:shadowing-import-from :alexandria #:ensure-list )
(:shadowing-import-from :anaphora #:awhen #:aif #:it)
(:export
+ #:access-warning
;; utils to make this work
#:has-reader?
#:has-writer?
@@ -52,6 +53,23 @@
(in-package :access)
+(define-condition access-condition (simple-condition)
+ ((format-control :accessor format-control :initarg :format-control :initform nil)
+ (format-args :accessor format-args :initarg :format-args :initform nil)
+ (original-error :accessor original-error :initarg :original-error :initform nil))
+ (:report (lambda (c s)
+ (apply #'format
+ s
+ (format-control c)
+ (format-args c)))))
+
+(define-condition access-warning (access-condition warning) ())
+
+(defun access-warn (message &rest args)
+ (warn (make-condition 'access-warning
+ :format-control message
+ :format-args args)))
+
(defun equalper (x y)
"compares symbols by equalp symbol-name"
(flet ((cast (it)
@@ -174,7 +192,7 @@
((or keyword string) (string-equal (string name) (string reader-name)))
(function (eql reader reader-name))
(symbol (eql name reader-name))
- (T (warn "Not sure how to ~S maps to a function" reader-name)))
+ (T (access-warn "Not sure how to ~S maps to a function" reader-name)))
(return (values reader name)))))))
(defun has-writer? (o writer-name)
@@ -194,16 +212,31 @@
;; setf-form ;; try again with just the slotname
(has-writer? o (second writer-name))))
(symbol (eql sn writer-name))
- (T (warn "Not sure how to ~S maps to a function" writer-name)))
+ (T (access-warn "Not sure how to ~S maps to a function" writer-name)))
(return (values writer wn sn)))))))
-(defun has-slot? (o slot-name)
- "Does o have a slot names slot-name"
- (let ((slot-names (class-slot-names o)))
- (typecase slot-name
- ((or keyword string)
- (member (string slot-name) slot-names :test #'string-equal :key #'string))
- (symbol (member slot-name slot-names)))))
+(defun has-slot? (o slot-name &key (lax? t))
+ "Does o have a slot names slot-name
+
+ if lax? we will ignore packages to find the slot we will always return a
+ slot-name from the specified package if it exists, otherwise we return the
+ slot-name we found if its in a different package"
+ (let ((slot-names (class-slot-names o))
+ lax)
+ (or
+ (iter (for sn in slot-names)
+ (cond
+ ;; exact match - always return this first if we find it
+ ((eql sn slot-name) (return sn))
+
+ ;; return the first lax match we find
+ ((and lax? (not lax) (equalper slot-name sn))
+ (setf lax sn))
+
+ ;; warn on any additional lax matches we find
+ ((and lax? lax (equalper slot-name sn))
+ (access-warn "Multiple slots inexactly matched for ~a on ~a" slot-name o))))
+ lax)))
(defun setf-if-applicable (new o fn)
"If we find a setf function named (setf fn) that can operate on o then call
@@ -215,7 +248,7 @@
(typecase fn
((or keyword string symbol) (has-writer? o fn))
(function fn)
- (T (warn "Not sure how to call a ~A" fn) ))))
+ (T (access-warn "Not sure how to call a ~A" fn) ))))
(when fn
;; complex if/whens instead of ands/ors because a standard generic function
;; is a function, but we dont want to call it if not applicable
@@ -236,7 +269,7 @@
((or keyword string) (has-reader? o fn))
(symbol (symbol-function fn))
(function fn)
- (T (warn "Not sure how to call a ~A" fn) ))))
+ (T (access-warn "Not sure how to call a ~A" fn) ))))
(when fn
;; complex if/whens instead of ands/ors because a standard generic function
;; is a function, but we dont want to call it if not applicable
@@ -278,9 +311,10 @@
(awhen (ignore-errors (string k))
(gethash it o)))))
(:object
- (when (and (has-slot? o k)
- (slot-boundp o k))
- (slot-value o k))))))))
+ (let ((actual-slot-name (has-slot? o k)))
+ (when (and actual-slot-name
+ (slot-boundp o actual-slot-name))
+ (slot-value o actual-slot-name)))))))))
(defun set-access (new o k &key type (test #'equalper) (key #'identity))
"set places in plists, alists, hashtables and clos objects all through the same interface"
View
30 test/access.lisp
@@ -4,10 +4,21 @@
(:shadowing-import-from :anaphora #:awhen #:aif #:it)
(:export ))
+;; for a specific test
+(cl:defpackage :access-test-other
+ (:use :cl :cl-user :iterate :access :lisp-unit)
+ (:export ))
+
(in-package :access-test)
(enable-dot-syntax)
+(defun run-all-tests ()
+ (let ((lisp-unit:*print-errors* t)
+ (lisp-unit:*print-failures* t)
+ (lisp-unit:*print-summary* t))
+ (run-tests :all)))
+
(defparameter +al+ `((:one . 1) ("two" . 2) ("three" . 3) (four . 4) (:5 . 5)))
(defparameter +pl+ (list :one 1 "two" 2 "three" 3 'four 4 :5 5))
@@ -162,3 +173,22 @@
(assert-equal 4 rest.pl2.four))
(assert-equal 4 v.four))))
+(defclass multi-package-test-obj ()
+ ((my-slot :accessor my-slot :initarg :my-slot :initform nil)
+ (access-test-other::my-slot :accessor access-test-other::my-slot
+ :initarg :my-slot :initform nil))
+ (:documentation "Do you hate sanity?"))
+
+(define-test has-slot
+ (let ((o (make-instance 'multi-package-test-obj)))
+ (assert-eql 'my-slot (has-slot? o 'my-slot))
+ ;; seems like this *could be* implementation dependent based on the ordering returned from
+ ;; the mop... Lets hope for the sanest (eg first listed)
+ (assert-eql 'my-slot (has-slot? o :my-slot))
+ (let ( warned? )
+ (handler-case (has-slot? o :my-slot)
+ (access-warning (c) (declare (ignore c))
+ (setf warned? t)))
+ (assert-true warned? "We got a warning for multi-slot-matches"))
+ (assert-eql 'access-test-other::my-slot (has-slot? o 'access-test-other::my-slot))))
+
Please sign in to comment.
Something went wrong with that request. Please try again.