psgml / psgml-fs.el

Diff from to

psgml-fs.el

 
 
 ;;; Code:
-(provide 'psgml-fs)
+(provide 'psgml-fs) ;; XEmacs change
 (require 'psgml-api)
+(eval-when-compile (require 'cl)
+		   (require 'ps-print))
 
 ;;;; Formatting parameters
 
   (sgml-pop-entity)
   (sit-for 0))
 
-(defun fs-element-content (&optional e)
-  (unless e (setq e (fs-element)))
-  (let ((fs-para-acc "") fs-first-indent fs-left-indent)
-    (sgml-map-content e
-		      (function fs-paraform-phrase)
-		      (function fs-paraform-data)
-		      nil
-		      (function fs-paraform-entity))
-    fs-para-acc))
-
 (defun fs-paraform-phrase (e)
   (sgml-map-content e
 		    (function fs-paraform-phrase)
 			(assq t fs-style)))))
 
 (defun fs-do-style (fs-current-element style)
-  (let ((hang-from (eval (getf style 'hang-from))))
+  (let ((hang-from (eval (plist-get style 'hang-from))))
     (when hang-from
       (setq fs-hang-from
 	    (format "%s%s "
 			collect (cons (car st)
 				      (eval (cadr st))))
 		  fs-char)))
-    (when (getf style 'block)
+    (when (plist-get style 'block)
       (fs-para)
-      (fs-addvspace (or (getf style 'top)
+      (fs-addvspace (or (plist-get style 'top)
 			(fs-char 'default-top))))
-    (let ((before (getf style 'before)))
+    (let ((before (plist-get style 'before)))
       (when before
 	(fs-do-style e before)))
-    (cond ((getf style 'text)
-	   (let ((text (eval (getf style 'text))))
-	     (when (stringp text)
-	       (fs-paraform-data text))))
-	  (t
-           (let ((fs-style
-                  (append (getf style 'sub-style)
-                          fs-style)))
+    (let ((fs-style
+           (append (plist-get style 'sub-style)
+                   fs-style)))
+      (cond ((plist-get style 'text)
+             (let ((text (eval (plist-get style 'text))))
+               (when (stringp text)
+                 (fs-paraform-data text))))
+            (t
              (sgml-map-content e
                                (function fs-engine)
                                (function fs-paraform-data)
                                nil
                                (function fs-paraform-entity)))))
-    (let ((title (getf style 'title)))
+    (let ((title (plist-get style 'title)))
       (when title
         (setq title (eval title))
         (save-excursion
           (set-buffer fs-buffer)
           (setq fs-title title))))
-    (let ((after (getf style 'after)))
+    (let ((after (plist-get style 'after)))
       (when after
 	(fs-do-style e after)))
-    (when (getf style 'block)
+    (when (plist-get style 'block)
       (fs-para)
-      (fs-addvspace (or (getf style 'bottom)
+      (fs-addvspace (or (plist-get style 'bottom)
 			(fs-char 'default-bottom))))))
 
+
+(defun fs-clear ()
+  (setq fs-para-acc ""
+        fs-hang-from nil
+        fs-first-indent nil
+        fs-left-indent nil
+        fs-vspace 0)  )
+
+
+(defun fs-setup-buffer ()
+  (save-excursion
+    (let ((orig-filename (buffer-file-name (current-buffer))))
+      (set-buffer fs-buffer)
+      (erase-buffer)
+      (setq ps-left-header
+            '(fs-title fs-filename))
+      (make-local-variable 'fs-filename)
+      (setq fs-filename (file-name-nondirectory orig-filename))
+      (make-local-variable 'fs-title)
+      (setq fs-title ""))))
+
+(defun fs-wrapper (buffer-name thunk)
+  (fs-clear)
+  (let ((fs-style (fs-get-style fs-style))
+        (fs-buffer (get-buffer-create buffer-name)))
+    (fs-setup-buffer)
+    (funcall thunk)
+    (fs-para)
+    (save-excursion
+      (set-buffer fs-buffer)
+      (goto-char (point-min)))
+    fs-buffer))
+
+
 ;;;###autoload
 (defun style-format ()
   (interactive)
-  (setq fs-para-acc ""
-        fs-hang-from nil
-        fs-first-indent nil
-        fs-left-indent nil
-        fs-vspace 0)
-  (let ((fs-style (fs-get-style fs-style))
-        (fs-buffer (get-buffer-create "*Formatted*")))
-    (save-excursion
-      (let ((orig-filename (buffer-file-name (current-buffer))))
-        (set-buffer fs-buffer)
-        (erase-buffer)
-        (setq ps-left-header
-              '(fs-title fs-filename))
-        (make-local-variable 'fs-filename)
-        (setq fs-filename (file-name-nondirectory orig-filename))
-        (make-local-variable 'fs-title)
-        (setq fs-title "")))
-    (display-buffer fs-buffer)
-    (fs-engine (sgml-top-element))
-    (fs-para)
-    (save-excursion
-      (set-buffer fs-buffer)
-      (goto-char (point-min)))))
+  (fs-wrapper  "*Formatted*"
+               (lambda ()
+                 (display-buffer fs-buffer)
+                 (fs-engine (sgml-top-element)))))
 
 
 ;;;; Helper functions for use in style sheet
         (child  (setq element (sgml-element-content element)))))
     element))
 
+(defun fs-element-content (&optional e)
+  (unless e (setq e (fs-element)))
+  (let ((fs-para-acc "") fs-first-indent fs-left-indent)
+    (sgml-map-content e
+		      (function fs-paraform-phrase)
+		      (function fs-paraform-data)
+		      nil
+		      (function fs-paraform-entity))
+    fs-para-acc))
 
 (defun fs-attval (name &optional element)
   (sgml-element-attval (if element element (fs-element))
         (let ((attlist (sgml-element-attlist element)))
           (loop for attdecl in attlist
                 if (eq 'ID (sgml-attdecl-declared-value attdecl))
-                do (if (equalp id (sgml-element-attval element
-                                                       (sgml-attdecl-name attdecl)))
+                ;; XEmacs change: use equalp if compare-strings not avaialable.
+                do (if (or (and (fboundp 'compare-strings)
+                                (compare-strings id nil nil
+                                                 (sgml-element-attval
+                                                  element
+                                                  (sgml-attdecl-name attdecl))
+                                                 nil nil))
+                           (equalp id (sgml-element-attval
+                                       element (sgml-attdecl-name attdecl))))
                        (return-from func element))))
         ;; Next element
         (if (sgml-element-content element)
           (setq element (sgml-element-next element)))))
     nil))
 
+
+(defun fs-split-tokens (s)
+  "Split a string S into a list of tokens."
+  (let ((result nil))
+    (sgml-push-to-string s)
+    (while (not (eobp))
+      (skip-syntax-forward "-")
+      (let ((start (point)))
+        (skip-syntax-forward "^-")
+        (when (/= start (point))
+          (push (buffer-substring-no-properties start (point))
+                result))))
+    (sgml-pop-entity)
+    (nreverse result)))
+
 
 ;;; fs.el ends here
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.