-(defgeneric sql-name (cl)
- )
-
-(defmethod sql-name ((cl hyperobject-class))
- "Return name of SQL table for a class"
- (let* ((sql-name-slot (slot-value cl 'sql-name))
- (name (if (consp sql-name-slot) (car sql-name-slot) sql-name-slot))
- (lisp-name (if name name (class-name cl))))
- (lisp-name-to-sql-name lisp-name)))
-
-(defmethod sql-name ((esd hyperobject-esd))
- (let* ((name (slot-value esd 'sql-name))
- (lisp-name (if name name (slot-definition-name esd))))
- (lisp-name-to-sql-name lisp-name)))
-
-
-(defun lisp-name-to-sql-name (lisp)
- "Convert a lisp name (atom or list, string or symbol) into a canonical
-SQL name"
- (unless (stringp lisp)
- (setq lisp
- (typecase lisp
- (symbol (symbol-name lisp))
- (t (write-to-string lisp)))))
- (let ((sql (make-string (length lisp))))
- (dotimes (i (length lisp))
- (declare (fixnum i))
- (setf (char sql i)
- (let ((c (char lisp i)))
- (case c
- (#\- #\_)
- (#\$ #\_)
- (#\+ #\_)
- (#\# #\_)
- (otherwise c)))))
- (string-upcase sql)))
-