jss.invoke.lisp Maven / Gradle / Ivy
Go to download
Show more of this group Show more artifacts with this name
Show all versions of abcl-contrib Show documentation
Show all versions of abcl-contrib Show documentation
Extra packages--contribs--for ABCL
The newest version!
;; invoke.lisp v2.0
;;
;; Copyright (C) 2005 Alan Ruttenberg
;; Copyright (C) 2011 Mark Evenson
;;
;; Since most of this code is derivative of the Jscheme System, it is
;; licensed under the same terms, namely:
;; This software is provided 'as-is', without any express or
;; implied warranty.
;; In no event will the author be held liable for any damages
;; arising from the use of this software.
;; Permission is granted to anyone to use this software for any
;; purpose, including commercial applications, and to alter it
;; and redistribute it freely, subject to the following
;; restrictions:
;; 1. The origin of this software must not be misrepresented; you
;; must not claim that you wrote the original software. If you
;; use this software in a product, an acknowledgment in the
;; product documentation would be appreciated but is not
;; required.
;; 2. Altered source versions must be plainly marked as such, and
;; must not be misrepresented as being the original software.
;; 3. This notice may not be removed or altered from any source
;; distribution.
;; The dynamic dispatch of the java.lang.reflect package is used to
;; make it real easy, if perhaps less efficient, to write Java code
;; since you don't need to be bothered with imports, or with figuring
;; out which method to call. The only time that you need to know a
;; class name is when you want to call a static method, or a
;; constructor, and in those cases, you only need to know enough of
;; the class name that is unique wrt to the classes on your classpath.
;;
;; Java methods look like this: #"toString". Java classes are
;; represented as symbols, which are resolved to the appropriate java
;; class name. When ambiguous, you need to be more specific. A simple example:
;; (let ((sw (new 'StringWriter)))
;; (#"write" sw "Hello ")
;; (#"write" sw "World")
;; (print (#"toString" sw)))
;; What's happened here? First, all the classes in all the jars in the
;; classpath have been collected. For each class a.b.C.d, we have
;; recorded that b.c.d, b.C.d, C.d, c.d, and d potentially refer to
;; this class. In your call to new, as long as the symbol can refer to
;; only one class, we use that class. In this case, it is
;; java.io.StringWriter. You could also have written (new
;; 'io.stringwriter), (new '|io.StringWriter|), (new
;; 'java.io.StringWriter)...
;; the call (#"write" sw "Hello "), uses the code in invoke.java to
;; call the method named "write" with the arguments sw and "Hello ".
;; JSS figures out the right java method to call, and calls it.
;; If you want to do a raw java call, use #0"toString". Raw calls
;; return their results as Java objects, avoiding doing the usual Java
;; object to Lisp object conversions that ABCL does.
;; (with-constant-signature ((name jname raw?)*) &body body)
;; binds a macro which expands to a jcall, promising that the same method
;; will be called every time. Use this if you are making a lot of calls and
;; want to avoid the overhead of a the dynamic dispatch.
;; e.g. (with-constant-signature ((tostring "toString"))
;; (time (dotimes (i 10000) (tostring "foo"))))
;; runs about 3x faster than (time (dotimes (i 10000) (#"toString" "foo")))
;;
;; (with-constant-signature ((tostring "toString" t)) ...) will cause the
;; toString to be a raw java call. see get-all-jar-classnames below for an example.
;;
;; Implementation is that the first time the function is called, the
;; method is looked up based on the arguments passed, and thereafter
;; that method is called directly. Doesn't work for static methods at
;; the moment (lazy)
;;
;; (japropos string) finds all class names matching string
;; (jcmn class-name) lists the names of all methods for the class
;;
;; TODO
;; - Make with-constant-signature work for static methods too.
;; - #2"toString" to work like function scoped (with-constant-signature ((tostring "toString")) ...)
;; - #3"toString" to work like runtime scoped (with-constant-signature ((tostring "toString")) ...)
;; (both probably need compiler support to work)
;; - Maybe get rid of second " in reader macro. #"toString looks nicer, but might
;; confuse lisp mode.
;; - write jmap, analogous to map, but can take java collections, java arrays etc.
;; - write loop clauses for java collections.
;; - Register classes in .class files below classpath directories (when :wild-inferiors works)
;; - Make documentation like Edi Weitz
;;
;; Thanks: Peter Graves, Jscheme developers, Mike Travers for skij,
;; Andras Simon for jfli-abcl which bootstrapped me and taught me how to do
;; get-all-jar-classnames
;;
;; changelog
;; Sat January 28, 2006, alanr:
;; Change imports strategy. Only index by last part of class name,
;; case insensitive. Make the lookup-class-name logic be a bit more
;; complicated. This substantially reduces the time it takes to do the
;; auto imports and since class name lookup is relatively infrequent,
;; and in any case cached, this doesn't effect run time speed. (did
;; try caching, but didn't pay - more time was spent reading and
;; populating large hash table)
;;
;; Split class path by ";" in addition to ":" for windows.
;;
;; Tested on windows, linux.
;; 2011-05-21 Mark Evenson
;; "ported" to native ABCL without needing the jscheme.jar or bsh-2.0b4.jar
(in-package :jss)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defvar *do-auto-imports* t))
(defvar *imports-resolved-classes* (make-hash-table :test 'equal))
(defun find-java-class (name)
(jclass (maybe-resolve-class-against-imports name)))
(defmacro invoke-add-imports (&rest imports)
"Push these imports onto the search path. If multiple, earlier in list take precedence"
`(eval-when (:compile-toplevel :load-toplevel :execute)
(clrhash *imports-resolved-classes*)
(dolist (i (reverse ',imports))
(setq *imports-resolved-classes* (delete i *imports-resolved-classes* :test 'equal))
)))
(defun clear-invoke-imports ()
(clrhash *imports-resolved-classes*))
(defun maybe-resolve-class-against-imports (classname)
(or (gethash classname *imports-resolved-classes*)
(let ((found (lookup-class-name classname)))
(if found
(progn
(setf (gethash classname *imports-resolved-classes*) found)
found)
(string classname)))))
(defvar *class-name-to-full-case-insensitive* (make-hash-table :test 'equalp))
;; This is the function that calls invoke to call your java
;; method. The first argument is the method name or 'new. The second
;; is the object you are calling it on, followed by the rest of the
;; arguments. If the "object" is a symbol, then that symbol is assumed
;; to be a java class, and a static method on the class is called,
;; otherwise a regular method is called.
(defun invoke (method object &rest args)
(invoke-restargs method object args))
(defun invoke-restargs (method object args &optional (raw? nil))
(let* ((object-as-class-name
(if (symbolp object) (maybe-resolve-class-against-imports object)))
(object-as-class
(if object-as-class-name (find-java-class object-as-class-name))))
(if (eq method 'new)
(apply #'jnew (or object-as-class-name object) args)
(if raw?
(if (symbolp object)
(apply #'jstatic-raw method object-as-class args)
(apply #'jcall-raw method object args))
(if (symbolp object)
(apply #'jstatic method object-as-class args)
(apply #'jcall method object args))))))
;;; Method name as String --> String | Symbol --> jmethod
(defvar *methods-cache* (make-hash-table :test #'equal))
(defun get-jmethod (method object)
(when (gethash method *methods-cache*)
(gethash
(if (symbolp object) (lookup-class-name object) (jobject-class object))
(gethash method *methods-cache*))))
(defun set-jmethod (method object jmethod)
(unless (gethash method *methods-cache*)
(setf (gethash method *methods-cache*) (make-hash-table :test #'equal)))
(setf
(gethash
(if (symbolp object) (lookup-class-name object) (jobject-class object))
(gethash method *methods-cache*))
jmethod))
(defconstant +set-accessible+
(jmethod "java.lang.reflect.AccessibleObject" "setAccessible" "boolean"))
;;; TODO optimize me!
(defun invoke-find-method (method object args)
(let ((jmethod (get-jmethod method object)))
(unless jmethod
(setf jmethod
(if (symbolp object)
;;; static method
(apply #'jmethod (lookup-class-name object)
method (mapcar #'jobject-class args))
;;; instance method
(apply #'jresolve-method
method object args)))
(jcall +set-accessible+ jmethod +true+)
(set-jmethod method object jmethod))
jmethod))
;; This is the reader macro for java methods. it translates the method
;; into a lambda form that calls invoke. Which is nice because you
;; can, e.g. do this: (mapcar #"toString" list-of-java-objects). The reader
;; macro takes one arg. If 0, then jstatic-raw is called, so that abcl doesn't
;; automagically convert the returned java object into a lisp object. So
;; #0"toString" returns a java.lang.String object, where as #"toString" returns
;; a regular Lisp string as ABCL converts the Java string to a Lisp string.
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun read-invoke (stream char arg)
(unread-char char stream)
(let ((name (read stream)))
(let ((object-var (gensym))
(args-var (gensym)))
`(lambda (,object-var &rest ,args-var)
(invoke-restargs ,name ,object-var ,args-var ,(eql arg 0))))))
(set-dispatch-macro-character #\# #\" 'read-invoke))
(defmacro with-constant-signature (fname-jname-pairs &body body)
(if (null fname-jname-pairs)
`(progn ,@body)
(destructuring-bind ((fname jname &optional raw) &rest ignore) fname-jname-pairs
(declare (ignore ignore))
(let ((varname (gensym)))
`(let ((,varname nil))
(macrolet ((,fname (&rest args)
`(if ,',varname
(if ,',raw
(jcall-raw ,',varname ,@args)
(jcall ,',varname ,@args))
(progn
(setq ,',varname (invoke-find-method ,',jname ,(car args) (list ,@(rest args))))
(if ,',raw
(jcall-raw ,',varname ,@args)
(jcall ,',varname ,@args))))))
(with-constant-signature ,(cdr fname-jname-pairs)
,@body)))))))
(defun lookup-class-name (name)
(setq name (string name))
(let* (;; cant (last-name-pattern (#"compile" '|java.util.regex.Pattern| ".*?([^.]*)$"))
;; reason: bootstrap - the class name would have to be looked up...
(last-name-pattern (load-time-value (jstatic (jmethod "java.util.regex.Pattern" "compile"
(jclass "java.lang.String"))
(jclass "java.util.regex.Pattern")
".*?([^.]*)$")))
(last-name
(let ((matcher (#0"matcher" last-name-pattern name)))
(#"matches" matcher)
(#"group" matcher 1))))
(let* ((bucket (gethash last-name *class-name-to-full-case-insensitive*))
(bucket-length (length bucket)))
(or (find name bucket :test 'equalp)
(flet ((matches-end (end full test)
(= (+ (or (search end full :from-end t :test test) -10)
(length end))
(length full)))
(ambiguous (choices)
(error "Ambiguous class name: ~a can be ~{~a~^, ~}" name choices)))
(if (zerop bucket-length)
name
(let ((matches (loop for el in bucket when (matches-end name el 'char=) collect el)))
(if (= (length matches) 1)
(car matches)
(if (= (length matches) 0)
(let ((matches (loop for el in bucket when (matches-end name el 'char-equal) collect el)))
(if (= (length matches) 1)
(car matches)
(if (= (length matches) 0)
name
(ambiguous matches))))
(ambiguous matches))))))))))
(defun get-all-jar-classnames (jar-file-name)
(let* ((jar (jnew (jconstructor "java.util.jar.JarFile" (jclass "java.lang.String")) (namestring (truename jar-file-name))))
(entries (#"entries" jar)))
(with-constant-signature ((matcher "matcher" t) (substring "substring")
(jreplace "replace" t) (jlength "length")
(matches "matches") (getname "getName" t)
(next "nextElement" t) (hasmore "hasMoreElements")
(group "group"))
(loop while (hasmore entries)
for name = (getname (next entries))
with class-pattern = (#"compile" '|java.util.regex.Pattern| "[^$]*\\.class$")
with name-pattern = (#"compile" '|java.util.regex.Pattern| ".*?([^.]*)$")
when (matches (matcher class-pattern name))
collect
(let* ((fullname (substring (jreplace name #\/ #\.) 0 (- (jlength name) 6)))
(matcher (matcher name-pattern fullname))
(name (progn (matches matcher) (group matcher 1))))
(cons name fullname))
))))
(defun jar-import (file)
(when (probe-file file)
(loop for (name . full-class-name) in (get-all-jar-classnames file)
do
(pushnew full-class-name (gethash name *class-name-to-full-case-insensitive*)
:test 'equal))))
(defun new (class-name &rest args)
(invoke-restargs 'new class-name args))
(defvar *running-in-osgi* (ignore-errors (jclass "org.osgi.framework.BundleActivator")))
(defun get-java-field (object field &optional (try-harder *running-in-osgi*))
(if try-harder
(let* ((class (if (symbolp object)
(setq object (find-java-class object))
(if (equal "java.lang.Class" (jclass-name (jobject-class object)))
object
(jobject-class object))))
(jfield (if (java-object-p field)
field
(find field (#"getDeclaredFields" class)
:key 'jfield-name :test 'equal))))
(#"setAccessible" jfield t)
(values (#"get" jfield object) jfield))
(if (symbolp object)
(let ((class (find-java-class object)))
(jfield class field))
(jfield field object))))
;; use #"getSuperclass" and #"getInterfaces" to see whether there are fields in superclasses that we might set
(defun set-java-field (object field value &optional (try-harder *running-in-osgi*))
(if try-harder
(let* ((class (if (symbolp object)
(setq object (find-java-class object))
(if (equal "java.lang.Class" (jclass-name (jobject-class object)) )
object
(jobject-class object))))
(jfield (if (java-object-p field)
field
(find field (#"getDeclaredFields" class) :key 'jfield-name :test 'equal))))
(#"setAccessible" jfield t)
(values (#"set" jfield object value) jfield))
(if (symbolp object)
(let ((class (find-java-class object)))
(#"pokeStatic" 'invoke class field value))
(#"poke" 'invoke object field value))))
(defconstant +for-name+
(jmethod "java.lang.Class" "forName" "java.lang.String" "boolean" "java.lang.ClassLoader"))
(defun find-java-class (name)
(or (jstatic +for-name+ "java.lang.Class"
(maybe-resolve-class-against-imports name) +true+ java::*classloader*)
(ignore-errors (jclass (maybe-resolve-class-against-imports name)))))
(defmethod print-object ((obj (jclass "java.lang.Class")) stream)
(print-unreadable-object (obj stream :identity nil)
(format stream "java class ~a" (jclass-name obj))))
(defmethod print-object ((obj (jclass "java.lang.reflect.Method")) stream)
(print-unreadable-object (obj stream :identity nil)
(format stream "method ~a" (#"toString" obj))))
(defun do-auto-imports ()
(flet ((import-class-path (cp)
(map nil
(lambda(s)
(setq s (jcall "toString" s))
(when *load-verbose*
(format t ";Importing ~a~%" s))
(cond
((file-directory-p s) )
((equal (pathname-type s) "jar")
(jar-import (merge-pathnames (jcall "toString" s)
(format nil "~a/" (jstatic "getProperty" "java.lang.System" "user.dir")))))))
(jcall "split" cp
(string (jfield (jclass "java.io.File") "pathSeparatorChar"))))))
(import-class-path (jcall "getClassPath" (jstatic "getRuntimeMXBean" '|java.lang.management.ManagementFactory|)))
(import-class-path (jcall "getBootClassPath" (jstatic "getRuntimeMXBean" '|java.lang.management.ManagementFactory|)))
))
(eval-when (:load-toplevel :execute)
(when *do-auto-imports*
(do-auto-imports)))
(defun japropos (string)
(setq string (string string))
(let ((matches nil))
(maphash (lambda(key value)
(declare (ignore key))
(loop for class in value
when (search string class :test 'string-equal)
do (pushnew (list class "Java Class") matches :test 'equal)))
*class-name-to-full-case-insensitive*)
(loop for (match type) in (sort matches 'string-lessp :key 'car)
do (format t "~a: ~a~%" match type))
))
(defun jclass-method-names (class &optional full)
(if (java-object-p class)
(if (equal (jclass-name (jobject-class class)) "java.lang.Class")
(setq class (jclass-name class))
(setq class (jclass-name (jobject-class class)))))
(union
(remove-duplicates (map 'list (if full #"toString" 'jmethod-name) (#"getMethods" (find-java-class class))) :test 'equal)
(ignore-errors (remove-duplicates (map 'list (if full #"toString" 'jmethod-name) (#"getConstructors" (find-java-class class))) :test 'equal))))
(defun jcmn (class &optional full)
(if full
(dolist (method (jclass-method-names class t))
(format t "~a~%" method))
(jclass-method-names class)))
(defun path-to-class (classname)
(let ((full (lookup-class-name classname)))
(#"toString"
(#"getResource"
(find-java-class full)
(concatenate 'string "/" (substitute #\/ #\. full) ".class")))))
;; http://www.javaworld.com/javaworld/javaqa/2003-07/02-qa-0725-classsrc2.html
(defun all-loaded-classes ()
(let ((classes-field
(find "classes" (#"getDeclaredFields" (jclass "java.lang.ClassLoader"))
:key #"getName" :test 'equal)))
(#"setAccessible" classes-field t)
(loop for classloader in (mapcar #'first (dump-classpath))
append
(loop with classesv = (#"get" classes-field classloader)
for i below (#"size" classesv)
collect (#"getName" (#"elementAt" classesv i)))
append
(loop with classesv = (#"get" classes-field (#"getParent" classloader))
for i below (#"size" classesv)
collect (#"getName" (#"elementAt" classesv i))))))
(defun get-dynamic-class-path ()
(rest
(find-if (lambda (loader)
(string= "org.armedbear.lisp.JavaClassLoader"
(jclass-name (jobject-class loader))))
(dump-classpath)
:key #'car)))
(defun java-gc ()
(#"gc" (#"getRuntime" 'java.lang.runtime))
(#"runFinalization" (#"getRuntime" 'java.lang.runtime))
(#"gc" (#"getRuntime" 'java.lang.runtime))
(java-room))
(defun java-room ()
(let ((rt (#"getRuntime" 'java.lang.runtime)))
(values (- (#"totalMemory" rt) (#"freeMemory" rt))
(#"totalMemory" rt)
(#"freeMemory" rt)
(list :used :total :free))))
(defun verbose-gc (&optional (new-value nil new-value-supplied))
(if new-value-supplied
(progn (#"setVerbose" (#"getMemoryMXBean" 'java.lang.management.ManagementFactory) new-value) new-value)
(#"isVerbose" (#"getMemoryMXBean" 'java.lang.management.ManagementFactory))))
(defun all-jars-below (directory)
(loop with q = (system:list-directory directory)
while q for top = (pop q)
if (null (pathname-name top)) do (setq q (append q (all-jars-below top)))
if (equal (pathname-type top) "jar") collect top))
(defun all-classfiles-below (directory)
(loop with q = (system:list-directory directory)
while q for top = (pop q)
if (null (pathname-name top)) do (setq q (append q (all-classfiles-below top )))
if (equal (pathname-type top) "class")
collect top
))
(defun all-classes-below-directory (directory)
(loop for file in (all-classfiles-below directory) collect
(format nil "~{~a.~}~a"
(subseq (pathname-directory file) (length (pathname-directory directory)))
(pathname-name file))
))
(defun classfiles-import (directory)
(setq directory (truename directory))
(loop for full-class-name in (all-classes-below-directory directory)
for name = (#"replaceAll" full-class-name "^.*\\." "")
do
(pushnew full-class-name (gethash name *class-name-to-full-case-insensitive*)
:test 'equal)))
(defun set-to-list (set)
(declare (optimize (speed 3) (safety 0)))
(with-constant-signature ((iterator "iterator" t) (hasnext "hasNext") (next "next"))
(loop with iterator = (iterator set)
while (hasNext iterator)
for item = (next iterator)
collect item)))
(defun jlist-to-list (list)
"Convert a LIST implementing java.util.List to a Lisp list."
(declare (optimize (speed 3) (safety 0)))
(loop :for i :from 0 :below (jcall "size" list)
:collecting (jcall "get" list i)))
(defun jarray-to-list (jarray)
(declare (optimize (speed 3) (safety 0)))
(jlist-to-list
(jstatic "asList" "java.util.Arrays" jarray)))
;;; Deprecated
;;;
;;; XXX unclear what sort of list this would actually work on, as it
;;; certainly doesn't seem to be any of the Java collection types
;;; (what implements getNext())?
(defun list-to-list (list)
(declare (optimize (speed 3) (safety 0)))
(with-constant-signature ((isEmpty "isEmpty") (getfirst "getFirst")
(getNext "getNext"))
(loop until (isEmpty list)
collect (getFirst list)
do (setq list (getNext list)))))
;; Contribution of Luke Hope. (Thanks!)
(defun iterable-to-list (iterable)
(declare (optimize (speed 3) (safety 0)))
(let ((it (#"iterator" iterable)))
(with-constant-signature ((hasmore "hasMoreElements")
(next "nextElement"))
(loop while (hasmore it)
collect (next it)))))
(defun vector-to-list (vector)
(declare (optimize (speed 3) (safety 0)))
(with-constant-signature ((hasmore "hasMoreElements")
(next "nextElement"))
(loop while (hasmore vector)
collect (next vector))))
(defun hashmap-to-hashtable (hashmap &rest rest &key (keyfun #'identity) (valfun #'identity) (invert? nil)
table
&allow-other-keys )
(let ((keyset (#"keySet" hashmap))
(table (or table (apply 'make-hash-table
(loop for (key value) on rest by #'cddr
unless (member key '(:invert? :valfun :keyfun :table))
collect key and collect value)))))
(with-constant-signature ((iterator "iterator" t) (hasnext "hasNext") (next "next"))
(loop with iterator = (iterator keyset)
while (hasNext iterator)
for item = (next iterator)
do (if invert?
(setf (gethash (funcall valfun (#"get" hashmap item)) table) (funcall keyfun item))
(setf (gethash (funcall keyfun item) table) (funcall valfun (#"get" hashmap item)))))
table)))
(defun jclass-all-interfaces (class)
"Return a list of interfaces the class implements"
(unless (java-object-p class)
(setq class (find-java-class class)))
(loop for aclass = class then (#"getSuperclass" aclass)
while aclass
append (coerce (#"getInterfaces" aclass) 'list)))
(defun safely (f name)
(let ((fname (gensym)))
(compile fname
`(lambda(&rest args)
(with-simple-restart (top-level
"Return from lisp method implementation for ~a." ,name)
(apply ,f args))))
(symbol-function fname)))
(defun jdelegating-interface-implementation (interface dispatch-to &rest method-names-and-defs)
"Creates and returns an implementation of a Java interface with
methods calling Lisp closures as given in METHOD-NAMES-AND-DEFS.
INTERFACE is an interface
DISPATCH-TO is an existing Java object
METHOD-NAMES-AND-DEFS is an alternating list of method names
(strings) and method definitions (closures).
For missing methods, a dummy implementation is provided that
calls the method on DISPATCH-TO."
(let ((implemented-methods
(loop for m in method-names-and-defs
for i from 0
if (evenp i)
do (assert (stringp m) (m) "Method names must be strings: ~s" m) and collect m
else
do (assert (or (symbolp m) (functionp m)) (m) "Methods must be function designators: ~s" m))))
(let ((safe-method-names-and-defs
(loop for (name function) on method-names-and-defs by #'cddr
collect name collect (safely function name))))
(loop for method across
(jclass-methods interface :declared nil :public t)
for method-name = (jmethod-name method)
when (not (member method-name implemented-methods :test #'string=))
do
(let* ((def `(lambda
(&rest args)
(invoke-restargs ,(jmethod-name method) ,dispatch-to args t)
)))
(push (coerce def 'function) safe-method-names-and-defs)
(push method-name safe-method-names-and-defs)))
(apply #'java::%jnew-proxy interface safe-method-names-and-defs))))
© 2015 - 2025 Weber Informatics LLC | Privacy Policy