Windows 95 v2.4 Fix/W95-v2.4fix.iso/ACADWIN/ASE/SAMPLE/ASESMP.LSP

Lisp/Scheme | 1995-02-08 | 23.1 KB | 717 lines

;;;
;;;    asesmp.lsp
;;;
;;;    Copyright (C) 1990, 1992, 1994 by Autodesk, Inc.
;;;
;;;    Permission to use, copy, modify, and distribute this software
;;;    for any purpose and without fee is hereby granted, provided
;;;    that the above copyright notice appears in all copies and
;;;    that both that copyright notice and the limited warranty and
;;;    restricted rights notice below appear in all supporting
;;;    documentation.
;;;
;;;    AUTODESK PROVIDES THIS PROGRAM "AS IS" AND WITH ALL FAULTS.
;;;    AUTODESK SPECIFICALLY DISCLAIMS ANY IMPLIED WARRANTY OF
;;;    MERCHANTABILITY OR FITNESS FOR A PARTICULAR USE.  AUTODESK, INC.
;;;    DOES NOT WARRANT THAT THE OPERATION OF THE PROGRAM WILL BE
;;;    UNINTERRUPTED OR ERROR FREE.
;;;
;;;    Use, duplication, or disclosure by the U.S. Government is suject to
;;;    restrictions set forth in FAR 52.227-19 (Commercial Computer
;;;    Software - Restricted Rights) and DFAR 252.227-7013(c)(1)(ii)
;;;    (Rights in Technical Data and Computer Software), as applicable.
;;;
;;; DESCRIPTION
;;;
;;;    This module contains the following functions:
;;;        (asesmpdo)
;;;        (asesmplpn)
;;;        (asesmplink)
;;;        (asesmpsel)
;;;        (asesmperr)
;;;
;;;    1. (asesmpdo) - Database Object Reference statistic
;;;                    This command demostrates how to get the
;;;                    information by the given Database Object Reference.
;;;
;;;        Command: (asesmpdo)
;;;        Enter DO path:
;;;
;;;            This function prints the information, related to specified DO:
;;;                - DO path code
;;;                - all of the contained names
;;;                - status information
;;;                - updatability
;;;                - related Link Path Names
;;;                - subordinate DO names
;;;                - quantity of the related links
;;;                - quantity of the related entities
;;;
;;;    2. (asesmplpn) - Creating, Erasing, Renaming of LPN(s)
;;;
;;;        Command: (asesmplpn)
;;;        View/Erase/Rename/Create/<eXit>:
;;;            View    - displays Table path and key column names of LPN
;;;            Erase   - erases LPN
;;;            Rename  - renames LPN
;;;            Create  - creates a new LPN
;;;            eXit    - terminates function
;;;
;;;    3. (asesmplink) - Creating, Erasing, Updating of links
;;;
;;;        Command: (asesmplink)
;;;        View/Erase/Update/Create/<eXit>:
;;;            View    - displays link
;;;            Erase   - erases link
;;;            Update  - updates link
;;;            Create  - creates a new link
;;;            eXit    - terminates function
;;;
;;;    4. (asesmpsel) - Links Statistic
;;;                     This command demonstrates how to get
;;;                     the link information
;;;                     for the selected drawing objects.
;;;
;;;        Command: (asesmpsel)
;;;        Select objects:
;;;
;;;            This command asks for the drawing objects selecting and
;;;            prints the statistic for the link information,
;;;            related with the selected entities :
;;;                - total links quantity
;;;                - total links quantity per each LPN
;;;                - Entity Links quantity per each LPN
;;;                - DA links quantity per each LPN
;;;
;;;    5. (asesmperr) - prints ASE error stack
;;;
;;;        Command: (asesmperr)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun *error* (msg / i n)
   (terpri)
   (princ msg)
   (setq n (ase_errqty))
   (setq i 0)
   (while (< i n)
       (progn
           (terpri)
           (princ i)
           (princ ": ")
           (princ (ase_errmsg i))
           (princ " dsc=")
           (princ (ase_errdsc i))
           (princ " code=")
           (princ (ase_errcode i))
           (setq i (+ i 1))
       )
   )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun print_status (status)
    (terpri)
    (princ "Status: ")
    (princ (if (= 0 status) "undefined " ""))
    (princ (if (/= 0 (Boole 1 status 1)) "current " ""))
    (princ (if (/= 0 (Boole 1 status 2)) "registered " ""))
    (princ (if (/= 0 (Boole 1 status 4)) "accessible " ""))
    (princ (if (/= 0 (Boole 1 status 8)) "connected " ""))
    (princ (if (/= 0 (Boole 1 status 16)) "? " ""))
    (terpri)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun getdo (prompt)
   (getstring prompt)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun getlpn (prompt / lpn lst)
   (setq lpn "?")
   (while (equal lpn "?")
       (progn
           (setq lpn (getstring prompt))
           (if (equal lpn "?")
               (if (setq lst (ase_lplist))
                   (princ lst)
                   (*error* "Empty list")
               )
           )
       )
   )
   (if (equal lpn "")
       (setq lpn nil)
       (setq lpn lpn)
   )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun getkey (/ lst col)
   (setq lst nil)
   (setq col "")
   (while col
       (progn
           (setq col (getstring "\nEnter key column name: "))
           (if (equal col "")
               (setq col nil)
               (setq lst (cons col lst))
           )
       )
   )
   (setq lst (reverse lst))
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun getlinkid ()
   (initget 4)
   (getreal "\nEnter ID of existing link: ")
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun printlink (link / i flag item)
   (setq i 0)
   (while (setq flag (nth i link))
       (progn
           (setq i (+ i 1))
           (if (setq item (nth i link))
               (progn
                   (terpri)
                   (if (= flag 1)
                       (progn
                           (princ "ID: ")
                           (princ item)
                       )
                   )
                   (if (= flag 2)
                       (progn
                           (princ "Type: ")
                           (if (= item 2)
                               (princ "DA")
                               (princ "Entity")
                           )
                       )
                   )
                   (if (= flag 3)
                       (progn
                           (princ "Status: ")
                           (princ item)
                       )
                   )
                   (if (= flag 4)
                       (progn
                           (princ "Entity name: ")
                           (princ item)
                       )
                   )
                   (if (= flag 5)
                       (progn
                           (princ "LPN: ")
                           (princ item)
                       )
                   )
                   (if (= flag 6)
                       (progn
                           (princ "Key values: ")
                           (print item)
                       )
                   )
                   (if (= flag 7)
                       (progn
                           (princ "DA column names: ")
                           (princ item)
                       )
                   )
                   (if (= flag 9)
                       (progn
                           (princ "DA column values: ")
                           (print item)
                       )
                   )
                   (if (= flag 10)
                       (progn
                           (princ "Xref/Block: ")
                           (princ item)
                       )
                   )
                   (if (= flag 11)
                       (progn
                           (princ "Reserved attribute: ")
                           (princ item)
                       )
                   )
                   (setq i (+ i 1))
               )
           )
       )
   )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun getentity (/ lst ent )
   (setq lst (entsel "\nSelect object: "))
   (if lst
       (setq ent (car lst))
       (setq ent nil)
   )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun getkeyval (/ cond kword lst val)
   (terpri)
   (princ "Enter key column values")
   (setq lst nil)
   (setq cond t)
   (while cond
       (progn
           (setq val nil)
           (initget 0 "Real Integer String eXit")
           (setq kword (getkword "\nReal/Integer/String/<eXit>: "))
           (if (not kword)
               (setq cond nil)
           )
           (if (equal kword "eXit")
               (setq cond nil)
           )
           (if (equal kword "Real")
               (setq val (getreal "\nEnter real: "))
           )
           (if (equal kword "Integer")
               (setq val (getint "\nEnter integer: "))
           )
           (if (equal kword "String")
               (setq val (getstring "\nEnter string: "))
           )

           (if val
               (setq lst (cons val lst))
           )
       )
   )
   (setq lst (reverse lst))
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; This function prints number of links in the link selection and returns
;; this number
;;
(defun print_lsqty ( lsel / qty )

   ; initial set
   (setq qty 0.)

   (if (or (eq lsel nil)                        ;; bad parameter
       (eq 0 (setq qty (ase_lsqty lsel))))      ;; actual number of links

       (princ "\nNo linked entity selected.")
       (princ (strcat "\nTotal links: " (rtos qty)))
   )

   ; return value
   (setq qty qty)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; This function filters links to the LPN 'lpn' from link selection 'lsel'
;; and prints information of each type of links among them
;;
(defun print_lpn_ls_info (lpn lsel / ls)

   ;; make copy of the current link selection
   (if (setq ls (ase_lscopy lsel))

       (progn

           ;; filter links to the specified lpn
           (ase_lsintersectfilter ls 5 lpn)

           ;; print total links info
           (print_lpn_ls_type_info lpn ls 0)

           ;; print entity links info
           (print_lpn_ls_type_info lpn ls 1)

           ;; print DA links info
           (print_lpn_ls_type_info lpn ls 2)

           ;; remove copy
           (ase_lsfree ls)

       )

       ;; error
       (*error* "Can't copy link selection")
   )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; This function prints information about links of type 'type'
;; among link selection 'lsel', associated with the LPN 'lpn'
;;
(defun print_lpn_ls_type_info (lpn lsel type / ls qty ss)

   ;; make copy of the current link selection
   (if (setq ls (ase_lscopy lsel))

       (progn

           ;; filter ls by link type
           (ase_lsintersectfilter ls 2 type)

           ;; print message
           (cond
               ((= type 1) ; entity link
                   (princ (strcat "\nEntity Links Statistic for DOR [" lpn "]:"))
               )
               ((= type 2) ; DA link
                   (princ (strcat "\nDA Links Statistic for DOR [" lpn "]:"))
               )
               ((= type 0) ; All links
                   (princ (strcat "\nLink Statistic for DOR [" lpn "]:"))
               )
           )

           ;;  print number of links of the specified type
           (if (= 0. (setq qty (ase_lsqty ls)))
               (princ "\nNo Links of the specified type")
               (princ (strcat "\nLinks #" (rtos qty)))
           )

           ;; get selection set, associated with ls and print its length
           (if (setq ss (ase_lsentsel ls))
               (princ (strcat "\nEntities #" (rtos (sslength ss))))
               (princ "\nCan't get the entity selection for link selection")
           )

           ;; free ls
           (ase_lsfree ls)
       )

       ;; error
       (*error* "Can't copy link selection")
   )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; asesmpdo - Database Object Reference statistic
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun asesmpdo (/ do_name subordinate_do ss ls dolist name do_name_list name_code level status i lpn)

   (if (setq do_name (getdo "\nEnter DO path: "))
       (progn

           (setq do_name_list (list "Unknown" "Environment" "Catalog" "Schema" "Table" "LPN" "Full Path" "DO Path" "SQL Table Path"))

           (if (not (setq level (ase_dopathcode do_name)))
               (progn
                   (*error* "Wrong DO name")
                   (exit)
               )
           )

           (terpri)
           (setq status (ase_dostatus do_name))
           (princ (nth level do_name_list))
           (princ "- ")
           (princ do_name)
           (print_status status)

           (if (setq lpn (ase_dopathname do_name 5))
               (progn
                   (terpri)
                   (princ "LPN '")
                   (princ lpn)
                   (princ "': ")
                   (princ (if (ase_lpisupdatable lpn) "is updatable" "isn't updatable"))
                   (terpri)
               )
           )

           (if (< level 4)
               (progn
                   (setq dolist (ase_dolist do_name))
                   (princ "Subordinate DO objects (")
                   (princ (nth (1+ level) do_name_list))
                   (princ "):")
                   (terpri)
                   (setq i 0)
                   (while (setq subordinate_do (nth i dolist))
                       (progn
                           (princ (ase_dopathname subordinate_do (+ 1 level)))
                           (terpri)
                           (setq i (1+ i))
                       )
                   )
               )
           )

           (if (/= 0 (Boole 1 status 2))
               (progn
                   (setq ls (ase_lscreate -3 do_name))
                   (terpri)
                   (princ "Number of the links: ")
                   (princ (ase_lsqty ls))
                   (terpri)
                   (setq ss (ase_lsentsel ls))
                   (princ "Number of the linked objects: ")
                   (princ (sslength ss))
                   (ase_lsfree ls)
               )
           )

;          (setq i 0)
;          (while (and dolist (setq subordinate_do (nth i dolist)))
;              (progn
;                  (asesmpdo subordinate_do)
;                  (setq i (1+ i))
;              )
;          )
       )
   )

   (terpri)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; asesmplpn - Creating, Erasing, Renaming of LPN(s)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun asesmplpn(/ cond kword lpn lpn1 path lst)

   (setq cond t)

;  Main loop
   (while cond

       (progn
;          Get user's key word
           (initget 0 "View Erase Rename Create eXit")
           (setq kword (getkword "\nView/Erase/Rename/Create/<eXit>: "))

           (if (not kword)
;              Exit
               (setq cond nil)
           )

           (if (equal kword "eXit")
;              Exit
               (setq cond nil)
           )

           (if (equal kword "View")
;              View LPN
               (if (setq lpn (getlpn "\nEnter existing LPN or ? for list: "))
                   (progn
;                      Get DO path for LPN
                       (if (not (setq path (ase_lppath lpn)))
                           (*error* "Can't get DO path")
                           (progn
                               (terpri)
                               (princ "DO path: ")
                               (princ path)
                           )
                       )
;                      Get key column names for LPN
                       (if (not (setq lst (ase_lpkey lpn)))
                           (*error* "Can't get key column names")
                           (progn
                               (terpri)
                               (princ "Key column names: ")
                               (princ lst)
                           )
                       )
                   )
               )
           )

           (if (equal kword "Erase")
;              Erase LPN
               (if (setq lpn (getlpn "\nEnter existing LPN or ? for list: "))
                   (if (ase_lperase lpn)
                       (progn
                           (terpri)
                           (princ "OK")
                       )
                       (*error* "Can't erase LPN")
                   )
               )
           )

           (if (equal kword "Rename")
;              Rename LPN
               (if (setq lpn (getlpn "\nEnter existing LPN or ? for list: "))
                   (if (setq lpn1 (getlpn "\nEnter new LPN or ? for list: "))
                       (if (ase_lprename lpn lpn1)
                           (progn
                               (terpri)
                               (princ "OK")
                           )
                           (*error* "Can't rename LPN")
                       )
                   )
               )
           )

           (if (equal kword "Create")
;              Create new LPN
               (if (setq path (getdo "\nEnter table path: "))
                   (if (setq lpn (getlpn "\nEnter new LPN or ? for list: "))
                       (if (setq lst (getkey))
                           (if (ase_lpcreate path lpn lst)
                               (progn
                                   (terpri)
                                   (princ "OK")
                               )
                               (*error* "Can't create LPN")
                           )
                       )
                   )
               )
           )
       )
   )
   (terpri)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; asesmplink - Creating, Erasing, Updating of links
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun asesmplink(/ cond kword id lst ent lpn path lst)

   (setq cond t)

;  Main loop
   (while cond

       (progn
;          Get user's key word
           (initget 0 "View Erase Update Create eXit")
           (setq kword (getkword "\nView/Erase/Update/Create/<eXit>: "))

           (if (not kword)
;              Exit
               (setq cond nil)
           )

           (if (equal kword "eXit")
;              Exit
               (setq cond nil)
           )

           (if (equal kword "View")
;              View link
               (if (setq id (getlinkid))
                   (if (setq lst (ase_linkget id))
                       (printlink lst)
                       (*error* "Can't get link")
                   )
               )
           )

           (if (equal kword "Erase")
;              Erase link
               (if (setq id (getlinkid))
                   (if (ase_linkremove id)
                       (princ "OK")
                       (*error* "Can't erase link")
                   )
               )
           )

           (if (equal kword "Update")
;              Update link
               (if (setq id (getlinkid))
                   (progn

                       (initget 0 "Entity Lpn Key")
                       (setq kword (getkword "\nEntity/Lpn/Key: "))

;                      Change entity
                       (if (equal kword "Entity")
                           (if (setq ent (getentity))
                               (if (ase_linkupdate 1 id 4 ent)
                                   (princ "OK")
                                   (*error* "Can't update link")
                               )
                           )
                       )

;                      Change LPN and Key Values
                       (if (equal kword "Lpn")
                           (if (setq lpn (getlpn "\nEnter existing LPN or ? for list: "))
                               (if (setq lst (getkeyval))
                                   (if (ase_linkupdate 1 id 5 lpn 6 lst)
                                       (princ "OK")
                                       (*error* "Can't update link")
                                   )
                               )
                           )
                       )

;                      Change Key Values
                       (if (equal kword "Key")
                           (if (setq lst (getkeyval))
                               (if (ase_linkupdate 1 id 6 lst)
                                   (princ "OK")
                                   (*error* "Can't update link")
                               )
                           )
                       )
                   )
               )
           )

           (if (equal kword "Create")
;              Create new link
;              This sample can't create DA (only Entity link)
               (if (setq ent (getentity))
                   (if (setq lpn (getlpn "\nEnter existing LPN or ? for list: "))
                       (if (setq lst (getkeyval))
                           (if (setq id (ase_linkcreate 2 1 4 ent 5 lpn 6 lst))
                               (progn
                                   (princ "ID of new link: ")
                                   (princ id)
                               )
                               (*error* "Can't create link")
                           )
                       )
                   )
               )
           )
       )
   )
   (terpri)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; asesmpsel - Links Statistic
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun asesmpsel ( / ss do lsel lpn_list lpn i)

   ;;  select objects
   (if (setq ss (ssget))
       (progn

           ;; create link selection
           (setq lsel (ase_lscreate -2 ss))

           ;; print total number of links in the link selection
           (if (< 0. (print_lsqty lsel))
               (progn

                   // get the list of lpn, associated with link selection
                   (if (setq lpn_list (ase_lslpnames lsel))
                       (progn
                           (setq i 0)
                           (while (setq lpn (nth i lpn_list))
                               (progn
                                   (print_lpn_ls_info lpn lsel)
                                   (princ "\n")
                                   (setq i (+ 1 i))
                               )
                           )
                       )

                       ;; error
                       (*error* "Can't get list of LPNs, associated with link selection")
                   )

                   ;; free link selection
                   (ase_lsfree lsel)
               )
           )
       )
   )

   (terpri)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; asesmperr - prints ASE error stack
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun asesmperr()
   (*error* "ASE error stack:")
)