ADN Club > AutoLisp / VisualLISP и DCL
Lisp and XML
(1/1)
Владимир Северюхин:
Собственные базы данных к Автокад - часто используются при решении прикладных задач. Выложу я чужую библиотеку для работы с xml. Я вносил небольшие
правки, правда не помню какие.
Библиотека для работы с xml из lisp.
--- Код - Auto/Visual Lisp [Выбрать] ---;;;************************************************************************;;; api-xml.lsp;;; Prepared by: J. Szewczak;;; Date: 4 January 2004;;; Purpose: To provide an API for interfacing with XML files.;;; Copyright (c) 2004 - AMSEC LLC - All rights reserved;;;************************************************************************;;; Version 2004.01.04;;;************************************************************************ ;;;***********************************************************************;;; MODULE: api-error;;; DESCRIPTION: wraps a function to trap Active-X errors - if error is found;;; DESCRIPTION: function returns nil.;;; ARGS: function to check, list of arguments, boolean (return error message?) T or nil;;; EXAMPLE: (api-error '/ (list 50 0) T) displays "VLISP Error: divide by zero" & returns 'nil';;; Отредактировано by Владимир Северюхин ;;;*********************************************************************** (defun api-error (func lst bool / trap) (cond ( (vl-catch-all-error-p (setq trap (vl-catch-all-apply func lst)) ) (if bool ; (princ (strcat "\nVLISP XML Error: " (vl-catch-all-error-message trap)) ; ) ) (setq trap nil) ) ) trap) ;;;************************************************************************;;; MODULE: XML-Get-Document;;; DESCRIPTION: queries an XML file for the DOM Active-X object;;; ARGS: XML file (string); a variable to store the DOM object;;; EXAMPLE:(XML-Get-Document projfile 'XMLDoc) returns vla-object;;;************************************************************************ (defun XML-Get-Document (file XMLDoc) (if (findfile file) (progn (set XMLDoc (vlax-create-object "MSXML2.DOMDocument.3.0")) ;;create XML-DOM pipeline (vlax-put-property (eval XMLDoc) "async" :vlax-false) (cond ( (api-error 'vlax-invoke-method (list (eval XMLDoc) "Load" file) T) ;; Load Project File into XML-DOM pipeline (eval XMLDoc) ) ) ) (alert "\nXML Document could not be found.") )) ;;;************************************************************************;;; MODULE: XML-Get-XMLObject;;; DESCRIPTION: this gets the top-level parent node object in a given XML Document;;; ARGS: filename (string);;; EXAMPLE: (XML-Get-XMLObject filename) returns VLA-OBJECT;;;************************************************************************ (defun XML-Get-XMLObject (file / docObj xmlTop xmlVer object) (if (findfile file) (progn (setq docObj (XML-Get-Document file 'docObj) xmlTop (vlax-get-property docObj "childNodes") ;; Get the Top Level of the XML xmlVer (vlax-invoke-method xmlTop "nextNode") ;; Gets the XML version element object (vlax-invoke-method xmlTop "nextNode") ;; Gets the Parent element ) ) ) object) ;;;************************************************************************;;; MODULE: XML-Get-ElementKey;;; DESCRIPTION: returns the requested tags text.;;; ARGS: Parent - the parent collection object, tag name - must be unique tag name;;; EXAMPLE: (XML-Get-ElementKey laydef "Name") returns "ANNOTATION";;;************************************************************************ (defun XML-Get-ElementKey (parent tag / el desc) (if (vlax-method-applicable-p parent 'getElementsByTagName) (progn (setq el (vlax-invoke-method parent 'getElementsByTagName tag)) (if (> (vlax-get-property el 'Length) 0) (setq desc (vlax-get-property (vlax-invoke-method el 'nextNode) 'text)) ) (vlax-invoke-method el 'reset) ) (princ "\nXML Object could not be searched.") ) (if desc desc nil)) ;;;************************************************************************;;; MODULE: XML-Get-ElementKey-Object;;; DESCRIPTION: returns the requested tags object.;;; ARGS: Parent - the parent collection object, tag name - must be unique tag name;;; EXAMPLE: (XML-Get-ElementKey-Object laydef "Name") returns VLA-OBJECT;;;************************************************************************ (defun XML-Get-ElementKey-Object (parent tag / el desc) (if (vlax-method-applicable-p parent 'getElementsByTagName) (progn (setq el (vlax-invoke-method parent 'getElementsByTagName tag)) (if (> (vlax-get-property el 'Length) 0) (setq desc (vlax-invoke-method el 'nextNode)) ) (vlax-invoke-method el 'reset) ) (princ "\nXML Object could not be searched.") ) (if desc desc nil)) ;;;************************************************************************;;; MODULE: XML-Get-Parent;;; DESCRIPTION: Gets a top level object from the XML object with the given name;;; ARGS: a valid XML object, the name of the parent level;;; EXAMPLE: (XML-Get-Parent oXML "Leaders") returns VLA-OBJECT;;;************************************************************************ (defun XML-Get-Parent (oXML name) (vlax-invoke-method (vlax-invoke-method oXML 'GetElementsByTagName name) 'peekNode )) ;;;************************************************************************;;; MODULE: XML-Get-Children;;; DESCRIPTION: gets the child object from a parent level;;; ARGS: XML object, Parent name;;; EXAMPLE: none;;;************************************************************************ (defun XML-Get-Children (oXML parentName / return) (cond ( (/= parentName nil) (if (vlax-invoke-method (XML-Get-Parent oXML parentName) 'hasChildNodes) (setq return (vlax-get-property (XML-Get-Parent oXML parentName) 'childNodes)) ) ) ( T (if (vlax-invoke-method oXML 'hasChildNodes) (setq return (vlax-get-property oXML 'childNodes)))) ) return) ;;;************************************************************************;;; MODULE: XML-Get-ChildList;;; DESCRIPTION: returns a list of all child objects under a parent XML Object;;; ARGS: XML object;;; EXAMPLE: (XML-Get-ChildList objXML) returns a list of VLA-Objects;;;************************************************************************ (defun XML-Get-ChildList (oXML / collection child lst) (cond ( (vlax-invoke-method oXML 'hasChildNodes) (setq collection (XML-Get-Children oXML nil)) (while (setq child (vlax-invoke-method collection 'nextNode)) (setq lst (if lst (cons child lst) (list child))) ) (reverse lst) ) (princ "\nObject has no children") )) ;;;************************************************************************;;; MODULE: XML-Get-Child;;; DESCRIPTION: gets a specific child name under the parent level with given name;;; ARGS: XML object, parent level, child name;;; EXAMPLE: (setq oPointers (XML-Get-Child oXML "Leaders" "Pointers")) returns VLA-Object;;; EXAMPLE: (XML-Get-Child oPointers nil "ArrowSize") used you only want to go one deep...;;;************************************************************************ (defun XML-Get-Child (oXML parentName childName / child target) (cond ( (/= parentName nil) (setq child (XML-get-Children oXML parentName))) ( T (setq child (vlax-get-property oXML 'childNodes))) ) (setq target (api-error 'vlax-invoke-method (list child 'nextNode) T)) (while (and target (/= (vlax-get-property target 'tagName) childName) ) (setq target (api-error 'vlax-invoke-method (list child 'nextNode) T)) ) target) ;;;************************************************************************;;; MODULE: XML-Get-Child-ByAttribute;;; DESCRIPTION: gets a specific child name under the parent level with given attribute and attribute value;;; ARGS: XML object, parent level, attribute to search by, attribute value to match;;; EXAMPLE: (XML-Get-Child-ByAttribute oLayers "LayerDefinitions" "Name" "ANNOTATION") returns VLA-OBJECT;;; EXAMPLE: (XML-Get-Child-ByAttribute oLayerDefs nil "Name" "ANNOTATION") used when you only want to go one deep...;;;************************************************************************ (defun XML-Get-Child-ByAttribute (oXML parentName attrib attribValue / parent rtn) (if parentName (setq parent (XML-Get-Child oXML nil parentName)) (setq parent oXML) ) (foreach itm (XML-Get-ChildList parent) (if (= (XML-Get-Attribute itm attrib "") attribValue) (setq rtn itm) ) ) rtn) ;;;************************************************************************;;; MODULE: XML-Get-Child-Value;;; DESCRIPTION: Retrieves the value from the 'Text property of a child element;;; ARGS: XML object, parent Name, Child Name;;; EXAMPLE: (XML-Get-Child-Value oXML "TaskInfo" "FSCM") returns "4T323";;;************************************************************************ (defun XML-Get-Child-Value (oXML parentName childName) (if (XML-Get-Child oXML parentName childName) (vlax-get-property (XML-Get-Child oXML parentName childName) 'text) nil )) ;;;************************************************************************;;; MODULE: XML-Put-Child;;; DESCRIPTION: updates the text in a given child node;;; ARGS: XML object, parent node name, child node to change, value to change to;;; EXAMPLE: (XML-Put-Child oXML "DrawingSetup" "DrawingMode" "MicroScale");;;************************************************************************ (defun XML-Put-Child (oXML parentName childName valu / child return) (if (and valu (setq valu (vl-princ-to-string valu)) (setq child (XML-Get-Child oXML parentName childName)) ) (api-error 'vlax-put-property (list child 'text valu) T) )) ;;;************************************************************************;;; MODULE: XML-Remove-Child;;; DESCRIPTION: removes the specified child object node;;; ARGS: XML node object;;; EXAMPLE: (XML-Remove-Child oXML);;;************************************************************************ (defun XML-Remove-Child (rmvChild / parent) (setq parent (vlax-get-property rmvChild 'parentNode)) (api-error 'vlax-invoke-method (list parent 'removeChild rmvChild) T)) ;;;************************************************************************;;; MODULE: XML-Add-Child;;; DESCRIPTION: adds a Child element to the given parent object;;; ARGS: Parent Level VLA-Object, name of new child;;; EXAMPLE: (XML-Add-Child oXML "LayerKey") returns the newly created child node object;;;************************************************************************ (defun XML-Add-Child (parent name / xmlDoc newElement return) (setq xmlDoc (vlax-get-property parent 'ownerDocument)) (if (not parent) (setq parent xmlDoc)) (if (setq newElement (api-error 'vlax-invoke-method (list xmlDoc 'createElement name) T)) (setq return (api-error 'vlax-invoke-method (list parent 'appendChild newElement) T)) ) return) ;;;************************************************************************;;; MODULE: XML-Get-Attribute;;; DESCRIPTION: returns an XML object's named attribute value;;; ARGS: XML object, attribute name (string), a default value to return if there is no value found in the XML object;;; EXAMPLE: (XML-Get-Attribute oXML "Name" "Default") might return "ANNOTATION";;;************************************************************************ (defun XML-Get-Attribute (oXML name default / att return) (if (setq att (api-error 'vlax-invoke-method (list oXML 'getAttributeNode name) T)) (if att ;; due to the fact that the Text property strips trailing and leading white characters ;; when using the 'get' method. the Value property has been used instead. (vlax-variant-value (vlax-get-Property att "Value")) default ) )) ;;;************************************************************************;;; MODULE: XML-Get-Attribute-List;;; DESCRIPTION: returns a list of strings corresponding to the names of the XML object's attributes;;; ARGS: XML object;;; EXAMPLE: (XML-Get-Attribute-List oXML) might return ("Name" "Color" "LineType" "LineWeight" "Plottable" "Comment");;;************************************************************************ (defun XML-Get-Attribute-List (oXML / lst attCollection count) (if (setq attCollection (vlax-get-property oXML 'attributes)) (progn (setq count 0) (while (< count (vlax-get-property attCollection 'length)) (setq lst (append lst (list (vlax-get-property (vlax-get-property attCollection 'item count) 'Name))) count (1+ count) ) ) ) ) lst) ;;;************************************************************************;;; MODULE: XML-Put-Attribute;;; DESCRIPTION: function to put an XML attribute value -- will add the attribute if not already there;;; ARGS: XML object, attribute name (string), a value to change the attribute to;;; EXAMPLE: (XML-Put-Attribute oXML "Name" "Default") might return vla-object;;;************************************************************************ (defun XML-Put-Attribute (oXML name valu / att return) (cond ( valu (setq valu (vl-princ-to-string valu))) ( (not valu) (setq valu "")) ) (if (not (XML-Get-Attribute oXML name nil)) (XML-Add-Attribute oXML name "") ) (api-error 'vlax-invoke-method (list oXML 'setAttribute name valu) T)) ;;;************************************************************************;;; MODULE: XML-Add-Attribute;;; DESCRIPTION: adds an attribute to the Parent Object with given name, and the optional value;;; ARGS: Parent Level VLA-Object, name of new attribute, value (optional);;; EXAMPLE: (XML-Add-Attribute oXML "Name" "Default") returns the newly created attribute XML object.;;;************************************************************************ (defun XML-Add-Attribute (parent name valu / xmlDoc newAttribute newAtt) (setq xmlDoc (vlax-get-property parent 'ownerDocument)) (if (setq newAttribute (api-error 'vlax-invoke-method (list xmlDoc 'createAttribute name) T)) (progn (setq attNodeMap (vlax-get-property parent 'attributes) newAtt (api-error 'vlax-invoke-method (list attNodeMap 'setNamedItem newAttribute) T) ) (if valu (vlax-put-property newAtt 'Text valu)) ) ) newAtt) ;;;************************************************************************;;; MODULE: XML-Get-Value;;; DESCRIPTION: Retrieves the value from the 'Text property of the supplied XML Element object;;; ARGS: XML object;;; EXAMPLE: (XML-Get-Value oXML) returns "4T323";;;************************************************************************ (defun XML-Get-Value (oXML) (api-error 'vlax-get-property (list oXML 'text) T)) ;;;************************************************************************;;; MODULE: XML-Put-Value;;; DESCRIPTION: Puts a text value into the 'Text property of the supplied XML Element object;;; ARGS: XML object, text string;;; EXAMPLE: (XML-Put-Value oXML "4T323") returns T if successful nil if not.;;;************************************************************************ (defun XML-Put-Value (oXML str) (api-error 'vlax-put-property (list oXML 'text str) T) (if (= (XML-Get-Value oXML) str) T nil )) ;;;************************************************************************;;; MODULE: XML-SaveAs;;; DESCRIPTION: Writes the parsed XML object out to the given file;;; ARGS: XML document object or XML element object, fully qualified filename to save to;;; EXAMPLE: (XML-SaveAs oXML "C:\\projects\\npy structure.swp");;;************************************************************************ (defun XML-SaveAs (oXML file) (cond ( (= (vlax-get-property oXML 'nodeTypeString) "element") (api-error 'vlax-invoke-method (list (vlax-get-property oXML 'ownerDocument) 'save file) T) ) ( T (api-error 'vlax-invoke-method (list oXML 'save file) T)) )) ;;;************************************************************************;;; MODULE: XML-Save;;; DESCRIPTION: Writes the parsed XML object out to its parent file;;; ARGS: XML document object or XML element object;;; EXAMPLE: (XML-Save oXML);;;************************************************************************ (defun XML-Save (oXML / doc file) (cond ( (= (vlax-get-property oXML 'nodeTypeString) "element") (setq doc (vlax-get-property oXML 'ownerDocument)) ) ( T (setq doc oXML)) ) (setq file (vl-string-subst "\\" "/" (vl-string-left-trim "file:///" (vlax-get-property doc 'url)))) (api-error 'vlax-invoke-method (list doc 'save file) T)) ;;;************************************************************************
Небольшой пример нерабочего кода как пример вызова:
--- Код - Auto/Visual Lisp [Выбрать] --- (setq oSoorygenie (XML-Add-Child oMySoorygeniya "Soorygenie") ) (setq sl_alpha_str_ (sl_intos_ sl_alpha_)) (XML-Put-Value (XML-Add-Child oSoorygenie "Znachenie") sl_alpha_str_ ) (XML-Put-Value (XML-Add-Child oSoorygenie "Name") "Угол поворота" ) (XML-Put-Value (XML-Add-Child oSoorygenie "Param") (sl_rtos_ (vlax-curve-getDistAtPoint (vlax-ename->vla-object trent) x) 1 ) )
Алексей Кулик:
Могу выложить свою библиотеку, если хочешь :)
P.S. Практика показала, что крайне желательно хранить и обрабатывать указатель не на весь документ, а на его родительский узел. И нередко требовалось найти узел по значению одного из атрибутов.
P.P.S. xml-файлы, если они требуются, лично я обычно создаю в Notepad++, MS XML Editor или в VisualStudio, и не заполняю их через lisp - возможно, это пока и рано или поздно я дойду до необходимости заполнения xml :)
Навигация
Перейти к полной версии