;;; This file contains functions to parse a java .class file, and a
;;; very crude function to display the contents. When in a .class buffer
;;; (or the expanded one from inside a .jar file) type "M-x class-file"
;;; to get the contents in a fairly readable. The function (read-class-file)
;;; parses the contents and returns a list.
;;;
;;; If you want to get class files read automatically when browsing a
;;; .jar file put the following in your .emacs:
;;;
;;; (require 'java-class)
;;;	(defadvice archive-extract (after expand-java-class activate)
;;;		(if (string-match "\\.class" buffer-file-name) (java-class-mode)))

;;; russell young 2005
;;; elisp at young-0 dot com

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Customization
;;
;; A few variables and a lot of faces
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Set up all the customizable variables
(defgroup java-class nil
  "Customization of function to interpret java .class files.
Files are parsed and displayed so that you can understand at a glance what
they contain."
  :prefix "jc-"
  :group 'programming)

(defcustom jc-delete-class-buffer t
  "Deletes the .class buffer after parsing it."
  :group 'java-class
  :type 'boolean)

(defcustom jc-limit-display '()
  "Limits display to only those methods and fields with the given attributes.
If none are listed then display all methods and fields."
  :type '(set (const default)
			  (const public)
			  (const private)
			  (const protected)
			  (const final)
			  (const synchronized)
			  (const volatile)
			  (const transient)
			  (const native)
			  (const interface)
			  (const abstract)
			  (const static))
  :group 'java-class)

(defcustom jc-use-faces t
  "Use different faces to display different field and method types."
  :group 'java-class
  :type 'boolean)

;;; following are the faces it uses to display the fields and methods.
;;; Faces are combined to give more than one feature - I use colors for
;;; protection (green for public, yellow for protected, red for
;;; private), italic for static, and underline for final.
;;;
;;; Originally I spent a long time trying to get the customize buffers
;;; to update all the relevent faces whenever one was changed. Finally
;;; I concluded there was no good way to do it with the CUSTOM widgets
;;; supplied, since they have too many hardcoded function names in the
;;; functions. So, I did it by advising the CUSTOM-SET-FACE function.
;;;
;;; Later when I understood font inheritance I realized it could all
;;; be done automatically by having the fonts inherit from the proper
;;; template fonts, so that is what it does now.
;;;
;;; The base fonts are jc-final, jc-static, jc-default, jc-public,
;;; jc-protected, and jc-private. Changes made in these will propogate
;;; correctly through all the other combinations.

(defface jc-final '((t
					 (:underline t)))
  "Features to add on to faces for all final fields and methods.
This face is not used directly, but instead is used to modify the faces
used for final fields and methods. Any feature set here will be set
in the faces jc-default-final, jc-private-final... and thus used to
display all final objects. I use different colors for the protections
and other features, like underline and italic, for the modifiers."
  :group 'java-class)

(defface jc-static '((t
					  (:italic t)))
  "Features to add on to faces for all static fields and methods.
This face is not used directly, but instead is used to modify the faces
used for static fields and methods. Any feature set here will be set
in the faces jc-default-static, jc-private-static... and thus used to
display all static objects. I use different colors for the protections
and other features, like underline and italic, for the modifiers."
  :group 'java-class)

(defface jc-default
  '((((class color) (background dark)) nil) (((class color) (background light)) nil) (t nil))
  "Face used to display fields and methods if no protection is given.
This face is combined with the jc-static and jc-final faces to make the
faces jc-default-static, jc-default-final, and jc-default-static-final"
  :group 'java-class)

(defface jc-public
  `((((class color) (background dark))
	 (:foreground "green"))
	(((class color)
	  (background light))
	 (:foreground "dark green"))
	(t ()))
  "Face used to display public fields and methods.
This face is combined with the jc-static and jc-final faces to make the
faces jc-public-static, jc-public-final, and jc-public-static-final"
  :group 'java-class)

(defface jc-protected
  `((((class color) (background dark))
	 (:foreground "yellow"))
	(((class color)
	  (background light))
	 (:foreground "orange"))
	(t ()))
  "Face used to display protected fields and methods.
This face is combined with the jc-static and jc-final faces to make the
faces jc-protected-static, jc-protected-final, and jc-protected-static-final"
  :group 'java-class)

(defface jc-private
  `((((class color) (background dark))
	 (:foreground "red"))
	(((class color)
	  (background light))
	 (:foreground "red"))
	(t ()))
  "Face used to display private fields and methods.
This face is combined with the jc-static and jc-final faces to make the
faces jc-private-static, jc-private-final, and jc-private-static-final"
  :group 'java-class)

;;; make the derived faces. They are *not* in the JAVA-CLASS customization group,
;;; since they are not meant to be changed directly, only through inheritance
(flet ((make-combined-faces (base)
							(let ((doc "Do not change this face, it inherits from the main faces
(jc-static, jc-final), and (jc-default, jc-public, jc-private, jc-protected)"))
							  (custom-declare-face (intern (format "%s-static" base))
												   `((t (:inherit (jc-static ,base))))
												   doc)
							  (custom-declare-face (intern (format "%s-final" base))
												   `((t (:inherit (jc-final ,base))))
												   doc)
							  (custom-declare-face (intern (format "%s-static-final" base))
												   `((t (:inherit (jc-final jc-static ,base))))
												   doc)
							  )))
  (make-combined-faces 'jc-default)
  (make-combined-faces 'jc-public)
  (make-combined-faces 'jc-protected)
  (make-combined-faces 'jc-private))

;;; mask used to get the bits I care about for display. These are the
;;; bits for PUBLIC, PRIVATE, PROTECTED, STATIC, and FINAL. There are also
;;; bits for SYNCHRONIZED, VOLATILE, TRANSIENT, NATIVE, INTERFACE, and
;;; ABSTRACT, but adding one doubles the number of faces used, and they
;;; don't seem as important
(defconst jc-flag-bits
  '(public private protected static final synchronized volatile transient native interface abstract)
  "Meaning of the flag bits, from bit 0x1 to bit 0x400")

(defconst jc-facemask 31
  "mask of bits to use in finding the proper face")

(defconst jc-face-map
  '((0 . jc-default)				(1 . jc-public)				 (2 . jc-private)				(4 . jc-protected)
	(8 . jc-default-static)		(9 . jc-public-static)		 (10 . jc-private-static)		(12 . jc-protected-static)
	(16 . jc-default-final)		(17 . jc-public-final)		 (18 . jc-private-final)		(20 . jc-protected-final)
	(24 . jc-default-static-final)(25 . jc-public-static-final)(26 . jc-private-static-final)	(28 . jc-protected-static-final))
  "alist matching flag bits with display face to use.")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Here is the stuff that actually parses the file
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defconst jc-class-file-magic '("CAFEBABE")
  "Class file magic number, if it is not right this is not a class file")

;;; Descriptor for the main structure
;;; Each of these functions runs, advancing a pointer in the class file
;;; In general, the first 3 fields can be thrown away after the file has been parsed
(defconst class-desc '((class-file-check (get-bytes-string 4))		;;; magic
					   (reverse (get-bytes 2 2))					;;; minor, major (change the order)
					   (prog1 (setq pool-len ptr					;;; constant-pool-count , constant pools
									constant-pool (cons nil (read-array 'read-one-constant 1)))
						 (setq pool-len (- ptr pool-len)))			;;; get the size
					   (read-flag-bits)								;;; access-flags
					   (from-pool)									;;; this-class
					   (from-pool)									;;; super-class
					   (read-array 'from-pool 0)					;;; interfaces-count, read-interfaces
					   (read-array 'read-one-field 0)				;;; field-counts, field-info
					   (read-array 'read-one-field 0)				;;; methods-count, methods-info
					   (read-array 'read-one-attribute 0)			;;; attributes-count, attribute info
					   pool-len										;;; add on the pool size
					   )
  "Descriptor controlling parsing of the entire .class file")


;; Constant pool data types
;; There is no real need to include the first member of each entry, but it
;; makes debugging the result list a lot easier
;; type name (for debugging); initialize command; fetch command; double size (add fake entry after)
;; NOTE: LONG, DOUBLE, and FLOAT do not give proper values because elisp does not easily
;;	handle those types. LONG returns a string
;; NOTE 2: I don't think the fetch methods for the last few types ever get called, they are
;;	parsed in the FLET functions in CLASS-FILE
(defconst constant-pool-types '((utf		(get-string 2)	identity)			;;; utf - the actual data is here
								nil												;;; unused - will cause an error
								(integer	(get-bytes 4)	identity)			;;; integer
								(float		(get-bytes 4)	identity)			;;; float
								(long		(get-bytes-string 8) identity	t)	;;; long
								(double	(get-bytes 4 4) list		t)			;;; double
								(class		(get-bytes 2)	gfcp)				;;; class
								(string	(get-bytes 2)	gfcp)					;;; string
								(fieldref	(get-bytes 2 2)						;;; field ref
											(lambda (x) (list (gfcp (car x)) (gfcp (second x)))))
								(methodref	(get-bytes 2 2)						;;; method ref
											(lambda (x) (list (gfcp (car x)) (gfcp (second x)))))
								(ifaceref	(get-bytes 2 2)						;;; interface ref
											(lambda (x) (list (gfcp (car x)) (gfcp (second x)))))
								(nameandtype (get-bytes 2 2)					;;; nameandtype
											 (lambda (x) (list (gfcp (car x)) (get-signature (gfcp (second x))))))
								)
  "Constant pool types, and instructions on parsing them")

;;; Type codes
(defconst jc-field-types '((?B "byte")
						   (?C "char")
						   (?D "double")
						   (?F "float")
						   (?I "integer")
						   (?J "long")
						   (?S "short")
						   (?Z "boolean")
						   (?V "void")
						   (?L "class:" t))
  "Different variable types and their codes
The T in CLASS signals that it needs to get more information")

;;; Special ATTRIBUTE types: these ones have special handling, others
;;; used default function. Feel free to add more (LocalVariableTable,
;;; LineNumberTable...)
(defconst jc-interpret-attributes
  '(("Exceptions"		attribute--Exceptions)
	("InnerClasses"		attribute--InnerClasses))
  "Handler functions for special attributes")

(defun jc-attribute-default-handler (value constant-pool)
  "default handler for attributes not listed in jc-interpret-attributes
If it looks like a constant pool entry use that, otherwise just write it out"
  (let (att-num)
	(if (and (= (length value) 2) (< (setq att-num (jc-get-bytes value 2 0)) (length constant-pool)))
		(get-from-constant-pool att-num constant-pool)
	  ;; The T below marks this as the raw string value, useful for
	  ;; suppressing binary code at output
	  (list value t))))

(defun attribute--Exceptions (value constant-pool)
  "interprets an Exception attribute string"
  (loop with ptr = 0
		repeat (jc-get-bytes value 2 0)
		collect (car (get-from-constant-pool (jc-get-bytes value 2 (setq ptr (+ 2 ptr))) constant-pool))))

(defun attribute--InnerClasses (value constant-pool)
  "interprets an InnerClass attribute string"
	(loop with ptr = 0
		  repeat (jc-get-bytes value 2 0)
		  collect (list (get-from-constant-pool (jc-get-bytes value 2 (setq ptr (+ 2 ptr))) constant-pool)
						(get-from-constant-pool (jc-get-bytes value 2 (setq ptr (+ 2 ptr))) constant-pool)
						(get-from-constant-pool (jc-get-bytes value 2 (setq ptr (+ 2 ptr))) constant-pool)
						(flag-bits  (jc-get-bytes value 2 (setq ptr (+ 2 ptr)))))))

;;; helper functions to read from a string (usually the buffer)
(defun jc-get-bytes-string (string num start)
  "Reads NUM bytes from the string STRING starting from START, and return the result as a string"
 (let* ((val "")
		 (p (or start 0))
		 (end (+ p num)))
	(while (< p end)
	  (setq val (format "%s%.2X" val (aref string p))
			p (1+ p)))
	val))

(defun jc-get-bytes (string num start)
  "Reads NUM bytes from the string STRING starting from START, and return the result as an int
This will fail for big numbers, elisp does not support 32-bit unsigned"
  (let* ((val 0)
		 (p (or start 0))
		 (end (+ p num)))
	(while (< p end)
	  (setq val (+ (* val 256) (aref string p))
			p (1+ p)))
	val))

(defun class-file-check (magic)
  (or (equal magic jc-class-file-magic)
	  (error "Bad magic number, this does not look like a .class file"))
  magic)

(defun flag-bits (bits)
  "interprets the flag bits"
  (loop for flag in jc-flag-bits
		for bit = 1 then (* 2 bit)
		append (if (< 0 (logand bits bit)) (list flag)) into answer
		finally return (if (= 0 (logand bits 7)) (cons 'default answer) answer)
		))

;;; This reads the signature or data type from a string
;;; It would be nice just to call it when making CONSTANT-POOL, but there
;;; is no guarantee the offsets are given in order, so is has to be factored
;;; in later
(defun get-signature (str)
  ;; ugly arefs because emacs can't handle ?( or ?)
  (if (listp str) (setq str (car str)))
  (let* ((open (aref "(" 0))
		 (close (aref ")" 0))
		 (result nil)
		 (sig (= (aref str 0) open))
		 (ptr (if sig 1 0)))
	;; As below, FLET because of references to PTR in the functions
	(flet ((get-type ()
					 (string-match "\\((\\|)\\)?\\(\\[*\\)\\(L\\([^;]*\\)\\)?" str ptr)
					 (let* ((array-depth (- (match-end 2) (match-beginning 2)))
							(desc (or (assoc (aref str (match-end 2)) jc-field-types)
									  (error "Bad field descriptor")))
							(type (if (third desc) (concat (second desc) (match-string 4 str))
									(second desc))))
					   (setq ptr (1+ (match-end 0)))
					   (while (> array-depth 0)
						 (setq type (concat type "[]")
							   array-depth (1- array-depth)))
					   type)))
	  (while (< ptr (length str))
		(setq result (cons (get-type) result)))
	  (if sig (list (car result) (reverse (cdr result))) (car result)))))

(defun /-to-. (string)
  (save-match-data
	(let ((p 0))
	  (while (setq p (string-match "/" string p))
		(setf (aref string p) ?.))
	  string)))

(defun get-from-constant-pool (which constant-pool)
  ;; this is a convenience for the calls
  (flet ((gfcp (w) (get-from-constant-pool w constant-pool)))
	(if (listp which) (setq which (car which)))
	(let* ((item (nth which constant-pool))
		   (desc (assoc (car item) constant-pool-types)))
	  (if desc (funcall (nth 2 desc) (second item))))))

;;; attribute should be a list if it is evaluated, otherwise it is
;;; left a string.  This makes processing easy in the display section
(defun attribute-value (type value constant-pool)
  (funcall (or (second (assoc (car type) jc-interpret-attributes)) 'jc-attribute-default-handler) value constant-pool))

(defun read-class-file ()
  "Reads a java .class file and fills in a list of its data
It uses the FLET because those functions access and change the value of the PTR
variable, which is internal to this function."
  (let* ((ptr 0)					;; buffer pointer used in FLET functions
		 (string (buffer-string))	;; string to parse
		 (double-size nil)			;; used in creation of constant pool for empty (spacing) entries
		 pool-len constant-pool)				;; filled in by loop, needed by later iterations
	(flet ((get-bytes (&rest all)
						(mapcar (lambda (x) (prog1 (jc-get-bytes string x ptr) (setq ptr (+ ptr x)))) all))
		   (get-bytes-string (len)
							   (prog1 (list (jc-get-bytes-string string len ptr)) (setq ptr (+ ptr len))))
		   (get-string (lenlen)
					   (let* ((len (car (get-bytes lenlen)))
							  (from ptr))
						 (list (substring string from (setq ptr (+ ptr len))))))
		   (from-pool () (get-from-constant-pool (get-bytes 2) constant-pool))
		   (read-flag-bits () (flag-bits (car (get-bytes 2))))

		   (read-array (read-one-func count)
					   (loop repeat (- (car (get-bytes 2)) count)
							 collect (funcall read-one-func)))
		   (read-one-constant () (if (not double-size)
									 (let* ((type (car (get-bytes 1)))
											(desc (nth (1- type) constant-pool-types)))
									   (setq double-size (fourth desc))
									   (list (car desc) (eval (second desc))))
								   (setq double-size nil)
								   'fake))
		   (read-one-field () (list (read-flag-bits) (from-pool) (get-signature (from-pool))
									(read-array 'read-one-attribute 0)))
		   (read-one-attribute () (let ((att (from-pool))) (list att (attribute-value att (car (get-string 4)) constant-pool))))
		   )
	  (mapcar 'eval class-desc))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; simple display function to view class file contents
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; attributes not handled above are distinguished by being of the
;;; form (STRING-VALUE t) This way the actual data is still available
;;; in the parsed structure, but the simple display function can
;;; replace the value with a tag
(defun display-one-att (att)
  (if (and (listp (second att)) (eq (second (second att)) t))
	  (if (= 0 (length (car (second att)))) ""
		(format "[binary %d bytes]" (length (car (second att)))))
	(if (stringp (second att)) (concat "\"" (second att) "\"")
	  (second att))))

(defun jc-display-attributes (atts level)
  (loop with indent = (make-string level ?\t)
		for att in atts
		concat (format "%s%s: %s\n" indent (caar att) (display-one-att att))))

(defun jc-find-protection-bits (list)
  (if list
	  (let ((bit 1)
			(bits 0))
		(mapc (lambda (x) (if (member x list) (setq bits (+ bits bit))) (setq bit (* 2 bit))) jc-flag-bits)
		bits)
	0))

(defun list-to-string (l)
  (reduce 'concat l :initial-value "" :key (lambda (x) (format "%s " (if (listp x) (car x) x)))))

(defun jc-add-color (prot &rest text)
  (let* ((string (reduce 'concat  text))
		 (face (cdr (assoc (logand jc-facemask (jc-find-protection-bits prot)) jc-face-map))))
	(and face jc-use-faces (put-text-property 0 (length string) 'face face string))
	string))

(defun class-display-fields/methods (type desc)
  (let ((result ""))
	(if jc-limit-display
		(setq result (format "\n%d Total %s" (length desc) type)
			  desc (remove nil (mapcar (lambda (x) (if (some (lambda (x) (member x jc-limit-display)) (car x)) x)) desc))
			  type (concat (list-to-string jc-limit-display) type)))
	(setq result (format "%s\n%d %s:\n" result (length desc) type))
	(loop for thing in desc
		  do (setq result (concat result
								  (jc-add-color (car thing)
												(format "	- %-10s: %s %s\n" (car (second thing)) (third thing) (car thing))
												(jc-display-attributes (fourth thing) 2)))))
	result))

(defun jc-simple-display (desc)
  "Very basic function to display the important contents of a java .class file"
  (setq buffer-read-only nil)
  (erase-buffer)
  (insert "Class file for class " 	(jc-add-color (nth 3 desc) (car (nth 4 desc))) "\n\n"
		  "Magic number: " 			(car (nth 0 desc)) "\n"
		  "Version: " 				(prin1-to-string (nth 1 desc)) "\n"
		  "Flags: " 				(prin1-to-string (nth 3 desc)) "\n"
		  "Superclass: " 			(car (nth 5 desc)) "\n"
		  "Interfaces: " 			(list-to-string (nth 6 desc)) "\n"
		  "Constant pool length: "  (number-to-string (length (nth 2 desc))) " entries, " 
		  							(number-to-string (nth 10 desc)) " bytes\n"
		  (class-display-fields/methods "Fields" (nth 7 desc))
		  (class-display-fields/methods "Methods" (nth 8 desc))
		  "\nAttributes:\n"
		  (jc-display-attributes (nth 9 desc) 1)
		  )
  (setq buffer-read-only t)
  (goto-char 0)
  )


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Mode stuff
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(require 'crm)

(defvar jc-class-desc nil)
(make-variable-buffer-local 'jc-class-desc)
(make-variable-buffer-local 'jc-limit-display)

(defconst jc-keys 
  '(("q" . bury-buffer)
	("s" . jc-show-type)
	("p" . (lambda () "Display only public method and field definitions from the current java .class file"
		   (interactive) (jc-show-type '(public))))
	("a" . (lambda () "Display all method and field definitions from the current java .class file"
		   (interactive) (jc-show-type 'all)))
	("f" . (lambda () "Jump to field definitions" (interactive) (jc-goto "Fields")))
	("m" . (lambda () "Jump to method definitions" (interactive) (jc-goto "Methods")))
	)
  "key definitions for java-class mode"
  )

(defvar jc-keymap nil)

(defun jc-keymap ()
  (unless jc-keymap
	(setq jc-keymap (make-sparse-keymap))
	(mapc (lambda (x) (define-key jc-keymap (car x) (cdr x))) jc-keys))
  jc-keymap
  )

(defvar java-class-mode-hook nil
  "Run at the very end of java-class-mode.")

(defconst jc-limit-choices (cons '("default") (mapcar '(lambda (x) (list (symbol-name x))) jc-flag-bits)))

(defun jc-goto (type)
  (interactive)
  (goto-char (buffer-size))
  (re-search-backward (concat "\\b[0-9]+ \\(Total \\)?" type))
  )

(defun jc-show-type (&optional type)
  "Filters for the field and method types requested.
More than one type can be entered by separating them with ','"
  (interactive)
  (setq jc-limit-display (if type
							 (if (listp type) type)
						   (mapcar 'intern (completing-read-multiple "Filter fields/methods (enter more than one using ','): " jc-limit-choices nil  ))))
  (jc-simple-display jc-class-desc)
  (message (format "Displaying fields and methods matching %s" (or jc-limit-display "all"))))

(defun java-class-mode ()
  "This is a mode for viewing java class files.
You can add it to AUTO-MODE-ALIST, and invoke it automatically on
jar files by putting the following in your .emacs:

	(require 'java-class)
	(defadvice archive-extract (after expand-java-class activate)
		(if (string-match \"\\\\.class\" buffer-file-name) (java-class-mode)))

Behavior can be customized from the customization group 'java-class.

Defined keys:
	q: hide the buffer
	a: show all methods and fields
	p: show only public methods and fields
	s: reads a list of types to filter for. More than one type can
		be entered. It displays the OR of the requested types, so
		entering \"public,static\" will list all methods and fields 
		that are public OR static, not public AND static.
	m: jump to method definitions
	f: jump to field definitions
"
  (interactive)
  (let ((desc (read-class-file))
		(orig-buffer (current-buffer)))
	;; if there is a problem with the buffer it will break in
	;; READ-CLASS-FILE and will not reach here
	(switch-to-buffer (get-buffer-create (concat "*Class " (file-name-nondirectory (car (nth 4 desc))) "*")))
	(kill-all-local-variables)
	(jc-simple-display desc)
	(and jc-delete-class-buffer (kill-buffer orig-buffer))
	(use-local-map (jc-keymap))
	(setq major-mode 'jc-mode
		  mode-name "javaClass"
		  jc-class-desc desc)
	(run-hooks 'java-class-mode-hook)
	))


(provide 'java-class)