Lisp and XML

Автор Тема: Lisp and XML  (Прочитано 7842 раз)

0 Пользователей и 1 Гость просматривают эту тему.

Оффлайн Владимир СеверюхинАвтор темы

  • ADN Club
  • Сообщений: 2
  • Карма: 0
  • Skype: sleekka_lamersen
Lisp and XML
« : 26-06-2013, 15:05:55 »
Собственные базы данных к Автокад - часто используются при решении прикладных задач. Выложу я чужую библиотеку для работы с xml. Я вносил небольшие
правки, правда не помню какие.

Библиотека для работы с xml из lisp.

Код - Auto/Visual Lisp [Выбрать]
  1. ;;;************************************************************************
  2. ;;; api-xml.lsp
  3. ;;; Prepared by: J. Szewczak
  4. ;;; Date: 4 January 2004
  5. ;;; Purpose: To provide an API for interfacing with XML files.
  6. ;;; Copyright (c) 2004 - AMSEC LLC - All rights reserved
  7. ;;;************************************************************************
  8. ;;; Version 2004.01.04
  9. ;;;************************************************************************
  10.  
  11. ;;;***********************************************************************
  12. ;;; MODULE: api-error
  13. ;;; DESCRIPTION: wraps a function to trap Active-X errors - if error is found
  14. ;;; DESCRIPTION: function returns nil.
  15. ;;; ARGS: function to check, list of arguments, boolean (return error message?) T or nil
  16. ;;; EXAMPLE: (api-error '/ (list 50 0) T) displays "VLISP Error: divide by zero" & returns 'nil'
  17. ;;; Отредактировано by Владимир Северюхин
  18.  
  19. ;;;***********************************************************************
  20.  
  21. (defun api-error (func lst bool / trap)
  22.   (cond
  23.     ( (vl-catch-all-error-p
  24.         (setq trap (vl-catch-all-apply func lst))
  25.       )
  26.       (if bool
  27.       ; (princ
  28.       (strcat "\nVLISP XML Error: " (vl-catch-all-error-message trap))
  29.       ; )
  30.       )
  31.       (setq trap nil)
  32.     )
  33.   )
  34.   trap
  35. )
  36.  
  37.  
  38. ;;;************************************************************************
  39. ;;; MODULE: XML-Get-Document
  40. ;;; DESCRIPTION: queries an XML file for the DOM Active-X object
  41. ;;; ARGS: XML file (string); a variable to store the DOM object
  42. ;;; EXAMPLE:(XML-Get-Document projfile 'XMLDoc) returns vla-object
  43. ;;;************************************************************************
  44.  
  45. (defun XML-Get-Document (file XMLDoc)
  46.   (if (findfile file)
  47.     (progn
  48.       (set XMLDoc (vlax-create-object "MSXML2.DOMDocument.3.0")) ;;create XML-DOM pipeline
  49.       (vlax-put-property (eval XMLDoc) "async" :vlax-false)
  50.       (cond
  51.         ( (api-error 'vlax-invoke-method (list (eval XMLDoc) "Load" file) T) ;; Load Project File into XML-DOM pipeline
  52.           (eval XMLDoc)
  53.         )
  54.       )
  55.     )
  56.     (alert "\nXML Document could not be found.")
  57.   )
  58. )
  59.  
  60. ;;;************************************************************************
  61. ;;; MODULE: XML-Get-XMLObject
  62. ;;; DESCRIPTION: this gets the top-level parent node object in a given XML Document
  63. ;;; ARGS: filename (string)
  64. ;;; EXAMPLE: (XML-Get-XMLObject filename) returns VLA-OBJECT
  65. ;;;************************************************************************
  66.  
  67. (defun XML-Get-XMLObject (file / docObj xmlTop xmlVer object)
  68.   (if (findfile file)
  69.     (progn
  70.       (setq docObj (XML-Get-Document file 'docObj)
  71.             xmlTop (vlax-get-property docObj "childNodes") ;; Get the Top Level of the XML
  72.             xmlVer (vlax-invoke-method xmlTop "nextNode")  ;; Gets the XML version element
  73.             object (vlax-invoke-method xmlTop "nextNode")  ;; Gets the Parent element
  74.       )
  75.     )
  76.   )
  77.   object
  78. )
  79.  
  80. ;;;************************************************************************
  81. ;;; MODULE: XML-Get-ElementKey
  82. ;;; DESCRIPTION: returns the requested tags text.
  83. ;;; ARGS: Parent - the parent collection object, tag name - must be unique tag name
  84. ;;; EXAMPLE: (XML-Get-ElementKey laydef "Name") returns "ANNOTATION"
  85. ;;;************************************************************************
  86.  
  87. (defun XML-Get-ElementKey (parent tag / el desc)
  88.   (if (vlax-method-applicable-p parent 'getElementsByTagName)
  89.     (progn
  90.       (setq el (vlax-invoke-method parent 'getElementsByTagName tag))
  91.       (if (> (vlax-get-property el 'Length) 0)
  92.         (setq desc (vlax-get-property (vlax-invoke-method el 'nextNode) 'text))
  93.       )
  94.       (vlax-invoke-method el 'reset)
  95.     )
  96.     (princ "\nXML Object could not be searched.")
  97.   )
  98.   (if desc desc nil)
  99. )
  100.  
  101. ;;;************************************************************************
  102. ;;; MODULE: XML-Get-ElementKey-Object
  103. ;;; DESCRIPTION: returns the requested tags object.
  104. ;;; ARGS: Parent - the parent collection object, tag name - must be unique tag name
  105. ;;; EXAMPLE: (XML-Get-ElementKey-Object laydef "Name") returns VLA-OBJECT
  106. ;;;************************************************************************
  107.  
  108. (defun XML-Get-ElementKey-Object (parent tag / el desc)
  109.   (if (vlax-method-applicable-p parent 'getElementsByTagName)
  110.     (progn
  111.       (setq el (vlax-invoke-method parent 'getElementsByTagName tag))
  112.       (if (> (vlax-get-property el 'Length) 0)
  113.         (setq desc (vlax-invoke-method el 'nextNode))
  114.       )
  115.       (vlax-invoke-method el 'reset)
  116.     )
  117.     (princ "\nXML Object could not be searched.")
  118.   )
  119.   (if desc desc nil)
  120. )
  121.  
  122. ;;;************************************************************************
  123. ;;; MODULE: XML-Get-Parent
  124. ;;; DESCRIPTION: Gets a top level object from the XML object with the given name
  125. ;;; ARGS: a valid XML object, the name of the parent level
  126. ;;; EXAMPLE: (XML-Get-Parent oXML "Leaders") returns VLA-OBJECT
  127. ;;;************************************************************************
  128.  
  129. (defun XML-Get-Parent (oXML name)
  130.   (vlax-invoke-method
  131.     (vlax-invoke-method oXML 'GetElementsByTagName name)
  132.    'peekNode
  133.   )
  134. )
  135.  
  136. ;;;************************************************************************
  137. ;;; MODULE: XML-Get-Children
  138. ;;; DESCRIPTION: gets the child object from a parent level
  139. ;;; ARGS: XML object, Parent name
  140. ;;; EXAMPLE: none
  141. ;;;************************************************************************
  142.  
  143. (defun XML-Get-Children (oXML parentName / return)
  144.   (cond
  145.     ( (/= parentName nil)
  146.       (if (vlax-invoke-method (XML-Get-Parent oXML parentName) 'hasChildNodes)
  147.         (setq return (vlax-get-property (XML-Get-Parent oXML parentName) 'childNodes))
  148.       )
  149.     )
  150.     ( T (if (vlax-invoke-method oXML 'hasChildNodes) (setq return (vlax-get-property oXML 'childNodes))))
  151.   )
  152.   return
  153. )
  154.  
  155. ;;;************************************************************************
  156. ;;; MODULE: XML-Get-ChildList
  157. ;;; DESCRIPTION: returns a list of all child objects under a parent XML Object
  158. ;;; ARGS: XML object
  159. ;;; EXAMPLE: (XML-Get-ChildList objXML) returns a list of VLA-Objects
  160. ;;;************************************************************************
  161.  
  162. (defun XML-Get-ChildList (oXML / collection child lst)
  163.   (cond
  164.     ( (vlax-invoke-method oXML 'hasChildNodes)
  165.       (setq collection (XML-Get-Children oXML nil))
  166.       (while (setq child (vlax-invoke-method collection 'nextNode))
  167.         (setq lst (if lst (cons child lst) (list child)))
  168.       )
  169.       (reverse lst)
  170.     )
  171.     (princ "\nObject has no children")
  172.   )
  173. )
  174.  
  175. ;;;************************************************************************
  176. ;;; MODULE: XML-Get-Child
  177. ;;; DESCRIPTION: gets a specific child name under the parent level with given name
  178. ;;; ARGS: XML object, parent level, child name
  179. ;;; EXAMPLE: (setq oPointers (XML-Get-Child oXML "Leaders" "Pointers")) returns VLA-Object
  180. ;;; EXAMPLE: (XML-Get-Child oPointers nil "ArrowSize") used you only want to go one deep...
  181. ;;;************************************************************************
  182.  
  183. (defun XML-Get-Child (oXML parentName childName / child target)
  184.   (cond
  185.     ( (/= parentName nil) (setq child (XML-get-Children oXML parentName)))
  186.     ( T (setq child (vlax-get-property oXML 'childNodes)))
  187.   )
  188.   (setq target (api-error 'vlax-invoke-method (list child 'nextNode) T))
  189.   (while
  190.     (and
  191.       target
  192.       (/= (vlax-get-property target 'tagName) childName)
  193.     )
  194.     (setq target (api-error 'vlax-invoke-method (list child 'nextNode) T))
  195.   )
  196.   target
  197. )
  198.  
  199. ;;;************************************************************************
  200. ;;; MODULE: XML-Get-Child-ByAttribute
  201. ;;; DESCRIPTION: gets a specific child name under the parent level with given attribute and attribute value
  202. ;;; ARGS: XML object, parent level, attribute to search by, attribute value to match
  203. ;;; EXAMPLE: (XML-Get-Child-ByAttribute oLayers "LayerDefinitions" "Name" "ANNOTATION") returns VLA-OBJECT
  204. ;;; EXAMPLE: (XML-Get-Child-ByAttribute oLayerDefs nil "Name" "ANNOTATION") used when you only want to go one deep...
  205. ;;;************************************************************************
  206.  
  207. (defun XML-Get-Child-ByAttribute (oXML parentName attrib attribValue / parent rtn)
  208.   (if parentName
  209.     (setq parent (XML-Get-Child oXML nil parentName))
  210.     (setq parent oXML)
  211.   )
  212.   (foreach itm (XML-Get-ChildList parent)
  213.     (if (= (XML-Get-Attribute itm attrib "") attribValue)
  214.       (setq rtn itm)
  215.     )
  216.   )
  217.   rtn
  218. )
  219.  
  220. ;;;************************************************************************
  221. ;;; MODULE: XML-Get-Child-Value
  222. ;;; DESCRIPTION: Retrieves the value from the 'Text property of a child element
  223. ;;; ARGS: XML object, parent Name, Child Name
  224. ;;; EXAMPLE: (XML-Get-Child-Value oXML "TaskInfo" "FSCM") returns "4T323"
  225. ;;;************************************************************************
  226.  
  227. (defun XML-Get-Child-Value (oXML parentName childName)
  228.   (if (XML-Get-Child oXML parentName childName)
  229.     (vlax-get-property (XML-Get-Child oXML parentName childName) 'text)
  230.     nil
  231.   )
  232. )
  233.  
  234. ;;;************************************************************************
  235. ;;; MODULE: XML-Put-Child
  236. ;;; DESCRIPTION: updates the text in a given child node
  237. ;;; ARGS: XML object, parent node name, child node to change, value to change to
  238. ;;; EXAMPLE: (XML-Put-Child oXML "DrawingSetup" "DrawingMode" "MicroScale")
  239. ;;;************************************************************************
  240.  
  241. (defun XML-Put-Child (oXML parentName childName valu / child return)
  242.   (if
  243.     (and
  244.       valu
  245.       (setq valu (vl-princ-to-string valu))
  246.       (setq child (XML-Get-Child oXML parentName childName))
  247.     )
  248.     (api-error 'vlax-put-property (list child 'text valu) T)
  249.   )
  250. )
  251.  
  252. ;;;************************************************************************
  253. ;;; MODULE: XML-Remove-Child
  254. ;;; DESCRIPTION: removes the specified child object node
  255. ;;; ARGS: XML node object
  256. ;;; EXAMPLE: (XML-Remove-Child oXML)
  257. ;;;************************************************************************
  258.  
  259. (defun XML-Remove-Child (rmvChild / parent)
  260.   (setq parent (vlax-get-property rmvChild 'parentNode))
  261.   (api-error 'vlax-invoke-method (list parent 'removeChild rmvChild) T)
  262. )
  263.  
  264. ;;;************************************************************************
  265. ;;; MODULE: XML-Add-Child
  266. ;;; DESCRIPTION: adds a Child element to the given parent object
  267. ;;; ARGS: Parent Level VLA-Object, name of new child
  268. ;;; EXAMPLE: (XML-Add-Child oXML "LayerKey") returns the newly created child node object
  269. ;;;************************************************************************
  270.  
  271. (defun XML-Add-Child (parent name / xmlDoc newElement return)
  272.   (setq xmlDoc (vlax-get-property parent 'ownerDocument))
  273.   (if (not parent) (setq parent xmlDoc))
  274.   (if (setq newElement (api-error 'vlax-invoke-method (list xmlDoc 'createElement name) T))
  275.     (setq return (api-error 'vlax-invoke-method (list parent 'appendChild newElement) T))
  276.   )
  277.   return
  278. )
  279.  
  280. ;;;************************************************************************
  281. ;;; MODULE: XML-Get-Attribute
  282. ;;; DESCRIPTION: returns an XML object's named attribute value
  283. ;;; ARGS: XML object, attribute name (string), a default value to return if there is no value found in the XML object
  284. ;;; EXAMPLE: (XML-Get-Attribute oXML "Name" "Default") might return "ANNOTATION"
  285. ;;;************************************************************************
  286.  
  287. (defun XML-Get-Attribute (oXML name default / att return)
  288.   (if (setq att (api-error 'vlax-invoke-method (list oXML 'getAttributeNode name) T))
  289.     (if att
  290.       ;; due to the fact that the Text property strips trailing and leading white characters
  291.       ;; when using the 'get' method.  the Value property has been used instead.
  292.       (vlax-variant-value (vlax-get-Property att "Value"))
  293.       default
  294.     )
  295.   )
  296. )
  297.  
  298. ;;;************************************************************************
  299. ;;; MODULE: XML-Get-Attribute-List
  300. ;;; DESCRIPTION: returns a list of strings corresponding to the names of the XML object's attributes
  301. ;;; ARGS: XML object
  302. ;;; EXAMPLE: (XML-Get-Attribute-List oXML) might return ("Name" "Color" "LineType" "LineWeight" "Plottable" "Comment")
  303. ;;;************************************************************************
  304.  
  305. (defun XML-Get-Attribute-List (oXML / lst attCollection count)
  306.   (if (setq attCollection (vlax-get-property oXML 'attributes))
  307.     (progn
  308.       (setq count 0)
  309.       (while (< count (vlax-get-property attCollection 'length))
  310.         (setq lst (append lst (list (vlax-get-property (vlax-get-property attCollection 'item count) 'Name)))
  311.               count (1+ count)
  312.         )
  313.       )
  314.     )
  315.   )
  316.   lst
  317. )
  318.  
  319. ;;;************************************************************************
  320. ;;; MODULE: XML-Put-Attribute
  321. ;;; DESCRIPTION: function to put an XML attribute value -- will add the attribute if not already there
  322. ;;; ARGS: XML object, attribute name (string), a value to change the attribute to
  323. ;;; EXAMPLE: (XML-Put-Attribute oXML "Name" "Default") might return vla-object
  324. ;;;************************************************************************
  325.  
  326. (defun XML-Put-Attribute (oXML name valu / att return)
  327.   (cond
  328.     ( valu (setq valu (vl-princ-to-string valu)))
  329.     ( (not valu) (setq valu ""))
  330.   )
  331.   (if (not (XML-Get-Attribute oXML name nil))
  332.     (XML-Add-Attribute oXML name "")
  333.   )
  334.   (api-error 'vlax-invoke-method (list oXML 'setAttribute name valu) T)
  335. )
  336.  
  337. ;;;************************************************************************
  338. ;;; MODULE: XML-Add-Attribute
  339. ;;; DESCRIPTION: adds an attribute to the Parent Object with given name, and the optional value
  340. ;;; ARGS: Parent Level VLA-Object, name of new attribute, value (optional)
  341. ;;; EXAMPLE: (XML-Add-Attribute oXML "Name" "Default") returns the newly created attribute XML object.
  342. ;;;************************************************************************
  343.  
  344. (defun XML-Add-Attribute (parent name valu / xmlDoc newAttribute newAtt)
  345.   (setq xmlDoc (vlax-get-property parent 'ownerDocument))
  346.   (if (setq newAttribute (api-error 'vlax-invoke-method (list xmlDoc 'createAttribute name) T))
  347.     (progn
  348.       (setq attNodeMap (vlax-get-property parent 'attributes)
  349.             newAtt (api-error 'vlax-invoke-method (list attNodeMap 'setNamedItem newAttribute) T)
  350.       )
  351.       (if valu (vlax-put-property newAtt 'Text valu))
  352.     )
  353.   )
  354.   newAtt
  355. )
  356.  
  357. ;;;************************************************************************
  358. ;;; MODULE: XML-Get-Value
  359. ;;; DESCRIPTION: Retrieves the value from the 'Text property of the supplied XML Element object
  360. ;;; ARGS: XML object
  361. ;;; EXAMPLE: (XML-Get-Value oXML) returns "4T323"
  362. ;;;************************************************************************
  363.  
  364. (defun XML-Get-Value (oXML)
  365.   (api-error 'vlax-get-property (list oXML 'text) T)
  366. )
  367.  
  368. ;;;************************************************************************
  369. ;;; MODULE: XML-Put-Value
  370. ;;; DESCRIPTION: Puts a text value into the 'Text property of the supplied XML Element object
  371. ;;; ARGS: XML object, text string
  372. ;;; EXAMPLE: (XML-Put-Value oXML "4T323") returns T if successful nil if not.
  373. ;;;************************************************************************
  374.  
  375. (defun XML-Put-Value (oXML str)
  376.   (api-error 'vlax-put-property (list oXML 'text str) T)
  377.   (if (= (XML-Get-Value oXML) str)
  378.     T
  379.     nil
  380.   )
  381. )
  382.  
  383. ;;;************************************************************************
  384. ;;; MODULE: XML-SaveAs
  385. ;;; DESCRIPTION: Writes the parsed XML object out to the given file
  386. ;;; ARGS: XML document object or XML element object, fully qualified filename to save to
  387. ;;; EXAMPLE: (XML-SaveAs oXML "C:\\projects\\npy structure.swp")
  388. ;;;************************************************************************
  389.  
  390. (defun XML-SaveAs (oXML file)
  391.   (cond
  392.     ( (= (vlax-get-property oXML 'nodeTypeString) "element")
  393.       (api-error 'vlax-invoke-method (list (vlax-get-property oXML 'ownerDocument) 'save file) T)
  394.     )
  395.     ( T (api-error 'vlax-invoke-method (list oXML 'save file) T))
  396.   )
  397. )
  398.  
  399. ;;;************************************************************************
  400. ;;; MODULE: XML-Save
  401. ;;; DESCRIPTION: Writes the parsed XML object out to its parent file
  402. ;;; ARGS: XML document object or XML element object
  403. ;;; EXAMPLE: (XML-Save oXML)
  404. ;;;************************************************************************
  405.  
  406. (defun XML-Save (oXML / doc file)
  407.   (cond
  408.     ( (= (vlax-get-property oXML 'nodeTypeString) "element")
  409.       (setq doc (vlax-get-property oXML 'ownerDocument))
  410.     )
  411.     ( T (setq doc oXML))
  412.   )
  413.   (setq file (vl-string-subst "\\" "/" (vl-string-left-trim "file:///" (vlax-get-property doc 'url))))
  414.   (api-error 'vlax-invoke-method (list doc 'save file) T)
  415. )
  416.  
  417. ;;;************************************************************************

Небольшой пример нерабочего кода как пример вызова:
Код - Auto/Visual Lisp [Выбрать]
  1.           (setq
  2.            oSoorygenie
  3.            (XML-Add-Child oMySoorygeniya "Soorygenie")
  4.           )
  5.           (setq sl_alpha_str_ (sl_intos_ sl_alpha_))
  6.           (XML-Put-Value
  7.            (XML-Add-Child oSoorygenie "Znachenie")
  8.            sl_alpha_str_
  9.           )
  10.  
  11.           (XML-Put-Value
  12.            (XML-Add-Child oSoorygenie "Name")
  13.            "Угол поворота"
  14.           )
  15.           (XML-Put-Value
  16.            (XML-Add-Child oSoorygenie "Param")
  17.            (sl_rtos_
  18.             (vlax-curve-getDistAtPoint (vlax-ename->vla-object trent) x)
  19.             1
  20.            )
  21.           )
« Последнее редактирование: 21-10-2014, 23:49:33 от Александр Ривилис »

Оффлайн Алексей Кулик

  • Administrator
  • *****
  • Сообщений: 1096
  • Карма: 172
Re: Lisp and XML
« Ответ #1 : 26-06-2013, 16:56:20 »
Могу выложить свою библиотеку, если хочешь :)
P.S. Практика показала, что крайне желательно хранить и обрабатывать указатель не на весь документ, а на его родительский узел. И нередко требовалось найти узел по значению одного из атрибутов.
P.P.S. xml-файлы, если они требуются, лично я обычно создаю в Notepad++, MS XML Editor или в VisualStudio, и не заполняю их через lisp - возможно, это пока и рано или поздно я дойду до необходимости заполнения xml :)
Все, что сказано - личное мнение.

Правила форума существуют не просто так!

Приводя в сообщении код, не забывайте про его форматирование!